[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-326-g92afe25

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=92afe25d5c162c29d971c2c36bd04a5b9d0b29c5

The branch, wip-rtl-halloween has been updated
       via  92afe25d5c162c29d971c2c36bd04a5b9d0b29c5 (commit)
       via  be6e40a1df4cc97d1bf3d4567e980b92454d5180 (commit)
       via  91fc226e24bea970b5d6814fdceebd3c97c54a28 (commit)
       via  1d15832ffc1e46be2d5549c744681cf88776698e (commit)
       via  03f16599e37d91fdc7564e4baed9a489b2901dec (commit)
      from  14b9aa95e61e2d593bd96ab0a7675ed72d55503c (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 92afe25d5c162c29d971c2c36bd04a5b9d0b29c5
Author: Andy Wingo <address@hidden>
Date:   Sun Nov 3 12:28:47 2013 +0100

    Correctness fix for vector constructor inlining.
    
    * module/language/tree-il/compile-cps.scm (convert): Don't inline the
      vector constructor if any arg could capture the current continuation.

commit be6e40a1df4cc97d1bf3d4567e980b92454d5180
Author: Andy Wingo <address@hidden>
Date:   Sun Nov 3 12:16:49 2013 +0100

    Eval evaluates initializers before creating environment ribs.
    
    * module/ice-9/eval.scm (let-env-evaluator, primitive-eval): Evaluate
      initializers of let expressions before creating the environment rib.
      This prevents call/cc-related shenanigans.

commit 91fc226e24bea970b5d6814fdceebd3c97c54a28
Author: Andy Wingo <address@hidden>
Date:   Sun Nov 3 12:15:09 2013 +0100

    "length" is an interesting primitive
    
    * module/language/tree-il/primitives.scm (*effect-free-primitives*):
      (*interesting-primitive-names*): Add "length", so that we can
      constant-fold it.

commit 1d15832ffc1e46be2d5549c744681cf88776698e
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 1 19:43:45 2013 +0100

    Revert "Compile-time debugging"
    
    This reverts commit 6a37b7faaf150e9fb7945ef79969cb7671d17367.

commit 03f16599e37d91fdc7564e4baed9a489b2901dec
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 1 19:28:36 2013 +0100

    Fix call/cc with the RTL VM
    
    * libguile/vm.c (vm_return_to_continuation): The RTL VM saves the
      registers for the caller of call/cc, but the caller will expect values
      in the normal MV return location: above the frame.  Make it so, number
      four!

-----------------------------------------------------------------------

Summary of changes:
 libguile/vm.c                           |   38 ++++++++++++------------
 module/ice-9/eval.scm                   |   50 ++++++++++++++++++++++++++----
 module/language/cps/compile-rtl.scm     |    6 +---
 module/language/cps/contification.scm   |    6 +--
 module/language/tree-il/compile-cps.scm |   19 +++++++++--
 module/language/tree-il/primitives.scm  |    4 ++-
 6 files changed, 83 insertions(+), 40 deletions(-)

diff --git a/libguile/vm.c b/libguile/vm.c
index c9ce3a3..bf1a269 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -150,7 +150,7 @@ vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM 
*argv)
     scm_misc_error (NULL, "Too few values returned to continuation",
                     SCM_EOL);
 
-  if (vp->stack_size < cp->stack_size + n + 1)
+  if (vp->stack_size < cp->stack_size + n + 4)
     scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
                     scm_list_2 (vm, cont));
 
@@ -167,24 +167,24 @@ vm_return_to_continuation (SCM vm, SCM cont, size_t n, 
SCM *argv)
   vp->fp = cp->fp;
   memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
 
-  if (n == 1 || !cp->mvra)
-    {
-      vp->ip = cp->ra;
-      vp->sp++;
-      *vp->sp = argv_copy[0];
-    }
-  else
-    {
-      size_t i;
-      for (i = 0; i < n; i++)
-        {
-          vp->sp++;
-          *vp->sp = argv_copy[i];
-        }
-      vp->sp++;
-      *vp->sp = scm_from_size_t (n);
-      vp->ip = cp->mvra;
-    }
+  {
+    size_t i;
+
+    /* Push on an empty frame, as the continuation expects.  */
+    for (i = 0; i < 4; i++)
+      {
+        vp->sp++;
+        *vp->sp = SCM_BOOL_F;
+      }
+
+    /* Push the return values.  */
+    for (i = 0; i < n; i++)
+      {
+        vp->sp++;
+        *vp->sp = argv_copy[i];
+      }
+    vp->ip = cp->mvra;
+  }
 }
 
 SCM
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index e34c087..51cdb65 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -79,6 +79,48 @@
              (vector-set! e (1+ width) val)
              (lp (vector-ref e 0) (1- d)))))))
 
