compile lexical variable access and closure creation to the new ops

* module/language/glil.scm (<glil>): New GLIL type, <glil-lexical>,
  which will subsume other lexical types.
* module/language/glil/compile-assembly.scm: Compile <glil-lexical>.
  (make-open-binding): Change the interpretation of the second argument
  -- instead of indicating an "external" var, it now indicates a boxed
  var.
  (open-binding): Adapt to new glil-bind format.
* module/language/tree-il/analyze.scm: Add a lot more docs.
  (analyze-lexicals): Change the allocation algorithm and output format
  to allow the tree-il->glil compiler to capture free variables
  appropriately and to reference bound variables in boxes if necessary.
  Amply documented.

* module/language/tree-il/compile-glil.scm (compile-glil): Compile
  lexical variable access to <glil-lexical>. Emit variable capture and
  closure creation code here, instead of leaving that task to the
  GLIL->assembly compiler.

* test-suite/tests/tree-il.test: Update expected code emission.

module/language/glil.scm

@@ -1,6 +1,6 @@
 ;;; Guile Low Intermediate Language
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -49,6 +49,9 @@
    <glil-external> make-glil-external glil-external?
    glil-external-op glil-external-depth glil-external-index
 
+   <glil-lexical> make-glil-lexical glil-lexical?
+   glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
+
    <glil-toplevel> make-glil-toplevel glil-toplevel?
    glil-toplevel-op glil-toplevel-name
 
@@ -85,6 +88,7 @@
   ;; Variables
   (<glil-local> op index)
   (<glil-external> op depth index)
+  (<glil-lexical> local? boxed? op index)
   (<glil-toplevel> op name)
   (<glil-module> op mod name public?)
   ;; Controls
@@ -122,6 +126,7 @@
     ((const ,obj) (make-glil-const obj))
     ((local ,op ,index) (make-glil-local op index))
     ((external ,op ,depth ,index) (make-glil-external op depth index))
+    ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
     ((toplevel ,op ,name) (make-glil-toplevel op name))
     ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
     ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
@@ -144,10 +149,10 @@
     ((<glil-void>) `(void))
     ((<glil-const> obj) `(const ,obj))
     ;; variables
-    ((<glil-local> op index)
-     `(local ,op ,index))
     ((<glil-external> op depth index)
      `(external ,op ,depth ,index))
+    ((<glil-lexical> local? boxed? op index)
+     `(lexical ,local? ,boxed? ,op ,index))
     ((<glil-toplevel> op name)
      `(toplevel ,op ,name))
     ((<glil-module> op mod name public?)

module/language/glil/compile-assembly.scm

@@ -78,8 +78,8 @@
                            (make-glil-call 'return 1))))))
 
 ;; A functional stack of names of live variables.
-(define (make-open-binding name ext? index)
-  (list name ext? index))
+(define (make-open-binding name boxed? index)
+  (list name boxed? index))
 (define (make-closed-binding open-binding start end)
   (make-binding (car open-binding) (cadr open-binding)
                 (caddr open-binding) start end))
@@ -89,8 +89,8 @@
           (map
            (lambda (v)
              (pmatch v
-               ((,name local ,i) (make-open-binding name #f i))
-               ((,name external ,i) (make-open-binding name #t i))
+               ((,name ,boxed? ,i)
+                (make-open-binding name boxed? i))
                (else (error "unknown binding type" v))))
            vars)
           (car bindings))
@@ -257,6 +257,21 @@
                           `((external-ref ,(+ n index)))
                           `((external-set ,(+ n index))))))))
 
