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.

2 files changed, 47 insertions, 17 deletions

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 49633aa28..70778f34d 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,14 +129,22 @@
 (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
+  (define assigned (make-hash-table))
   ;;  variables that are assigned
   ;; 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))
@@ -196,6 +225,10 @@
       
       (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 +277,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)
@@ -328,13 +365,6 @@
       
       (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)
   (allocate! x #f 0)
 
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 7c2764236..3ee5c881d 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -529,7 +529,7 @@
           (emit-code #f (make-glil-call 'return 1)))))
 
       ((<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))
@@ -586,7 +586,7 @@
        ;; 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))))
+                   (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
@@ -602,7 +602,7 @@
        ;; Now go back and fix up the bindings.
        (for-each
         (lambda (x v)
-          (let ((free-locs (cdr (hashq-ref allocation x))))
+          (let ((free-locs (cddr (hashq-ref allocation x))))
             (if (not (null? free-locs))
                 (begin
                   (for-each