guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-39-gd97


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-1-39-gd97b69d
Date: Fri, 07 Aug 2009 17:08:28 +0000

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=d97b69d9cd7207e947d22b2417defc58560e6457

The branch, master has been updated
       via  d97b69d9cd7207e947d22b2417defc58560e6457 (commit)
       via  230cfcfb3e3558a6981487042cc5358d0da1f8bb (commit)
       via  9059993fe0bf38045ae52552c68d985a3e3c5344 (commit)
      from  9b29d6079184d2d92fef5a1b7eba79f39fa3ef82 (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 d97b69d9cd7207e947d22b2417defc58560e6457
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 7 19:06:15 2009 +0200

    lambda, the ultimate goto
    
    * module/language/tree-il/analyze.scm (analyze-lexicals): Rework to
      actually determine when a fixed-point procedure may be allocated as a
      label.
    * module/language/tree-il/compile-glil.scm (emit-bindings): Always emit
      a <glil-bind>. Otherwise it's too hard to pair with unbindings.
      (flatten-lambda): Consequently, here we only `bind' if there are any
      vars to bind. This doesn't make any difference, given that lambdas
      don't have trailing unbind instructions, but it does keep the GLIL
      output the same for thunks -- no extraneous (bind) instructions. Keeps
      tree-il.test happy.
      (flatten): Some bugfixes. Yaaay, it works!!!

commit 230cfcfb3e3558a6981487042cc5358d0da1f8bb
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 7 17:44:02 2009 +0200

    implement compilation of label-allocated lambda expressions
    
    * module/language/tree-il/compile-glil.scm (flatten-lambda, flatten):
      Implement compilation of label-allocated lambda expressions. Quite
      tricky, we'll see if this works when the new analyzer lands.

commit 9059993fe0bf38045ae52552c68d985a3e3c5344
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 7 15:35:53 2009 +0200

    add label alist to lambda allocations in tree-il->glil compiler
    
    * module/language/tree-il/analyze.scm: Add some more comments about
      something that will land in a future commit: compiling fixpoint
      lambdas as labels.
      (analyze-lexicals): Reorder a bit, and add a label alist to procedure
      allocations. Empty for now.
    
    * module/language/tree-il/compile-glil.scm (flatten): Adapt to the free
      variables being in the cddr of the allocation, not the cdr.

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

Summary of changes:
 module/language/tree-il/analyze.scm      |  226 +++++++++++++++++----
 module/language/tree-il/compile-glil.scm |  336 ++++++++++++++++++------------
 2 files changed, 387 insertions(+), 175 deletions(-)

diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 49633aa..b93a0bd 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -78,6 +78,25 @@
 ;; in a vector. Each closure variable has a unique index into that
 ;; vector.
 ;;
+;; There is one more complication. Procedures bound by <fix> may, in
+;; some cases, be rendered inline to their parent procedure. That is to
+;; say,
+;;
+;;  (letrec ((lp (lambda () (lp)))) (lp))
+;;    => (fix ((lp (lambda () (lp)))) (lp))
+;;      => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
+;;         ^ jump over the loop  ^ the fixpoint lp ^ starting off the loop
+;;
+;; The upshot is that we don't have to allocate any space for the `lp'
+;; closure at all, as it can be rendered inline as a loop. So there is
+;; another kind of allocation, "label allocation", in which the
+;; procedure is simply a label, placed at the start of the lambda body.
+;; The label is the gensym under which the lambda expression is bound.
+;;
+;; The analyzer checks to see that the label is called with the correct
+;; number of arguments. Calls to labels compile to rename + goto.
+;; Lambda, the ultimate goto!
+;;
 ;;
 ;; The return value of `analyze-lexicals' is a hash table, the
 ;; "allocation".
@@ -88,15 +107,17 @@
 ;; in many procedures, it is a two-level map.
 ;;
 ;; The allocation also stored information on how many local variables
-;; need to be allocated for each procedure, and information on what free
-;; variables to capture from its lexical parent procedure.
+;; need to be allocated for each procedure, lexicals that have been
+;; translated into labels, and information on what free variables to
+;; capture from its lexical parent procedure.
 ;;
 ;; That is:
 ;;
 ;;  sym -> {lambda -> address}
-;;  lambda -> (nlocs . free-locs)
+;;  lambda -> (nlocs labels . free-locs)
 ;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda-vars) ...)
 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
 ;; free variable addresses are relative to parent proc.
 
@@ -108,32 +129,52 @@
 (define (analyze-lexicals x)
   ;; bound-vars: lambda -> (sym ...)
   ;;  all identifiers bound within a lambda
+  (define bound-vars (make-hash-table))
   ;; free-vars: lambda -> (sym ...)
   ;;  all identifiers referenced in a lambda, but not bound
   ;;  NB, this includes identifiers referenced by contained lambdas
+  (define free-vars (make-hash-table))
   ;; assigned: sym -> #t
   ;;  variables that are assigned
+  (define assigned (make-hash-table))
   ;; refcounts: sym -> count
   ;;  allows us to detect the or-expansion in O(1) time
-  
+  (define refcounts (make-hash-table))
+  ;; labels: sym -> lambda-vars
+  ;;  for determining if fixed-point procedures can be rendered as
+  ;;  labels. lambda-vars may be an improper list.
+  (define labels (make-hash-table))
+
   ;; returns variables referenced in expr
-  (define (analyze! x proc)
-    (define (step y) (analyze! y proc))
-    (define (recur x new-proc) (analyze! x new-proc))
+  (define (analyze! x proc labels-in-proc tail? tail-call-args)
+    (define (step y) (analyze! y proc labels-in-proc #f #f))
+    (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
+    (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
+                                              (and tail? args)))
+    (define (recur/labels x new-proc labels)
+      (analyze! x new-proc (append labels labels-in-proc) #t #f))
+    (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
     (record-case x
       ((<application> proc args)
-       (apply lset-union eq? (step proc) (map step args)))
+       (apply lset-union eq? (step-tail-call proc args)
+              (map step args)))
 
       ((<conditional> test then else)
-       (lset-union eq? (step test) (step then) (step else)))
+       (lset-union eq? (step test) (step-tail then) (step-tail else)))
 
       ((<lexical-ref> name gensym)
        (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+       (if (not (and tail-call-args
+                     (memq gensym labels-in-proc)
+                     (let ((args (hashq-ref labels gensym)))
+                       (and (list? args)
+                            (= (length args) (length tail-call-args))))))
+           (hashq-set! labels gensym #f))
        (list gensym))
       
       ((<lexical-set> name gensym exp)
-       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
        (hashq-set! assigned gensym #t)
+       (hashq-set! labels gensym #f)
        (lset-adjoin eq? (step exp) gensym))
       
       ((<module-set> mod name public? exp)
@@ -146,7 +187,12 @@
        (step exp))
       
       ((<sequence> exps)
-       (apply lset-union eq? (map step exps)))
+       (let lp ((exps exps) (ret '()))
+         (cond ((null? exps) '())
+               ((null? (cdr exps))
+                (lset-union eq? ret (step-tail (car exps))))
+               (else
+                (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
       
       ((<lambda> vars meta body)
        (let ((locally-bound (let rev* ((vars vars) (out '()))
@@ -166,7 +212,7 @@
        (hashq-set! bound-vars proc
                    (append (reverse vars) (hashq-ref bound-vars proc)))
        (lset-difference eq?
-                        (apply lset-union eq? (step body) (map step vals))
+                        (apply lset-union eq? (step-tail body) (map step vals))
                         vars))
       
       ((<letrec> vars vals body)
@@ -174,15 +220,86 @@
                    (append (reverse vars) (hashq-ref bound-vars proc)))
        (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
        (lset-difference eq?
-                        (apply lset-union eq? (step body) (map step vals))
+                        (apply lset-union eq? (step-tail body) (map step vals))
                         vars))
       
       ((<fix> vars vals body)
+       ;; Try to allocate these procedures as labels.
+       (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+                 vars vals)
        (hashq-set! bound-vars proc
                    (append (reverse vars) (hashq-ref bound-vars proc)))
-       (lset-difference eq?
-                        (apply lset-union eq? (step body) (map step vals))
-                        vars))
+       ;; Step into subexpressions.
+       (let* ((var-refs
+               (map
+                ;; Since we're trying to label-allocate the lambda,
+                ;; pretend it's not a closure, and just recurse into its
+                ;; body directly. (Otherwise, recursing on a closure
+                ;; that references one of the fix's bound vars would
+                ;; prevent label allocation.)
+                (lambda (x)
+                  (record-case x
+                    ((<lambda> (lvars vars) body)
+                     (let ((locally-bound
+                            (let rev* ((lvars lvars) (out '()))
+                              (cond ((null? lvars) out)
+                                    ((pair? lvars) (rev* (cdr lvars)
+                                                         (cons (car lvars) 
out)))
+                                    (else (cons lvars out))))))
+                       (hashq-set! bound-vars x locally-bound)
+                       ;; recur/labels, the difference from the closure case
+                       (let* ((referenced (recur/labels body x vars))
+                              (free (lset-difference eq? referenced 
locally-bound))
+                              (all-bound (reverse! (hashq-ref bound-vars x))))
+                         (hashq-set! bound-vars x all-bound)
+                         (hashq-set! free-vars x free)
+                         free)))))
+                vals))
+              (vars-with-refs (map cons vars var-refs))
+              (body-refs (recur/labels body proc vars)))
+         (define (delabel-dependents! sym)
+           (let ((refs (assq-ref vars-with-refs sym)))
+             (if refs
+                 (for-each (lambda (sym)
+                             (if (hashq-ref labels sym)
+                                 (begin
+                                   (hashq-set! labels sym #f)
+                                   (delabel-dependents! sym))))
+                           refs))))
+         ;; Stepping into the lambdas and the body might have made some
+         ;; procedures not label-allocatable -- which might have
+         ;; knock-on effects. For example:
+         ;;   (fix ((a (lambda () (b)))
+         ;;         (b (lambda () a)))
+         ;;     (a))
+         ;; As far as `a' is concerned, both `a' and `b' are
+         ;; label-allocatable. But `b' references `a' not in a proc-tail
+         ;; position, which makes `a' not label-allocatable. The
+         ;; knock-on effect is that, when back-propagating this
+         ;; information to `a', `b' will also become not
+         ;; label-allocatable, as it is referenced within `a', which is
+         ;; allocated as a closure. This is a transitive relationship.
+         (for-each (lambda (sym)
+                     (if (not (hashq-ref labels sym))
+                         (delabel-dependents! sym)))
+                   vars)
+         ;; Now lift bound variables with label-allocated lambdas to the
+         ;; parent procedure.
+         (for-each
+          (lambda (sym val)
+            (if (hashq-ref labels sym)
+                ;; Remove traces of the label-bound lambda. The free
+                ;; vars will propagate up via the return val.
+                (begin
+                  (hashq-set! bound-vars proc
+                              (append (hashq-ref bound-vars val)
+                                      (hashq-ref bound-vars proc)))
+                  (hashq-remove! bound-vars val)
+                  (hashq-remove! free-vars val))))
+          vars vals)
+         (lset-difference eq?
+                          (apply lset-union eq? body-refs var-refs)
+                          vars)))
       
       ((<let-values> vars exp body)
        (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
@@ -191,11 +308,15 @@
                           (if (null? in) out (cons in out))))))
          (hashq-set! bound-vars proc bound)
          (lset-difference eq?
-                          (lset-union eq? (step exp) (step body))
+                          (lset-union eq? (step exp) (step-tail body))
                           bound)))
       
       (else '())))
   
+  ;; allocation: sym -> {lambda -> address}
+  ;;             lambda -> (nlocs labels . free-locs)
+  (define allocation (make-hash-table))
+  
   (define (allocate! x proc n)
     (define (recur y) (allocate! y proc n))
     (record-case x
@@ -244,9 +365,13 @@
              (free-addresses
               (map (lambda (v)
                      (hashq-ref (hashq-ref allocation v) proc))
-                   (hashq-ref free-vars x))))
+                   (hashq-ref free-vars x)))
+             (labels (filter cdr
+                             (map (lambda (sym)
+                                    (cons sym (hashq-ref labels sym)))
+                                  (hashq-ref bound-vars x)))))
          ;; set procedure allocations
-         (hashq-set! allocation x (cons nlocs free-addresses)))
+         (hashq-set! allocation x (cons* nlocs labels free-addresses)))
        n)
 
       ((<let> vars vals body)
@@ -293,18 +418,46 @@
                (lp (cdr vars) (1+ n))))))
 
       ((<fix> vars vals body)
-       (let lp ((vars vars) (n n))
-         (if (null? vars)
-             (let ((nmax (apply max
-                                (map (lambda (x)
-                                       (allocate! x proc n))
-                                     vals))))
-               (max nmax (allocate! body proc n)))
-             (let ((v (car vars)))
-               (if (hashq-ref assigned v)
-                   (error "fixpoint procedures may not be assigned" x))
-               (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
-               (lp (cdr vars) (1+ n))))))
+       (let lp ((in vars) (n n))
+         (if (null? in)
+             (let lp ((vars vars) (vals vals) (nmax n))
+               (cond
+                ((null? vars)
+                 (max nmax (allocate! body proc n)))
+                ((hashq-ref labels (car vars))                 
+                 ;; allocate label bindings & body inline to proc
+                 (lp (cdr vars)
+                     (cdr vals)
+                     (record-case (car vals)
+                       ((<lambda> vars body)
+                        (let lp ((vars vars) (n n))
+                          (if (not (null? vars))
+                              ;; allocate bindings
+                              (let ((v (if (pair? vars) (car vars) vars)))
+                                (hashq-set!
+                                 allocation v
+                                 (make-hashq
+                                  proc `(#t ,(hashq-ref assigned v) . ,n)))
+                                (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+                              ;; allocate body
+                              (max nmax (allocate! body proc n))))))))
+                (else
+                 ;; allocate closure
+                 (lp (cdr vars)
+                     (cdr vals)
+                     (max nmax (allocate! (car vals) proc n))))))
+             
+             (let ((v (car in)))
+               (cond
+                ((hashq-ref assigned v)
+                 (error "fixpoint procedures may not be assigned" x))
+                ((hashq-ref labels v)
+                 ;; no binding, it's a label
+                 (lp (cdr in) n))
+                (else
+                 ;; allocate closure binding
+                 (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
+                 (lp (cdr in) (1+ n))))))))
 
       ((<let-values> vars exp body)
        (let ((nmax (recur exp)))
@@ -328,14 +481,7 @@
       
       (else n)))
 