+    ((<glil-lexical> local? boxed? op index)
+     (emit-code
+      `((,(if local?
+              (case op
+                ((ref) (if boxed? 'local-boxed-ref 'local-ref))
+                ((set) (if boxed? 'local-boxed-set 'local-set))
+                ((box) 'box)
+                ((empty-box) 'empty-box)
+                (else (error "what" op)))
+              (case op
+                ((ref) (if boxed? 'closure-boxed-ref 'closure-ref))
+                ((set) (if boxed? 'closure-boxed-set (error "what." glil)))
+                (else (error "what" op))))
+         ,index))))
+    
     ((<glil-toplevel> op name)
      (case op
        ((ref set)

module/language/tree-il/analyze.scm

@@ -19,14 +19,37 @@
 ;;; Code:
 
 (define-module (language tree-il analyze)
+  #:use-module (srfi srfi-1)
   #:use-module (system base syntax)
   #:use-module (language tree-il)
   #:export (analyze-lexicals))
 
-;; allocation: the process of assigning a type and index to each var
-;; a var is external if it is heaps; assigning index is easy
-;; args are assigned in order
-;; locals are indexed as their linear position in the binding path
+;; Allocation is the process of assigning storage locations for lexical
+;; variables. A lexical variable has a distinct "address", or storage
+;; location, for each procedure in which it is referenced.
+;;
+;; A variable is "local", i.e., allocated on the stack, if it is
+;; referenced from within the procedure that defined it. Otherwise it is
+;; a "closure" variable. For example:
+;;
+;;    (lambda (a) a) ; a will be local
+;; `a' is local to the procedure.
+;;
+;;    (lambda (a) (lambda () a))
+;; `a' is local to the outer procedure, but a closure variable with
+;; respect to the inner procedure.
+;;
+;; If a variable is ever assigned, it needs to be heap-allocated
+;; ("boxed"). This is so that closures and continuations capture the
+;; variable's identity, not just one of the values it may have over the
+;; course of program execution. If the variable is never assigned, there
+;; is no distinction between value and identity, so closing over its
+;; identity (whether through closures or continuations) can make a copy
+;; of its value instead.
+;;
+;; Local variables are stored on the stack within a procedure's call
+;; frame. Their index into the stack is determined from their linear
+;; postion within a procedure's binding path:
 ;; (let (0 1)
 ;;   (let (2 3) ...)
 ;;   (let (2) ...))
@@ -48,49 +71,67 @@
 ;; case. A proper solution would be some sort of liveness analysis, and
 ;; not our linear allocation algorithm.
 ;;
-;; allocation:
-;;  sym -> (local . index) | (heap level . index)
-;;  lambda -> (nlocs . nexts)
+;; Closure variables are captured when a closure is created, and stored
+;; in a vector. Each closure variable has a unique index into that
+;; vector.
+;;
+;;
+;; The return value of `analyze-lexicals' is a hash table, the
+;; "allocation".
+;;
+;; The allocation maps gensyms -- recall that each lexically bound
+;; variable has a unique gensym -- to storage locations ("addresses").
+;; Since one gensym may have many storage locations, if it is referenced
+;; 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.
+;;
+;; That is:
+;;
+;;  sym -> {lambda -> address}
+;;  lambda -> (nlocs . free-locs)
+;;
+;; address := (local? boxed? . index)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define (make-hashq k v)
+  (let ((res (make-hash-table)))
+    (hashq-set! res k v)
+    res))
 
 (define (analyze-lexicals x)
-  ;; parents: lambda -> parent
-  ;;  useful when we see a closed-over var, so we can calculate its
-  ;;  coordinates (depth and index).
-  ;; bindings: lambda -> (sym ...)
-  ;;  useful for two reasons: one, so we know how much space to allocate
-  ;;  when we go into a lambda; and two, so that we know when to stop,
-  ;;  when looking for closed-over vars.
-  ;; heaps: sym -> lambda
-  ;;  allows us to heapify vars in an O(1) fashion
+  ;; bound-vars: lambda -> (sym ...)
+  ;;  all identifiers bound within a lambda
+  ;; free-vars: lambda -> (sym ...)
+  ;;  all identifiers referenced in a lambda, but not bound
+  ;;  NB, this includes identifiers referenced by contained lambdas
+  ;; assigned: sym -> #t
+  ;;  variables that are assigned
   ;; refcounts: sym -> count
-  ;;  allows us to detect the or-expansion an O(1) time
-
-  (define (find-heap sym parent)
-    ;; fixme: check displaced lexicals here?
-    (if (memq sym (hashq-ref bindings parent))
-        parent
-        (find-heap sym (hashq-ref parents parent))))
-
-  (define (analyze! x parent level)
-    (define (step y) (analyze! y parent level))
-    (define (recur x parent) (analyze! x parent (1+ level)))
+  ;;  allows us to detect the or-expansion in O(1) time
+  
+  ;; returns variables referenced in expr
+  (define (analyze! x proc)
+    (define (step y) (analyze! y proc))
+    (define (recur x new-proc) (analyze! x new-proc))
     (record-case x
       ((<application> proc args)
-       (step proc) (for-each step args))
+       (apply lset-union eq? (step proc) (map step args)))
 
       ((<conditional> test then else)
-       (step test) (step then) (step else))
+       (lset-union eq? (step test) (step then) (step else)))
 
       ((<lexical-ref> name gensym)
        (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
-       (if (and (not (memq gensym (hashq-ref bindings parent)))
-                (not (hashq-ref heaps gensym)))
-           (hashq-set! heaps gensym (find-heap gensym parent))))
+       (list gensym))
       
       ((<lexical-set> name gensym exp)
-       (step exp)
-       (if (not (hashq-ref heaps gensym))
-           (hashq-set! heaps gensym (find-heap gensym parent))))
+       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+       (hashq-set! assigned gensym #t)
+       (lset-adjoin eq? (step exp) gensym))
       
       ((<module-set> mod name public? exp)
        (step exp))
@@ -102,157 +143,168 @@
        (step exp))
       
       ((<sequence> exps)
-       (for-each step exps))
+       (apply lset-union eq? (map step exps)))
       
       ((<lambda> vars meta body)
-       (hashq-set! parents x parent)
-       (hashq-set! bindings x
-                   (let rev* ((vars vars) (out '()))
-                     (cond ((null? vars) out)
-                           ((pair? vars) (rev* (cdr vars)
-                                               (cons (car vars) out)))
-                           (else (cons vars out)))))
-       (recur body x)
-       (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
-
+       (let ((locally-bound (let rev* ((vars vars) (out '()))
+                              (cond ((null? vars) out)
+                                    ((pair? vars) (rev* (cdr vars)
+                                                        (cons (car vars) out)))
+                                    (else (cons vars out))))))
+         (hashq-set! bound-vars x locally-bound)
+         (let* ((referenced (recur body x))
+                (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)))
+      
       ((<let> vars vals body)
-       (for-each step vals)
-       (hashq-set! bindings parent
-                   (append (reverse vars) (hashq-ref bindings parent)))
-       (step body))
+       (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))
       
       ((<letrec> vars vals body)
-       (hashq-set! bindings parent
-                   (append (reverse vars) (hashq-ref bindings parent)))
-       (for-each step vals)
-       (step body))
-
+       (hashq-set! bound-vars proc
+                   (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))
+                        vars))
+      
       ((<let-values> vars exp body)
-       (hashq-set! bindings parent
-                   (let lp ((out (hashq-ref bindings parent)) (in vars))
+       (hashq-set! bound-vars proc
+                   (let lp ((out (hashq-ref bound-vars proc)) (in vars))
                      (if (pair? in)
                          (lp (cons (car in) out) (cdr in))
                          (if (null? in) out (cons in out)))))
-       (step exp)
-       (step body))
+       (lset-difference eq?
+                        (lset-union eq? (step exp) (step body))
+                        vars))
+      
+      (else '())))
+  
+  (define (allocate! x proc n)
+    (define (recur y) (allocate! y proc n))
+    (record-case x
+      ((<application> proc args)
+       (apply max (recur proc) (map recur args)))
 
-      (else #f)))
+      ((<conditional> test then else)
+       (max (recur test) (recur then) (recur else)))
 
-    (define (allocate-heap! binder)
-      (hashq-set! heap-indexes binder
-                  (1+ (hashq-ref heap-indexes binder -1))))
+      ((<lexical-set> name gensym exp)
+       (recur exp))
+      
+      ((<module-set> mod name public? exp)
+       (recur exp))
+      
+      ((<toplevel-set> name exp)
+       (recur exp))
+      
+      ((<toplevel-define> name exp)
+       (recur exp))
+      
+      ((<sequence> exps)
+       (apply max (map recur exps)))
+      
+      ((<lambda> vars meta body)
+       ;; allocate closure vars in order
+       (let lp ((c (hashq-ref free-vars x)) (n 0))
+         (if (pair? c)
+             (begin
+               (hashq-set! (hashq-ref allocation (car c))
+                           x
+                           `(#f ,(hashq-ref assigned (car c)) . ,n))
+               (lp (cdr c) (1+ n)))))
+      
+       (let ((nlocs
+              (let lp ((vars vars) (n 0))
+                (if (not (null? vars))
+                    ;; allocate args
+                    (let ((v (if (pair? vars) (car vars) vars)))
+                      (hashq-set! allocation v
+                                  (make-hashq
+                                   x `(#t ,(hashq-ref assigned v) . ,n)))
+                      (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+                    ;; allocate body, return number of additional locals
+                    (- (allocate! body x n) n))))
+             (free-addresses
+              (map (lambda (v)
+                     (hashq-ref (hashq-ref allocation v) proc))
+                   (hashq-ref free-vars x))))
+         ;; set procedure allocations
+         (hashq-set! allocation x (cons nlocs free-addresses)))
+       n)
 
-    (define (allocate! x level n)
-      (define (recur y) (allocate! y level n))
-      (record-case x
-        ((<application> proc args)
-         (apply max (recur proc) (map recur args)))
-
-        ((<conditional> test then else)
-         (max (recur test) (recur then) (recur else)))
-
-        ((<lexical-set> name gensym exp)
-         (recur exp))
-        
-        ((<module-set> mod name public? exp)
-         (recur exp))
-        
-        ((<toplevel-set> name exp)
-         (recur exp))
-        
-        ((<toplevel-define> name exp)
-         (recur exp))
-        
-        ((<sequence> exps)
-         (apply max (map recur exps)))
-        
-        ((<lambda> vars meta body)
-         (let lp ((vars vars) (n 0))
-           (if (null? vars)
-               (hashq-set! allocation x
-                           (let ((nlocs (- (allocate! body (1+ level) n) n)))
-                             (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
-               (let ((v (if (pair? vars) (car vars) vars)))
-                 (let ((binder (hashq-ref heaps v)))
-                   (hashq-set!
-                    allocation v
-                    (if binder
-                        (cons* 'heap (1+ level) (allocate-heap! binder))
-                        (cons 'stack n))))
-                 (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
-         n)
-
-        ((<let> vars vals body)
-         (let ((nmax (apply max (map recur vals))))
-           (cond
-            ;; the `or' hack
-            ((and (conditional? body)
-                  (= (length vars) 1)
-                  (let ((v (car vars)))
-                    (and (not (hashq-ref heaps v))
-                         (= (hashq-ref refcounts v 0) 2)
-                         (lexical-ref? (conditional-test body))
-                         (eq? (lexical-ref-gensym (conditional-test body)) v)
-                         (lexical-ref? (conditional-then body))
-                         (eq? (lexical-ref-gensym (conditional-then body)) v))))
-             (hashq-set! allocation (car vars) (cons 'stack n))
-             ;; the 1+ for this var
-             (max nmax (1+ n) (allocate! (conditional-else body) level n)))
-            (else
-             (let lp ((vars vars) (n n))
-               (if (null? vars)
-                   (max nmax (allocate! body level n))
-                   (let ((v (car vars)))
-                     (let ((binder (hashq-ref heaps v)))
-                       (hashq-set!
-                        allocation v
-                        (if binder
-                            (cons* 'heap level (allocate-heap! binder))
-                            (cons 'stack n)))
-                       (lp (cdr vars) (if binder n (1+ n)))))))))))
-        
-        ((<letrec> vars vals body)
-         (let lp ((vars vars) (n n))
-           (if (null? vars)
-               (let ((nmax (apply max
-                                  (map (lambda (x)
-                                         (allocate! x level n))
-                                       vals))))
-                 (max nmax (allocate! body level n)))
-               (let ((v (car vars)))
-                 (let ((binder (hashq-ref heaps v)))
-                   (hashq-set!
-                    allocation v
-                    (if binder
-                        (cons* 'heap level (allocate-heap! binder))
-                        (cons 'stack n)))
-                   (lp (cdr vars) (if binder n (1+ n))))))))
-
-        ((<let-values> vars exp body)
-         (let ((nmax (recur exp)))
+      ((<let> vars vals body)
+       (let ((nmax (apply max (map recur vals))))
+         (cond
+          ;; the `or' hack
+          ((and (conditional? body)
+                (= (length vars) 1)
+                (let ((v (car vars)))
+                  (and (not (hashq-ref assigned v))
+                       (= (hashq-ref refcounts v 0) 2)
+                       (lexical-ref? (conditional-test body))
+                       (eq? (lexical-ref-gensym (conditional-test body)) v)
+                       (lexical-ref? (conditional-then body))
+                       (eq? (lexical-ref-gensym (conditional-then body)) v))))
+           (hashq-set! allocation (car vars)
+                       (make-hashq proc `(#t #f . ,n)))
+           ;; the 1+ for this var
+           (max nmax (1+ n) (allocate! (conditional-else body) proc n)))
+          (else
            (let lp ((vars vars) (n n))
              (if (null? vars)
-                 (max nmax (allocate! body level n))
-                 (let ((v (if (pair? vars) (car vars) vars)))
-                   (let ((binder (hashq-ref heaps v)))
-                     (hashq-set!
-                      allocation v
-                      (if binder
-                          (cons* 'heap level (allocate-heap! binder))
-                          (cons 'stack n)))
-                     (lp (if (pair? vars) (cdr vars) '())
-                         (if binder n (1+ n)))))))))
-        
-        (else n)))
+                 (max nmax (allocate! body proc n))
+                 (let ((v (car vars)))
+                   (hashq-set!
+                    allocation v
+                    (make-hashq proc
+                                `(#t ,(hashq-ref assigned v) . ,n)))
+                   (lp (cdr vars) (1+ n)))))))))
+      
+      ((<letrec> 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)))
+               (hashq-set!
+                allocation v
+                (make-hashq proc
+                            `(#t ,(hashq-ref assigned v) . ,n)))
+               (lp (cdr vars) (1+ n))))))
 
-  (define parents (make-hash-table))
-  (define bindings (make-hash-table))
-  (define heaps (make-hash-table))
+      ((<let-values> vars exp body)
+       (let ((nmax (recur exp)))
+         (let lp ((vars vars) (n n))
+           (if (null? vars)
+               (max nmax (allocate! body proc n))
+               (let ((v (if (pair? vars) (car vars) vars)))
+                 (let ((v (car vars)))
+                   (hashq-set!
+                    allocation v
+                    (make-hashq proc
+                                `(#t ,(hashq-ref assigned v) . ,n)))
+                   (lp (cdr vars) (1+ n))))))))
+      
+      (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))
-  (define heap-indexes (make-hash-table))
-
-  (analyze! x #f -1)
-  (allocate! x -1 0)
+  
+  (analyze! x #f)
+  (allocate! x #f 0)
 
   allocation)

module/language/tree-il/compile-glil.scm

@@ -20,6 +20,7 @@
 
 (define-module (language tree-il compile-glil)
   #:use-module (system base syntax)
+  #:use-module (system base pmatch)
   #:use-module (ice-9 receive)
   #:use-module (language glil)
   #:use-module (system vm instruction)
@@ -34,8 +35,12 @@
 ;; basic degenerate-case reduction
 
 ;; allocation:
-;;  sym -> (local . index) | (heap level . index)
-;;  lambda -> (nlocs . nexts)
+;;  sym -> {lambda -> address}
+;;  lambda -> (nlocs . closure-vars)
+;;
+;; address := (local? boxed? . index)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
 
 (define *comp-module* (make-fluid))
 
@@ -45,7 +50,7 @@
          (allocation (analyze-lexicals x)))
     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
       (lambda ()
-        (values (flatten-lambda x -1 allocation)
+        (values (flatten-lambda x allocation)
                 (and e (cons (car e) (cddr e)))
                 e)))))
 
@@ -131,20 +136,19 @@
 
 (define (make-label) (gensym ":L"))
 
-(define (vars->bind-list ids vars allocation)
+(define (vars->bind-list ids vars allocation proc)
   (map (lambda (id v)
-         (let ((loc (hashq-ref allocation v)))
-           (case (car loc)
-             ((stack) (list id 'local (cdr loc)))
-             ((heap)  (list id 'external (cddr loc)))
-             (else (error "badness" id v loc)))))
+         (pmatch (hashq-ref (hashq-ref allocation v) proc)
+           ((#t ,boxed? . ,n)
+            (list id boxed? n))
+           (,x (error "badness" x))))
        ids
        vars))
 
-(define (emit-bindings src ids vars allocation emit-code)
+(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)))))
+                      (vars->bind-list ids vars allocation proc)))))
 
 (define (with-output-to-code proc)
   (let ((out '()))
@@ -155,7 +159,7 @@
     (proc emit-code)
     (reverse out)))
 
-(define (flatten-lambda x level allocation)
+(define (flatten-lambda x allocation)
   (receive (ids vars nargs nrest)
       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
                (oids '()) (ovars '()) (n 0))
@@ -166,31 +170,27 @@
                 (else (values (reverse (cons ids oids))
                               (reverse (cons vars ovars))
                               (1+ n) 1))))
-    (let ((nlocs (car (hashq-ref allocation x)))
-          (nexts (cdr (hashq-ref allocation x))))
+    (let ((nlocs (car (hashq-ref allocation x))))
       (make-glil-program
-       nargs nrest nlocs nexts (lambda-meta x)
+       nargs nrest nlocs 0 (lambda-meta x)
        (with-output-to-code
         (lambda (emit-code)
           ;; write bindings and source debugging info
-          (emit-bindings #f ids vars allocation emit-code)
+          (emit-bindings #f ids vars allocation x emit-code)
           (if (lambda-src x)
               (emit-code #f (make-glil-source (lambda-src x))))
-
-          ;; copy args to the heap if necessary
-          (let lp ((in vars) (n 0))
-            (if (not (null? in))
-                (let ((loc (hashq-ref allocation (car in))))
-                  (case (car loc)
-                    ((heap)
-                     (emit-code #f (make-glil-local 'ref n))
-                     (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
-                  (lp (cdr in) (1+ n)))))
-
+          ;; box args if necessary
+          (for-each
+           (lambda (v)
+             (pmatch (hashq-ref (hashq-ref allocation v) x)
+               ((#t #t . ,n)
+                (emit-code #f (make-glil-lexical #t #f 'ref n))
+                (emit-code #f (make-glil-lexical #t #t 'box n)))))
+           vars)
           ;; and here, here, dear reader: we compile.
-          (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
+          (flatten (lambda-body x) allocation x emit-code)))))))
 
-(define (flatten x level allocation emit-code)
+(define (flatten x allocation proc emit-code)
   (define (emit-label label)
     (emit-code #f (make-glil-label label)))
   (define (emit-branch src inst label)
@@ -424,27 +424,21 @@
       ((<lexical-ref> src name gensym)
        (case context
          ((push vals tail)
-          (let ((loc (hashq-ref allocation gensym)))
-            (case (car loc)
-              ((stack)
-               (emit-code src (make-glil-local 'ref (cdr loc))))
-              ((heap)
-               (emit-code src (make-glil-external
-                               'ref (- level (cadr loc)) (cddr loc))))
-              (else (error "badness" x loc)))
-            (if (eq? context 'tail)
-                (emit-code #f (make-glil-call 'return 1)))))))
-
+          (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+            ((,local? ,boxed? . ,index)
+             (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)))))
+      
       ((<lexical-set> src name gensym exp)
        (comp-push exp)
-       (let ((loc (hashq-ref allocation gensym)))
-         (case (car loc)
-           ((stack)
-            (emit-code src (make-glil-local 'set (cdr loc))))
-           ((heap)
-            (emit-code src (make-glil-external
-                            'set (- level (cadr loc)) (cddr loc))))
-           (else (error "badness" x loc))))
+       (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+         ((,local? ,boxed? . ,index)
+          (emit-code src (make-glil-lexical local? boxed? 'set index)))
+         (,loc
+          (error "badness" x loc)))
        (case context
          ((push vals)
           (emit-code #f (make-glil-void)))
@@ -495,39 +489,52 @@
           (emit-code #f (make-glil-call 'return 1)))))
 
       ((<lambda>)
-       (case context
-         ((push vals)
-          (emit-code #f (flatten-lambda x level allocation)))
-         ((tail)
-          (emit-code #f (flatten-lambda x level allocation))
-          (emit-code #f (make-glil-call 'return 1)))))
-
+       (let ((free-locs (cdr (hashq-ref allocation x))))
+         (case context
+           ((push vals tail)
+            (emit-code #f (flatten-lambda x 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)))
+                  (emit-code #f (make-glil-call 'make-closure2 2))))
+            (if (eq? context 'tail)
+                (emit-code #f (make-glil-call 'return 1)))))))
+      
       ((<let> src names vars vals body)
        (for-each comp-push vals)
-       (emit-bindings src names vars allocation emit-code)
+       (emit-bindings src names vars allocation proc emit-code)
        (for-each (lambda (v)
-                   (let ((loc (hashq-ref allocation v)))
-                     (case (car loc)
-                       ((stack)
-                        (emit-code src (make-glil-local 'set (cdr loc))))
-                       ((heap)
-                        (emit-code src (make-glil-external 'set 0 (cddr loc))))
-                       (else (error "badness" x loc)))))
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                     ((#t #f . ,n)
+                      (emit-code src (make-glil-lexical #t #f 'set n)))
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'box n)))
+                     (,loc (error "badness" x loc))))
                  (reverse vars))
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
 
       ((<letrec> src names vars vals body)
-       (for-each comp-push vals)
-       (emit-bindings src names vars allocation emit-code)
        (for-each (lambda (v)
-                   (let ((loc (hashq-ref allocation v)))
-                     (case (car loc)
-                       ((stack)
-                        (emit-code src (make-glil-local 'set (cdr loc))))
-                       ((heap)
-                        (emit-code src (make-glil-external 'set 0 (cddr loc))))
-                       (else (error "badness" x loc)))))
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'empty-box n)))
+                     (,loc (error "badness" x loc))))
+                 vars)
+       (for-each comp-push vals)
+       (emit-bindings src names vars allocation proc emit-code)
+       (for-each (lambda (v)
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'set n)))
+                     (,loc (error "badness" x loc))))
                  (reverse vars))
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
@@ -548,16 +555,15 @@
              (emit-code #f (make-glil-const 1))
              (emit-label MV)
              (emit-code src (make-glil-mv-bind
-                             (vars->bind-list names vars allocation)
+                             (vars->bind-list names vars allocation proc)
                              rest?))
              (for-each (lambda (v)
-                         (let ((loc (hashq-ref allocation v)))
-                           (case (car loc)
-                             ((stack)
-                              (emit-code src (make-glil-local 'set (cdr loc))))
-                             ((heap)
-                              (emit-code src (make-glil-external 'set 0 (cddr loc))))
-                             (else (error "badness" x loc)))))
+                         (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                           ((#t #f . ,n)
+                            (emit-code src (make-glil-lexical #t #f 'set n)))
+                           ((#t #t . ,n)
+                            (emit-code src (make-glil-lexical #t #t 'box n)))
+                           (,loc (error "badness" x loc))))
                        (reverse vars))
              (comp-tail body)
              (emit-code #f (make-glil-unbind))))))))))

test-suite/tests/tree-il.test

@@ -129,45 +129,45 @@
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (lexical x y))
    (program 0 0 1 0 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (call return 1)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (lexical #t #f ref 0) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
    (program 0 0 1 0 ()
-            (const 1) (bind (x local 0)) (local set 0)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (const #f) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
    (program 0 0 1 0 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (call null? 1) (call return 1)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (lexical #t #f ref 0) (call null? 1) (call return 1)
             (unbind))))
 
 (with-test-prefix "lexical sets"
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
-   (program 0 0 0 1 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
-            (const 2) (external set 0 0) (void) (call return 1)
+   (program 0 0 1 0 ()
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+            (const 2) (lexical #t #t set 0) (void) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
-   (program 0 0 0 1 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
-            (const 2) (external set 0 0) (const #f) (call return 1)
+   (program 0 0 1 0 ()
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+            (const 2) (lexical #t #t set 0) (const #f) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
      (apply (primitive null?) (set! (lexical x y) (const 2))))
-   (program 0 0 0 1 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
-            (const 2) (external set 0 0) (void) (call null? 1) (call return 1)
+   (program 0 0 1 0 ()
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+            (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
             (unbind))))
 
 (with-test-prefix "module refs"
@@ -322,7 +322,7 @@
    (lambda (x) (y) () (const 2))
    (program 0 0 0 0 ()
             (program 1 0 0 0 ()
-                     (bind (x local 0))
+                     (bind (x #f 0))
                      (const 2) (call return 1))
             (call return 1)))
 
@@ -330,7 +330,7 @@
    (lambda (x x1) (y y1) () (const 2))
    (program 0 0 0 0 ()
             (program 2 0 0 0 ()
-                     (bind (x local 0) (x1 local 1))
+                     (bind (x #f 0) (x1 #f 1))
                      (const 2) (call return 1))
             (call return 1)))
 
@@ -338,7 +338,7 @@
    (lambda x y () (const 2))
    (program 0 0 0 0 ()
             (program 1 1 0 0 ()
-                     (bind (x local 0))
+                     (bind (x #f 0))
                      (const 2) (call return 1))
             (call return 1)))
 
@@ -346,7 +346,7 @@
    (lambda (x . x1) (y . y1) () (const 2))
    (program 0 0 0 0 ()
             (program 2 1 0 0 ()
-                     (bind (x local 0) (x1 local 1))
+                     (bind (x #f 0) (x1 #f 1))
                      (const 2) (call return 1))
             (call return 1)))
 
@@ -354,27 +354,29 @@
    (lambda (x . x1) (y . y1) () (lexical x y))
    (program 0 0 0 0 ()
             (program 2 1 0 0 ()
-                     (bind (x local 0) (x1 local 1))
-                     (local ref 0) (call return 1))
+                     (bind (x #f 0) (x1 #f 1))
+                     (lexical #t #f ref 0) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda (x . x1) (y . y1) () (lexical x1 y1))
    (program 0 0 0 0 ()
             (program 2 1 0 0 ()
-                     (bind (x local 0) (x1 local 1))
-                     (local ref 1) (call return 1))
+                     (bind (x #f 0) (x1 #f 1))
+                     (lexical #t #f ref 1) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
    (program 0 0 0 0 ()
-            (program 1 0 0 1 ()
-                     (bind (x external 0))
-                     (local ref 0) (external set 0 0)
+            (program 1 0 0 0 ()
+                     (bind (x #f 0))
                      (program 1 0 0 0 ()
-                              (bind (y local 0))
-                              (external ref 1 0) (call return 1))
+                              (bind (y #f 0))
+                              (lexical #f #f ref 0) (call return 1))
+                     (lexical #t #f ref 0)
+                     (call vector 1)
+                     (call make-closure2 2)
                      (call return 1))
             (call return 1))))
 
@@ -399,12 +401,12 @@
             (let (a) (b) ((const 2))
                  (lexical a b))))
    (program 0 0 1 0 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (branch br-if-not ,l1)
-            (local ref 0) (call return 1)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (lexical #t #f ref 0) (branch br-if-not ,l1)
+            (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a local 0)) (local set 0)
-            (local ref 0) (call return 1)
+            (const 2) (bind (a #f 0)) (lexical #t #f set 0)
+            (lexical #t #f ref 0) (call return 1)
             (unbind)
             (unbind))
    (eq? l1 l2))
@@ -416,12 +418,12 @@
             (let (a) (b) ((const 2))
                  (lexical x y))))
    (program 0 0 2 0 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (branch br-if-not ,l1)
-            (local ref 0) (call return 1)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (lexical #t #f ref 0) (branch br-if-not ,l1)
+            (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a local 1)) (local set 1)
-            (local ref 0) (call return 1)
+            (const 2) (bind (a #f 1)) (lexical #t #f set 1)
+            (lexical #t #f ref 0) (call return 1)
             (unbind)
             (unbind))
    (eq? l1 l2)))