adding experimental rest-arguments optimization

Makefile

@@ -119,7 +119,8 @@ COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \
 	lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) lib/chibi/net$(SO) \
 	lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \
 	lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \
-	lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
+	lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
+	lib/chibi/optimize/rest$(SO)
 
 libs: $(COMPILED_LIBS)
 

lib/chibi/optimize.module

@@ -0,0 +1,7 @@
+
+(module (chibi optimize)
+  (import (scheme) (chibi ast) (chibi match) (srfi 1))
+  (export register-lambda-optimization!
+          replace-references
+          fold-every join-seq dotted-tail)
+  (include "optimize.scm"))

lib/chibi/optimize.scm

@@ -0,0 +1,52 @@
+
+(define (register-lambda-optimization! proc . o)
+  (define (optimize ast)
+    (match ast
+      (($ Set ref value)
+       (make-set ref (optimize value)))
+      (($ Cnd test pass fail)
+       (make-cnd (optimize test) (optimize pass) (optimize fail)))
+      (($ Seq ls)
+       (make-seq (map optimize ls)))
+      (($ Lam name params body)
+       (lambda-body-set! ast (optimize body))
+       (proc ast))
+      ((app ...)
+       (map optimize app))
+      (else
+       ast)))
+  (register-optimization! optimize (if (pair? o) (car o) 600)))
+
+(define (replace-references ast name lam new)
+  (let replace ((x ast))
+    (match x
+      (($ Ref _ (n . (? lambda? f)))
+       (if (and (eq? n name) (eq? f lam))
+           new
+           x))
+      (($ Set ref value)
+       (make-set (replace ref) (replace value)))
+      (($ Cnd test pass fail)
+       (make-cnd (replace test) (replace pass) (replace fail)))
+      (($ Seq ls)
+       (make-seq (map replace ls)))
+      (($ Lam name params body)
+       (lambda-body-set! x (replace body))
+       x)
+      ((app ...)
+       (map replace app))
+      (else
+       x))))
+
+(define (join-seq a b)
+  (make-seq (append (if (seq? a) (seq-ls a) (list a))
+                    (if (seq? b) (seq-ls b) (list b)))))
+
+(define (dotted-tail ls)
+  (if (pair? ls) (dotted-tail (cdr ls)) ls))
+
+(define (fold-every kons knil ls)
+  (if (null? ls)
+      knil
+      (let ((knil (kons (car ls) knil)))
+        (and knil (fold-every kons knil (cdr ls))))))

lib/chibi/optimize/rest.c

