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.

1 files changed, 195 insertions, 129 deletions

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 3ee5c881d..4880f4754 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,6 +163,7 @@
        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
@@ -188,7 +189,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
@@ -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
@@ -436,30 +476,28 @@
          (emit-branch src 'br-if-not L1)
          (comp-tail then)
          (if (not (eq? context 'tail))
-             (emit-branch #f 'br L2))
+             (emit-branch #f 'br (or RA L2)))
          (emit-label L1)
          (comp-tail else)
          (if (not (eq? context 'tail))
-             (emit-label L2))))
+             (if RA
+                 (emit-branch #f 'br RA)
+                 (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,53 +517,45 @@
          (,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 (cddr (hashq-ref allocation x))))
@@ -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? (cddr (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 (cddr (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))
+                              ((memq (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))