-  (define bound-vars (make-hash-table))
-  (define free-vars (make-hash-table))
-  (define assigned (make-hash-table))
-  (define refcounts (make-hash-table))
-  
-  (define allocation (make-hash-table))
-  
-  (analyze! x #f)
+  (analyze! x #f '() #t #f)
   (allocate! x #f 0)
 
   allocation)
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 7c27642..48db6f6 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -37,7 +37,7 @@
 
 ;; allocation:
 ;;  sym -> {lambda -> address}
-;;  lambda -> (nlocs . closure-vars)
+;;  lambda -> (nlocs labels . free-locs)
 ;;
 ;; address := (local? boxed? . index)
 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
@@ -163,10 +163,10 @@
        ids
        vars))
 
+;; FIXME: always emit? otherwise it's hard to pair bind with unbind
 (define (emit-bindings src ids vars allocation proc emit-code)
-  (if (pair? vars)
-      (emit-code src (make-glil-bind
-                      (vars->bind-list ids vars allocation proc)))))
+  (emit-code src (make-glil-bind
+                  (vars->bind-list ids vars allocation proc))))
 
 (define (with-output-to-code proc)
   (let ((out '()))
@@ -188,7 +188,8 @@
                 (else (values (reverse (cons ids oids))
                               (reverse (cons vars ovars))
                               (1+ n) 1))))
-    (let ((nlocs (car (hashq-ref allocation x))))
+    (let ((nlocs (car (hashq-ref allocation x)))
+          (labels (cadr (hashq-ref allocation x))))
       (make-glil-program
        nargs nrest nlocs (lambda-meta x)
        (with-output-to-code
@@ -197,7 +198,8 @@
           (if self-label
               (emit-code #f (make-glil-label self-label)))
           ;; write bindings and source debugging info
-          (emit-bindings #f ids vars allocation x emit-code)
+          (if (not (null? ids))
+              (emit-bindings #f ids vars allocation x emit-code))
           (if (lambda-src x)
               (emit-code #f (make-glil-source (lambda-src x))))
           ;; box args if necessary
@@ -209,35 +211,44 @@
                       (emit-code #f (make-glil-lexical #t #t 'box n)))))
            vars)
           ;; and here, here, dear reader: we compile.
-          (flatten (lambda-body x) allocation x self-label emit-code)))))))
+          (flatten (lambda-body x) allocation x self-label
+                   labels emit-code)))))))
 
-(define (flatten x allocation self self-label emit-code)
+(define (flatten x allocation self self-label fix-labels emit-code)
   (define (emit-label label)
     (emit-code #f (make-glil-label label)))
   (define (emit-branch src inst label)
     (emit-code src (make-glil-branch inst label)))
 
-  ;; LMVRA == "let-values MV return address"
-  (let comp ((x x) (context 'tail) (LMVRA #f))
-    (define (comp-tail tree) (comp tree context LMVRA))
-    (define (comp-push tree) (comp tree 'push #f))
-    (define (comp-drop tree) (comp tree 'drop #f))
-    (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
-
+  ;; RA: "return address"; #f unless we're in a non-tail fix with labels
+  ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
+  (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+    (define (comp-tail tree) (comp tree context RA MVRA))
+    (define (comp-push tree) (comp tree 'push #f #f))
+    (define (comp-drop tree) (comp tree 'drop #f #f))
+    (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+    (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+    ;; A couple of helpers. Note that if we are in tail context, we
+    ;; won't have an RA.
+    (define (maybe-emit-return)
+      (if RA
+          (emit-branch #f 'br RA)
+          (if (eq? context 'tail)
+              (emit-code #f (make-glil-call 'return 1)))))
+    
     (record-case x
       ((<void>)
        (case context
-         ((push vals) (emit-code #f (make-glil-void)))
-         ((tail)
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((push vals tail)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
 
       ((<const> src exp)
        (case context
-         ((push vals) (emit-code src (make-glil-const exp)))
-         ((tail)
-          (emit-code src (make-glil-const exp))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((push vals tail)
+          (emit-code src (make-glil-const exp))))
+       (maybe-emit-return))
 
       ;; FIXME: should represent sequence as exps tail
       ((<sequence> src exps)
@@ -263,7 +274,7 @@
              ;; drop: (lambda () (apply values '(1 2)) 3)
              ;; push: (lambda () (list (apply values '(10 12)) 1))
              (case context
-               ((drop) (for-each comp-drop args))
+               ((drop) (for-each comp-drop args) (maybe-emit-return))
                ((tail)
                 (for-each comp-push args)
                 (emit-code src (make-glil-call 'return/values* (length 
args))))))
@@ -277,12 +288,14 @@
                ((push)
                 (comp-push proc)
                 (for-each comp-push args)
-                (emit-code src (make-glil-call 'apply (1+ (length args)))))
+                (emit-code src (make-glil-call 'apply (1+ (length args))))
+                (maybe-emit-return))
                ((vals)
                 (comp-vals
                  (make-application src (make-primitive-ref #f 'apply)
                                    (cons proc args))
-                 LMVRA))
+                 MVRA)
+                (maybe-emit-return))
                ((drop)
                 ;; Well, shit. The proc might return any number of
                 ;; values (including 0), since it's in a drop context,
@@ -290,8 +303,9 @@
                 ;; mv-call out to our trampoline instead.
                 (comp-drop
                  (make-application src (make-primitive-ref #f 'apply)
-                                   (cons proc args)))))))))
-
+                                   (cons proc args)))
+                (maybe-emit-return)))))))
+        
         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
               (not (eq? context 'push)))
          ;; tail: (lambda () (values '(1 2)))
@@ -299,11 +313,11 @@
          ;; push: (lambda () (list (values '(10 12)) 1))
          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
          (case context
-           ((drop) (for-each comp-drop args))
+           ((drop) (for-each comp-drop args) (maybe-emit-return))
            ((vals)
             (for-each comp-push args)
             (emit-code #f (make-glil-const (length args)))
-            (emit-branch src 'br LMVRA))
+            (emit-branch src 'br MVRA))
            ((tail)
             (for-each comp-push args)
             (emit-code src (make-glil-call 'return/values (length args))))))
@@ -324,7 +338,8 @@
             (comp-vals
              (make-application src (make-primitive-ref #f 'call-with-values)
                                args)
-             LMVRA))
+             MVRA)
+            (maybe-emit-return))
            (else
             (let ((MV (make-label)) (POST (make-label))
                   (producer (car args)) (consumer (cadr args)))
@@ -341,7 +356,8 @@
                 (else   (emit-code src (make-glil-call 'call/nargs 0))
                         (emit-label POST)
                         (if (eq? context 'drop)
-                            (emit-code #f (make-glil-call 'drop 1)))))))))
+                            (emit-code #f (make-glil-call 'drop 1)))
+                        (maybe-emit-return)))))))
 
         ((and (primitive-ref? proc)
               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
@@ -355,16 +371,19 @@
              (make-application
               src (make-primitive-ref #f 'call-with-current-continuation)
               args)
-             LMVRA))
+             MVRA)
+            (maybe-emit-return))
            ((push)
             (comp-push (car args))
-            (emit-code src (make-glil-call 'call/cc 1)))
+            (emit-code src (make-glil-call 'call/cc 1))
+            (maybe-emit-return))
            ((drop)
             ;; Crap. Just like `apply' in drop context.
             (comp-drop
              (make-application
               src (make-primitive-ref #f 'call-with-current-continuation)
-              args)))))
+              args))
+            (maybe-emit-return))))
 
         ((and (primitive-ref? proc)
               (or (hash-ref *primcall-ops*
@@ -376,13 +395,12 @@
               (case (instruction-pushes op)
                 ((0)
                  (case context
-                   ((tail) (emit-code #f (make-glil-void))
-                           (emit-code #f (make-glil-call 'return 1)))
-                   ((push vals) (emit-code #f (make-glil-void)))))
+                   ((tail push vals) (emit-code #f (make-glil-void))))
+                 (maybe-emit-return))
                 ((1)
                  (case context
-                   ((tail) (emit-code #f (make-glil-call 'return 1)))
-                   ((drop) (emit-code #f (make-glil-call 'drop 1)))))
+                   ((drop) (emit-code #f (make-glil-call 'drop 1))))
+                 (maybe-emit-return))
                 (else
                  (error "bad primitive op: too many pushes"
                         op (instruction-pushes op))))))
@@ -401,28 +419,50 @@
          (for-each (lambda (sym)
                      (pmatch (hashq-ref (hashq-ref allocation sym) self)
                        ((#t ,boxed? . ,index)
+                        ;; set unboxed, as the proc prelude will box if needed
                         (emit-code #f (make-glil-lexical #t #f 'set index)))
                        (,x (error "what" x))))
                    (reverse (lambda-vars self)))
          (emit-branch src 'br self-label))
         
+        ;; lambda, the ultimate goto
+        ((and (lexical-ref? proc)
+              (assq (lexical-ref-gensym proc) fix-labels))
+         ;; evaluate new values, assuming that analyze-lexicals did its
+         ;; job, and that the arity was right
+         (for-each comp-push args)
+         ;; rename
+         (for-each (lambda (sym)
+                     (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                       ((#t #f . ,index)
+                        (emit-code #f (make-glil-lexical #t #f 'set index)))
+                       ((#t #t . ,index)
+                        (emit-code #f (make-glil-lexical #t #t 'box index)))
+                       (,x (error "what" x))))
+                   (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
+         ;; goto!
+         (emit-branch src 'br (lexical-ref-gensym proc)))
+        
         (else
          (comp-push proc)
          (for-each comp-push args)
          (let ((len (length args)))
            (case context
              ((tail) (emit-code src (make-glil-call 'goto/args len)))
-             ((push) (emit-code src (make-glil-call 'call len)))
-             ((vals) (emit-code src (make-glil-mv-call len LMVRA)))
-             ((drop)
-              (let ((MV (make-label)) (POST (make-label)))
-                (emit-code src (make-glil-mv-call len MV))
-                (emit-code #f (make-glil-call 'drop 1))
-                (emit-branch #f 'br POST)
-                (emit-label MV)
-                (emit-code #f (make-glil-mv-bind '() #f))
-                (emit-code #f (make-glil-unbind))
-                (emit-label POST))))))))
+             ((push) (emit-code src (make-glil-call 'call len))
+                     (maybe-emit-return))
+             ((vals) (emit-code src (make-glil-mv-call len MVRA))
+                     (maybe-emit-return))
+             ((drop) (let ((MV (make-label)) (POST (make-label)))
+                       (emit-code src (make-glil-mv-call len MV))
+                       (emit-code #f (make-glil-call 'drop 1))
+                       (emit-branch #f 'br (or RA POST))
+                       (emit-label MV)
+                       (emit-code #f (make-glil-mv-bind '() #f))
+                       (emit-code #f (make-glil-unbind))
+                       (if RA
+                           (emit-branch #f 'br RA)
+                           (emit-label POST)))))))))
 
       ((<conditional> src test then else)
        ;;     TEST
@@ -435,31 +475,29 @@
          (comp-push test)
          (emit-branch src 'br-if-not L1)
          (comp-tail then)
-         (if (not (eq? context 'tail))
+         ;; if there is an RA, comp-tail will cause a jump to it -- just
+         ;; have to clean up here if there is no RA.
+         (if (and (not RA) (not (eq? context 'tail)))
              (emit-branch #f 'br L2))
          (emit-label L1)
          (comp-tail else)
-         (if (not (eq? context 'tail))
+         (if (and (not RA) (not (eq? context 'tail)))
              (emit-label L2))))
-
+      
       ((<primitive-ref> src name)
        (cond
         ((eq? (module-variable (fluid-ref *comp-module*) name)
               (module-variable the-root-module name))
          (case context
-           ((push vals)
-            (emit-code src (make-glil-toplevel 'ref name)))
-           ((tail)
-            (emit-code src (make-glil-toplevel 'ref name))
-            (emit-code #f (make-glil-call 'return 1)))))
+           ((tail push vals)
+            (emit-code src (make-glil-toplevel 'ref name))))
+         (maybe-emit-return))
         (else
          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
          (case context
-           ((push vals)
-            (emit-code src (make-glil-module 'ref '(guile) name #f)))
-           ((tail)
-            (emit-code src (make-glil-module 'ref '(guile) name #f))
-            (emit-code #f (make-glil-call 'return 1)))))))
+           ((tail push vals)
+            (emit-code src (make-glil-module 'ref '(guile) name #f))))
+         (maybe-emit-return))))
 
       ((<lexical-ref> src name gensym)
        (case context
@@ -469,8 +507,7 @@
              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
             (,loc
              (error "badness" x loc)))))
-       (case context
-         ((tail) (emit-code #f (make-glil-call 'return 1)))))
+       (maybe-emit-return))
       
       ((<lexical-set> src name gensym exp)
        (comp-push exp)
@@ -480,56 +517,48 @@
          (,loc
           (error "badness" x loc)))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
       
       ((<module-ref> src mod name public?)
        (emit-code src (make-glil-module 'ref mod name public?))
        (case context
-         ((drop) (emit-code #f (make-glil-call 'drop 1)))
-         ((tail) (emit-code #f (make-glil-call 'return 1)))))
+         ((drop) (emit-code #f (make-glil-call 'drop 1))))
+       (maybe-emit-return))
       
       ((<module-set> src mod name public? exp)
        (comp-push exp)
        (emit-code src (make-glil-module 'set mod name public?))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
 
       ((<toplevel-ref> src name)
        (emit-code src (make-glil-toplevel 'ref name))
        (case context
-         ((drop) (emit-code #f (make-glil-call 'drop 1)))
-         ((tail) (emit-code #f (make-glil-call 'return 1)))))
+         ((drop) (emit-code #f (make-glil-call 'drop 1))))
+       (maybe-emit-return))
       
       ((<toplevel-set> src name exp)
        (comp-push exp)
        (emit-code src (make-glil-toplevel 'set name))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
       
       ((<toplevel-define> src name exp)
        (comp-push exp)
        (emit-code src (make-glil-toplevel 'define name))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
 
       ((<lambda>)
-       (let ((free-locs (cdr (hashq-ref allocation x))))
+       (let ((free-locs (cddr (hashq-ref allocation x))))
          (case context
            ((push vals tail)
             (emit-code #f (flatten-lambda x #f allocation))
@@ -543,9 +572,8 @@
                        (else (error "what" x loc))))
                    free-locs)
                   (emit-code #f (make-glil-call 'vector (length free-locs)))
-                  (emit-code #f (make-glil-call 'make-closure 2))))
-            (if (eq? context 'tail)
-                (emit-code #f (make-glil-call 'return 1)))))))
+                  (emit-code #f (make-glil-call 'make-closure 2)))))))
+       (maybe-emit-return))
       
       ((<let> src names vars vals body)
        (for-each comp-push vals)
@@ -580,47 +608,85 @@
        (emit-code #f (make-glil-unbind)))
 
       ((<fix> src names vars vals body)
-       ;; For fixpoint procedures, we can do some tricks to avoid
-       ;; heap-allocation. Since we know the vals are lambdas, we can
-       ;; set them to their local var slots first, then capture their
-       ;; bindings, mutating them in place.
-       (for-each (lambda (x v)
-                   (emit-code #f (flatten-lambda x v allocation))
-                   (if (not (null? (cdr (hashq-ref allocation x))))
-                       ;; But we do have to make-closure them first, so
-                       ;; we are mutating fresh closures on the heap.
-                       (begin
-                         (emit-code #f (make-glil-const #f))
-                         (emit-code #f (make-glil-call 'make-closure 2))))
-                   (pmatch (hashq-ref (hashq-ref allocation v) self)
-                     ((#t #f . ,n)
-                      (emit-code src (make-glil-lexical #t #f 'set n)))
-                     (,loc (error "badness" x loc))))
-                 vals
-                 vars)
-       (emit-bindings src names vars allocation self emit-code)
-       ;; Now go back and fix up the bindings.
-       (for-each
-        (lambda (x v)
-          (let ((free-locs (cdr (hashq-ref allocation x))))
-            (if (not (null? free-locs))
-                (begin
-                  (for-each
-                   (lambda (loc)
-                     (pmatch loc
-                       ((,local? ,boxed? . ,n)
-                        (emit-code #f (make-glil-lexical local? #f 'ref n)))
-                       (else (error "what" x loc))))
-                   free-locs)
-                  (emit-code #f (make-glil-call 'vector (length free-locs)))
-                  (pmatch (hashq-ref (hashq-ref allocation v) self)
-                    ((#t #f . ,n)
-                     (emit-code #f (make-glil-lexical #t #f 'fix n)))
-                    (,loc (error "badness" x loc)))))))
-        vals
-        vars)
-       (comp-tail body)
-       (emit-code #f (make-glil-unbind)))
+       ;; The ideal here is to just render the lambda bodies inline, and
+       ;; wire the code together with gotos. We can do that if
+       ;; analyze-lexicals has determined that a given var has "label"
+       ;; allocation -- which is the case if it is in `fix-labels'.
+       ;;
+       ;; But even for closures that we can't inline, we can do some
+       ;; tricks to avoid heap-allocation for the binding itself. Since
+       ;; we know the vals are lambdas, we can set them to their local
+       ;; var slots first, then capture their bindings, mutating them in
+       ;; place.
+       (let ((RA (if (eq? context 'tail) #f (make-label))))
+         (for-each
+          (lambda (x v)
+            (cond
+             ((hashq-ref allocation x)
+              ;; allocating a closure
+              (emit-code #f (flatten-lambda x v allocation))
+              (if (not (null? (cddr (hashq-ref allocation x))))
+                  ;; Need to make-closure first, but with a temporary #f
+                  ;; free-variables vector, so we are mutating fresh
+                  ;; closures on the heap.
+                  (begin
+                    (emit-code #f (make-glil-const #f))
+                    (emit-code #f (make-glil-call 'make-closure 2))))
+              (pmatch (hashq-ref (hashq-ref allocation v) self)
+                ((#t #f . ,n)
+                 (emit-code src (make-glil-lexical #t #f 'set n)))
+                (,loc (error "badness" x loc))))
+             (else
+              ;; labels allocation: emit label & body, but jump over it
+              (let ((POST (make-label)))
+                (emit-branch #f 'br POST)
+                (emit-label v)
+                ;; we know the lambda vars are a list
+                (emit-bindings #f (lambda-names x) (lambda-vars x)
+                               allocation self emit-code)
+                (if (lambda-src x)
+                    (emit-code #f (make-glil-source (lambda-src x))))
+                (comp-fix (lambda-body x) RA)
+                (emit-code #f (make-glil-unbind))
+                (emit-label POST)))))
+          vals
+          vars)
+         ;; Emit bindings metadata for closures
+         (let ((binds (let lp ((out '()) (vars vars) (names names))
+                        (cond ((null? vars) (reverse! out))
+                              ((assq (car vars) fix-labels)
+                               (lp out (cdr vars) (cdr names)))
+                              (else
+                               (lp (acons (car vars) (car names) out)
+                                   (cdr vars) (cdr names)))))))
+           (emit-bindings src (map cdr binds) (map car binds)
+                          allocation self emit-code))
+         ;; Now go back and fix up the bindings for closures.
+         (for-each
+          (lambda (x v)
+            (let ((free-locs (if (hashq-ref allocation x)
+                                 (cddr (hashq-ref allocation x))
+                                 ;; can hit this latter case for labels 
allocation
+                                 '())))
+              (if (not (null? free-locs))
+                  (begin
+                    (for-each
+                     (lambda (loc)
+                       (pmatch loc
+                         ((,local? ,boxed? . ,n)
+                          (emit-code #f (make-glil-lexical local? #f 'ref n)))
+                         (else (error "what" x loc))))
+                     free-locs)
+                    (emit-code #f (make-glil-call 'vector (length free-locs)))
+                    (pmatch (hashq-ref (hashq-ref allocation v) self)
+                      ((#t #f . ,n)
+                       (emit-code #f (make-glil-lexical #t #f 'fix n)))
+                      (,loc (error "badness" x loc)))))))
+          vals
+          vars)
+         (comp-tail body)
+         (emit-label RA)
+         (emit-code #f (make-glil-unbind))))
 
       ((<let-values> src names vars exp body)
        (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))


hooks/post-receive
-- 
GNU Guile




reply via email to

[Prev in Thread] Current Thread [Next in Thread]