@@ -0,0 +1,31 @@
+/*  rest.c -- low-level utilities for VM rest optimization    */
+/*  Copyright (c) 2011 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+static sexp sexp_num_parameters (sexp ctx sexp_api_params(self, n)) {
+  return sexp_stack_data(sexp_context_stack(ctx))[sexp_context_last_fp(ctx)];
+}
+
+struct sexp_opcode_struct local_ref_op =
+  {SEXP_OPC_GENERIC, SEXP_OP_LOCAL_REF, 1, 8, 0, "local-ref", NULL, NULL,
+   NULL, sexp_make_fixnum(SEXP_OBJECT), sexp_make_fixnum(SEXP_FIXNUM),
+   0, 0, NULL};
+
+static sexp sexp_copy_opcode (sexp ctx, struct sexp_opcode_struct *op) {
+  sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+  memcpy(&(res->value), op, sizeof(op[0]));
+  return res;
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  sexp_define_foreign(ctx, env, "num-parameters", 0, sexp_num_parameters);
+  op = sexp_copy_opcode(ctx, &local_ref_op);
+  name = sexp_intern(ctx, sexp_opcode_name(op), -1);
+  sexp_env_define(ctx, env, name, op);
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}

lib/chibi/optimize/rest.module

@@ -0,0 +1,6 @@
+
+(module (chibi optimize rest)
+  (export optimize-rest rest-parameter-cdrs num-parameters local-ref)
+  (import (scheme) (srfi 1) (chibi ast) (chibi match) (chibi optimize))
+  (include-shared "rest")
+  (include "rest.scm"))

lib/chibi/optimize/rest.scm

@@ -0,0 +1,126 @@
+
+(define (optimize-rest ast)
+  (cond
+   ((and (lambda? ast)
+         (not (list? (lambda-params ast)))
+         (rest-parameter-cdrs ast))
+    => (lambda (cdrs)
+         (replace-rest-destructuring-with-stack-references
+          (length (lambda-params ast))
+          ast
+          cdrs)))
+   (else
+    ast)))
+
+(define safe-primitives (list car cdr null? pair?))
+
+(define (adjust-cdrs cdrs f params args)
+  (filter-map
+   (lambda (p a)
+     (match a
+       (((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
+        (let ((x (any (lambda (r)
+                        (and (eq? name (car r)) (eq? lam (cadr r))))
+                      cdrs)))
+          (and x (list p f (+ (caddr x) 1)))))
+       (($ Cnd
+           ((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam))))
+           ((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam))))
+           (or () ($ Lit ())))
+        (let ((x (any (lambda (r)
+                        (and (eq? name (car r)) (eq? lam (cadr r))))
+                      cdrs)))
+          (and x (list p f (+ (caddr x) 1.0)))))
+       (else #f)))
+   params
+   args))
+
+(define (rest-parameter-cdrs ast)
+  (let analyze ((x (lambda-body ast))
+                (cdrs (list (list (dotted-tail (lambda-params ast)) ast 0)))
+                (safe? #t))
+    (define (recurse x cdrs) (analyze x cdrs safe?))
+    (match x
+      (($ Ref name (_ . (? lambda? f)))
+       (and (not (any (lambda (r) (and (eq? name (car r)) (eq? f (cadr r)))) cdrs))
+            cdrs))
+      (($ Set ref value)
+       (and (recurse ref cdrs) (recurse value cdrs)))
+      (($ Cnd test pass fail)
+       (fold-every recurse cdrs (list test pass fail)))
+      (($ Seq ls)
+       (fold-every recurse cdrs ls))
+      (($ Lam name params body)
+       (analyze body cdrs #f))
+      (((and ($ Lam _ (params ...) body) f) args ...)
+       (let ((cdrs (fold-every recurse cdrs args)))
+         (and (equal? (length params) (length args))
+              (recurse body (append (adjust-cdrs cdrs f params args) cdrs)))))
+      (((? opcode? op) ($ Ref _ (_ . (? lambda?))))
+       (if (and safe? (memq op safe-primitives))
+           cdrs
+           (recurse (cadr x) cdrs)))
+      ((app ...)
+       (fold-every recurse cdrs app))
+      (else
+       cdrs))))
+
+(define (replace-rest-destructuring-with-stack-references base ast cdrs)
+  (define (rename p)
+    (make-syntactic-closure
+     (current-environment) '() (strip-syntactic-closures p)))
+  (define (replace-param x)
+    (match x
+      (($ Cnd test pass fail)
+       (make-cnd (replace-param test)
+                 (replace-param pass)
+                 (replace-param fail)))
+      (($ Seq ls)
+       (let ((ls (map replace-param ls)))
+         (and ls (make-seq ls))))
+      (((? opcode? op) ($ Ref name (_ . (? lambda? f))))
+       (let ((r (and (memq op safe-primitives)
+                     (any (lambda (r) (and (eq? name (car r)) (eq? f (cadr r))))
+                          cdrs))))
+         (cond
+          ((not r)
+           x)
+          ((eq? op car)
+           `(,local-ref ,(+ 1 (inexact->exact (caddr r)))))
+          ((eq? op cdr)
+           (make-lit '()))
+          ((eq? op pair?)
+           `(,> (,num-parameters) ,(+ base (inexact->exact (caddr r)))))
+          ((eq? op null?)
+           `(,<= (,num-parameters) ,(+ base (inexact->exact (caddr r)))))
+          (else
+           x))))
+      (($ Set ref value)
+       #f)
+      (($ Lam name params body)
+       #f)
+      ((app ...)
+       #f)
+      (else
+       x)))
+  (lambda-body-set!
+   ast
+   (let replace ((x (lambda-body ast)))
+     (match x
+       ((($ Lam name (params ...) body) args ...)
+        (let* ((locals (map replace-param args))
+               (names (map rename params))
+               (refs (map (lambda (name) (make-ref name (cons name ast))) names)))
+          (let ((res (fold (lambda (p new res)
+                             (replace-references res p (car x) new))
+                           (replace body)
+                           params
+                           refs)))
+            (lambda-locals-set! ast (append names (lambda-locals ast)))
+            (join-seq (make-seq (map make-set refs locals))
+                      res))))
+       (else
+        x))))
+  ast)
+
+(register-lambda-optimization! optimize-rest)