+  ;; For evaluating the initializers in a "let" expression.  We have to
+  ;; evaluate the initializers before creating the environment rib, to
+  ;; prevent continuation-related shenanigans; see
+  ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a
+  ;; deeper discussion.
+  ;;
+  ;; This macro will inline evaluation of the first N initializers.
+  ;; That number N is indicated by the number of template arguments
+  ;; passed to the macro.  It's a bit nasty but it's flexible and
+  ;; optimizes well.
+  (define-syntax let-env-evaluator
+    (syntax-rules ()
+      ((eval-and-make-env eval env (template ...))
+       (let ()
+         (define-syntax eval-and-make-env
+           (syntax-rules ()
+             ((eval-and-make-env inits width (template ...) k)
+              (let lp ((n (length '(template ...))) (vals '()))
+                (if (eqv? n width)
+                    (let ((env (make-env n #f env)))
+                      (let lp ((n (1- n)) (vals vals))
+                        (if (null? vals)
+                            (k env)
+                            (begin
+                              (env-set! env 0 n (car vals))
+                              (lp (1- n) (cdr vals))))))
+                    (lp (1+ n)
+                        (cons (eval (vector-ref inits n) env) vals)))))
+             ((eval-and-make-env inits width (var (... ...)) k)
+              (let ((n (length '(var (... ...)))))
+                (if (eqv? n width)
+                    (k (make-env n #f env))
+                    (let* ((x (eval (vector-ref inits n) env))
+                           (k (lambda (env)
+                                (env-set! env 0 n x)
+                                (k env))))
+                      (eval-and-make-env inits width (x var (... ...)) k)))))))
+         (lambda (inits)
+           (let ((width (vector-length inits))
+                 (k (lambda (env) env)))
+             (eval-and-make-env inits width () k)))))))
+
   ;; Fast case for procedures with fixed arities.
   (define-syntax make-fixed-closure
     (lambda (x)
@@ -456,13 +498,7 @@
          x)
 
         (('let (inits . body))
-         (let* ((width (vector-length inits))
-                (new-env (make-env width #f env)))
-           (let lp ((i 0))
-             (when (< i width)
-               (env-set! new-env 0 i (eval (vector-ref inits i) env))
-               (lp (1+ i))))
-           (eval body new-env)))
+         (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
 
         (('lambda (body meta nreq . tail))
          (let ((proc
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 7ed0c11..a842804 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -49,9 +49,7 @@
 (define (optimize exp opts)
   (define (run-pass exp pass kw default)
     (if (kw-arg-ref opts kw default)
-        (begin
-          (pk 'OPTIMIZING kw)
-          (pass exp))
+        (pass exp)
         exp))
 
   ;; Calls to source-to-source optimization passes go here.
@@ -504,13 +502,11 @@
     (_ (values))))
 
 (define (compile-rtl exp env opts)
-  (pk 'COMPILING)
   (let* ((exp (fix-arities exp))
          (exp (optimize exp opts))
          (exp (convert-closures exp))
          (exp (reify-primitives exp))
          (asm (make-assembler)))
-    (pk 'CODEGEN)
     (visit-funs (lambda (fun)
                   (compile-fun fun asm))
                 exp)
diff --git a/module/language/cps/contification.scm 
b/module/language/cps/contification.scm
index aa162e0..da73206 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -348,7 +348,5 @@
       (if (null? call-substs)
           fun
           ;; Iterate to fixed point.
-          (begin
-            (pk 'CONTIFIED (length call-substs))
-            (contify
-             (apply-contification fun call-substs cont-substs fun-elisions 
cont-splices)))))))
+          (contify
+           (apply-contification fun call-substs cont-substs fun-elisions 
cont-splices))))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 9d19062..67f1ec1 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -337,13 +337,24 @@
        (convert (make-conditional src exp (make-const #f #t)
                                   (make-const #f #f))
                 k subst))
-      ((eq? name 'vector)
+      ((and (eq? name 'vector)
+            (and-map (match-lambda
+                      ((or ($ <const>)
+                           ($ <void>)
+                           ($ <lambda>)
+                           ($ <lexical-ref>)) #t)
+                      (_ #f))
+                     args))
        ;; Some macros generate calls to "vector" with like 300
        ;; arguments.  Since we eventually compile to make-vector and
        ;; vector-set!, it reduces live variable pressure to allocate the
-       ;; vector first, then set values as they are produced.  Normally
-       ;; we would do this transformation in the compiler, but it's
-       ;; quite tricky there and quite easy here, so hold your nose
+       ;; vector first, then set values as they are produced, if we can
+       ;; prove that no value can capture the continuation.  (More on
+       ;; that caveat here:
+       ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
+       ;;
+       ;; Normally we would do this transformation in the compiler, but
+       ;; it's quite tricky there and quite easy here, so hold your nose
        ;; while we drop some smelly code.
        (convert (let ((len (length args)))
                   (let-gensyms (v)
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 46bc4eb..5e4f388 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -73,6 +73,8 @@
     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 
+    length
+
     make-vector vector-length vector-ref vector-set!
     variable? variable-ref variable-set!
     variable-bound?
@@ -165,7 +167,7 @@
     char<? char<=? char>=? char>?
     integer->char char->integer number->string string->number
     struct-vtable
-    string-length vector-length
+    length string-length vector-length
     ;; These all should get expanded out by expand-primitives.
     caar cadr cdar cddr
     caaar caadr cadar caddr cdaar cdadr cddar cdddr


hooks/post-receive
-- 
GNU Guile