tree-il -> glil compiler works now, at least in initial tests

* module/language/tree-il/analyze.scm: Break analyzer out into its own
  file.

* module/language/tree-il/compile-glil.scm: Port the GHIL->GLIL compiler
  over to work on tree-il. Works, but still misses a number of important
  optimizations.

* module/language/tree-il.scm: Add <void>. Not used quite yet.

* module/language/glil.scm: Remove <glil-argument>, as it is the same as
  <glil-local> (minus an offset).

* module/language/glil/compile-assembly.scm:
* module/language/glil/decompile-assembly.scm:
* module/language/ghil/compile-glil.scm: Adapt for <glil-argument>
* removal.

* module/Makefile.am (TREE_IL_LANG_SOURCES): Reorder, and add
  analyze.scm.

module/language/ghil/compile-glil.scm

@@ -187,7 +187,7 @@
 (define (make-glil-var op env var)
   (case (ghil-var-kind var)
     ((argument)
-     (make-glil-argument op (ghil-var-index var)))
+     (make-glil-local op (ghil-var-index var)))
     ((local)
      (make-glil-local op (ghil-var-index var)))
     ((external)
@@ -217,7 +217,9 @@
       (set! stack (cons code stack))
       (if loc (set! stack (cons (make-glil-source loc) stack))))
     (define (var->binding var)
-      (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
+      (list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
+                                  (case kind ((argument) 'local) (else kind)))
+            (ghil-var-index var)))
     (define (push-bindings! loc vars)
       (if (not (null? vars))
           (push-code! loc (make-glil-bind (map var->binding vars)))))
@@ -496,7 +498,7 @@
 	      (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
 	      (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
               (nargs (allocate-indices-linearly! vars))
-              (nlocs (allocate-locals! locs body))
+              (nlocs (allocate-locals! locs body nargs))
               (nexts (allocate-indices-linearly! exts)))
 	 ;; meta bindings
          (push-bindings! #f vars)
@@ -509,7 +511,7 @@
 	   (let ((v (car l)))
 	     (case (ghil-var-kind v)
                ((external)
-                (push-code! #f (make-glil-argument 'ref n))
+                (push-code! #f (make-glil-local 'ref n))
                 (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
 	 ;; compile body
 	 (comp body #t #f)
@@ -523,8 +525,8 @@
       ((null? l) n)
     (let ((v (car l))) (set! (ghil-var-index v) n))))
 
-(define (allocate-locals! vars body)
-  (let ((free '()) (nlocs 0))
+(define (allocate-locals! vars body nargs)
+  (let ((free '()) (nlocs nargs))
     (define (allocate! var)
       (cond
        ((pair? free)

module/language/glil.scm

@@ -44,9 +44,6 @@
    <glil-const> make-glil-const glil-const?
    glil-const-obj
 
-   <glil-argument> make-glil-argument glil-argument?
-   glil-argument-op glil-argument-index
-
    <glil-local> make-glil-local glil-local?
    glil-local-op glil-local-index
 
@@ -87,7 +84,6 @@
   (<glil-void>)
   (<glil-const> obj)
   ;; Variables
-  (<glil-argument> op index)
   (<glil-local> op index)
   (<glil-external> op depth index)
   (<glil-toplevel> op name)
@@ -125,7 +121,6 @@
     ((source ,props) (make-glil-source props))
     ((void) (make-glil-void))
     ((const ,obj) (make-glil-const obj))
-    ((argument ,op ,index) (make-glil-argument op index))
     ((local ,op ,index) (make-glil-local op index))
     ((external ,op ,depth ,index) (make-glil-external op depth index))
     ((toplevel ,op ,name) (make-glil-toplevel op name))
@@ -150,8 +145,6 @@
     ((<glil-void>) `(void))
     ((<glil-const> obj) `(const ,obj))
     ;; variables
-    ((<glil-argument> op index)
-     `(argument ,op ,index))
     ((<glil-local> op index)
      `(local ,op ,index))
     ((<glil-external> op depth index)

module/language/glil/compile-assembly.scm

@@ -83,16 +83,15 @@
 (define (make-closed-binding open-binding start end)
   (make-binding (car open-binding) (cadr open-binding)
                 (caddr open-binding) start end))
-(define (open-binding bindings vars nargs start)
+(define (open-binding bindings vars start)
   (cons
    (acons start
           (map
            (lambda (v)
              (pmatch v
-               ((,name argument ,i) (make-open-binding name #f i))
-               ((,name local ,i) (make-open-binding name #f (+ nargs i)))
+               ((,name local ,i) (make-open-binding name #f i))
                ((,name external ,i) (make-open-binding name #t i))
-               (else (error "unknown binding type" name type))))
+               (else (error "unknown binding type" v))))
            vars)
           (car bindings))
    (cdr bindings)))
@@ -129,13 +128,13 @@
 
 (define (compile-assembly glil)
   (receive (code . _)
-      (glil->assembly glil 0 '() '(()) '() '() #f -1)
+      (glil->assembly glil '() '(()) '() '() #f -1)
     (car code)))
 (define (make-object-table objects)
   (and (not (null? objects))
        (list->vector (cons #f objects))))
 
-(define (glil->assembly glil nargs nexts-stack bindings
+(define (glil->assembly glil nexts-stack bindings
                         source-alist label-alist object-alist addr)
   (define (emit-code x)
     (values (map assembly-pack x) bindings source-alist label-alist object-alist))
@@ -159,7 +158,7 @@
                        addr))
               (else
                (receive (subcode bindings source-alist label-alist object-alist)
-                   (glil->assembly (car body) nargs nexts-stack bindings
+                   (glil->assembly (car body) nexts-stack bindings
                                    source-alist label-alist object-alist addr)
                  (lp (cdr body) (append (reverse subcode) code)
                      bindings source-alist label-alist object-alist
@@ -196,14 +195,14 @@
     
     ((<glil-bind> vars)
      (values '()
-             (open-binding bindings vars nargs addr)
+             (open-binding bindings vars addr)
              source-alist
              label-alist
              object-alist))
 
     ((<glil-mv-bind> vars rest)
      (values `((truncate-values ,(length vars) ,(if rest 1 0)))
-             (open-binding bindings vars nargs addr)
+             (open-binding bindings vars addr)
              source-alist
              label-alist
              object-alist))
@@ -238,16 +237,11 @@
          (emit-code/object `((object-ref ,i))
                            object-alist)))))
 
-    ((<glil-argument> op index)
+    ((<glil-local> op index)
      (emit-code (if (eq? op 'ref)
                     `((local-ref ,index))
                     `((local-set ,index)))))
 
-    ((<glil-local> op index)
-     (emit-code (if (eq? op 'ref)
-                    `((local-ref ,(+ nargs index)))
-                    `((local-set ,(+ nargs index))))))
-
     ((<glil-external> op depth index)
      (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
                   (if (> d 0)

module/language/glil/decompile-assembly.scm

@@ -175,15 +175,11 @@
                (1+ pos)))
           ((local-ref ,n)
            (lp (cdr in) (cons *placeholder* stack)
-               (cons (if (< n nargs)
-                         (make-glil-argument 'ref n)
-                         (make-glil-local 'ref (- n nargs)))
+               (cons (make-glil-local 'ref n)
                      out) (+ pos 2)))
           ((local-set ,n)
            (lp (cdr in) (cdr stack)
-               (cons (if (< n nargs)
-                         (make-glil-argument 'set n)
-                         (make-glil-local 'set (- n nargs)))
+               (cons (make-glil-local 'set n)
                      (emit-constants (list-head stack 1) out))
                (+ pos 2)))
           ((br-if-not ,l)

module/language/tree-il.scm

@@ -24,6 +24,7 @@
             <lexical> make-lexical
             lexical-name lexical-gensym
 
+            <void> void? make-void void-src
             <application> application? make-application application-src application-proc application-args
             <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
             <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
@@ -48,6 +49,7 @@
             pre-order!))
 
 (define-type (<tree-il> #:common-slots (src))
+  (<void>)
   (<application> proc args)
   (<conditional> test then else)
   (<primitive-ref> name)
@@ -85,6 +87,9 @@
   (let ((loc (location exp))
         (retrans (lambda (x) (parse-ghil env x))))
     (pmatch exp
+     ((void)
+      (make-void loc))
+
      ((apply ,proc ,args)
       (make-application loc (retrans proc) (retrans args)))
 
@@ -147,6 +152,9 @@
 
 (define (unparse-tree-il tree-il)
   (record-case tree-il
+    ((<void>)
+     '(void))
+
     ((<application> proc args)
      `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args)))
 
@@ -200,6 +208,9 @@
                (tree-il->scheme (cdr e))))
         ((record? e)
          (record-case e
+           ((<void>)
+            '(if #f #f))
+
            ((<application> proc args)
             `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
 
@@ -253,6 +264,9 @@
 (define (post-order! f x)
   (let lp ((x x))
     (record-case x
+      ((<void>)
+       (or (f x) x))
+
       ((<application> proc args)
        (set! (application-proc x) (lp proc))
        (set! (application-args x) (map lp args))

module/language/tree-il/analyze.scm

@@ -0,0 +1,201 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il analyze)
+  #: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
+;; (let (0 1)
+;;   (let (2 3) ...)
+;;   (let (2) ...))
+;;   (let (2 3 4) ...))
+;; etc.
+;;
+;; allocation:
+;;  sym -> (local . index) | (heap level . index)
+;;  lambda -> (nlocs . nexts)
+
+(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
+
+  (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)))
+    (record-case x
+      ((<application> proc args)
+       (step proc) (for-each step args))
+
+      ((<conditional> test then else)
+       (step test) (step then) (step else))
+
+      ((<lexical-ref> name gensym)
+       (if (and (not (memq gensym (hashq-ref bindings parent)))
+                (not (hashq-ref heaps gensym)))
+           (hashq-set! heaps gensym (find-heap gensym parent))))
+      
+      ((<lexical-set> name gensym exp)
+       (step exp)
+       (if (not (hashq-ref heaps gensym))
+           (hashq-set! heaps gensym (find-heap gensym parent))))
+      
+      ((<module-set> mod name public? exp)
+       (step exp))
+      
+      ((<toplevel-set> name exp)
+       (step exp))
+      
+      ((<toplevel-define> name exp)
+       (step exp))
+      
+      ((<sequence> exps)
+       (for-each 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> vars vals exp)
+       (for-each step vals)
+       (hashq-set! bindings parent
+                   (append (reverse vars) (hashq-ref bindings parent)))
+       (step exp))
+      
+      ((<letrec> vars vals exp)
+       (hashq-set! bindings parent
+                   (append (reverse vars) (hashq-ref bindings parent)))
+       (for-each step vals)
+       (step exp))
+
+      (else #f)))
+
+    (define (allocate-heap! binder)
+      (hashq-set! heap-indexes binder
+                  (1+ (hashq-ref heap-indexes binder -1))))
+
+    (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)))
+                             (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 exp)
+         (let ((nmax (apply max (map recur vals))))
+           (let lp ((vars vars) (n n))
+             (if (null? vars)
+                 (max nmax (allocate! exp 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) (1+ n)))))))
+        
+        ((<letrec> vars vals exp)
+         (let lp ((vars vars) (n n))
+           (if (null? vars)
+               (let ((nmax (apply max
+                                  (map (lambda (x)
+                                         (allocate! x level n))
+                                       vals))))
+                 (max nmax (allocate! exp 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) (1+ n))))))
+
+        (else n)))
+
+  (define parents (make-hash-table))
+  (define bindings (make-hash-table))
+  (define heaps (make-hash-table))
+  (define allocation (make-hash-table))
+  (define heap-indexes (make-hash-table))
+
+  (analyze! x #f -1)
+  (allocate! x -1 0)
+
+  allocation)

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

@@ -21,287 +21,123 @@
 
 (define-module (language tree-il compile-glil)
   #:use-module (system base syntax)
+  #:use-module (ice-9 receive)
   #:use-module (language glil)
   #:use-module (language tree-il)
   #:use-module (language tree-il optimize)
-  #:use-module (ice-9 common-list)
+  #:use-module (language tree-il analyze)
   #:export (compile-glil))
 
-;; 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
-
-;; 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
-;; (let (0 1)
-;;   (let (2 3) ...)
-;;   (let (2) ...))
-;;   (let (2 3 4) ...))
-;; etc.
-
 ;; allocation:
 ;;  sym -> (local . index) | (heap level . index)
-
-
-(define (analyze-lexicals x)
-  (define (find-diff parent this)
-    (let lp ((parent parent) (n 0))
-      (if (eq? parent this)
-          n
-          (lp (hashq-ref parents parent) (1+ n)))))
-
-  (define (find-heap sym parent)
-    ;; fixme: check displaced lexicals here?
-    (if (memq sym (hashq-ref bindings parent))
-        parent
-        (find-binder 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)))
-    (record-case x
-      ((<application> proc args)
-       (step proc) (for-each step args))
-
-      ((<conditional> test then else)
-       (step test) (step then) (step else))
-
-      ((<lexical-ref> name gensym)
-       (if (and (not (memq gensym (hashq-ref bindings parent)))
-                (not (hashq-ref heaps gensym)))
-           (hashq-set! heaps gensym (find-heap gensym parent level))))
-      
-      ((<lexical-set> name gensym exp)
-       (step exp)
-       (if (not (hashq-ref heaps gensym))
-           (hashq-set! heaps gensym (find-heap gensym parent level))))
-      
-      ((<module-set> mod name public? exp)
-       (step exp))
-      
-      ((<toplevel-set> name exp)
-       (step exp))
-      
-      ((<toplevel-define> name exp)
-       (step exp))
-      
-      ((<sequence> exps)
-       (for-each 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> vars vals exp)
-       (for-each step vals)
-       (hashq-set! bindings parent
-                   (append (reverse vars) (hashq-ref bindings parent)))
-       (step exp))
-      
-      ((<letrec> vars vals exp)
-       (hashq-set! bindings parent
-                   (append (reverse vars) (hashq-ref bindings parent)))
-       (for-each step vals)
-       (step exp))
-
-      (else #f)))
-
-    (define (allocate-heap! binder)
-      (hashq-set! heap-indexes binder
-                  (1+ (hashq-ref heap-indexes binder -1))))
-
-    (define (allocate! x level n)
-      (define (step y) (allocate! y level n))
-      (record-case x
-        ((<application> proc args)
-         (step proc) (for-each step args))
-
-        ((<conditional> test then else)
-         (step test) (step then) (step else))
-
-        ((<lexical-set> name gensym exp)
-         (step exp))
-        
-        ((<module-set> mod name public? exp)
-         (step exp))
-        
-        ((<toplevel-set> name exp)
-         (step exp))
-        
-        ((<toplevel-define> name exp)
-         (step exp))
-        
-        ((<sequence> exps)
-         (for-each step exps))
-        
-        ((<lambda> vars meta body)
-         (let lp ((vars vars) (n 0))
-           (if (null? vars)
-               (allocate! body (1+ level) n)
-               (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))))))
-
-        ((<let> vars vals exp)
-         (for-each step vals)
-         (let lp ((vars vars) (n n))
-           (if (null? vars)
-               (allocate! exp 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) (1+ n))))))
-        
-        ((<letrec> vars vals exp)
-         (let lp ((vars vars) (n n))
-           (if (null? vars)
-               (begin
-                 (for-each (lambda (x) (allocate! x level n))
-                           vals)
-                 (allocate! exp 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) (1+ n))))))
-
-        (else #f)))
-
-  (define parents (make-hash-table))
-  (define bindings (make-hash-table))
-  (define heaps (make-hash-table))
-  (define allocation (make-hash-table))
-  (define heap-indexes (make-hash-table))
-
-  (hashq-set! bindings #f '())
-  (analyze! x #f 0)
-  (allocate! x 0 0)
-
-  allocation)
+;;  lambda -> (nlocs . nexts)
 
 (define (compile-glil x e opts)
-  (let ((x (optimize! x e opts)))
-    (let ((allocation (analyze-lexicals x)))
-      (values (codegen (make-lambda (tree-il-src x) '() '() x)
-                       allocation)
-              (and e (cons (car e) (cddr e)))
-              e))))
+  (let* ((x (make-lambda (tree-il-src x) '() '() x))
+         (x (optimize! x e opts))
+         (allocation (analyze-lexicals x)))
+    (values (flatten-lambda x -1 allocation)
+            (and e (cons (car e) (cddr e)))
+            e)))
 
 
 
-(define *ia-void* (make-glil-void))
-(define *ia-drop* (make-glil-call 'drop 1))
-(define *ia-return* (make-glil-call 'return 1))
-
 (define (make-label) (gensym ":L"))
 
-(define (make-glil-var op env var)
-  (case (ghil-var-kind var)
-    ((argument)
-     (make-glil-argument op (ghil-var-index var)))
-    ((local)
-     (make-glil-local op (ghil-var-index var)))
-    ((external)
-     (do ((depth 0 (1+ depth))
-	  (e env (ghil-env-parent e)))
-	 ((eq? e (ghil-var-env var))
-	  (make-glil-external op depth (ghil-var-index var)))))
-    ((toplevel)
-     (make-glil-toplevel op (ghil-var-name var)))
-    ((public private)
-     (make-glil-module op (ghil-var-env var) (ghil-var-name var)
-                       (eq? (ghil-var-kind var) 'public)))
-    (else (error "Unknown kind of variable:" var))))
+(define (vars->bind-list vars allocation)
+  (map (lambda (v)
+         (let ((loc (hashq-ref allocation v)))
+           (case (car loc)
+             ((stack) (list v 'local (cdr loc)))
+             ((heap)  (list v 'external (cddr loc)))
+             (else (error "badness" v loc)))))
+       vars))
 
+(define (emit-bindings src vars allocation emit-code)
+  (if (pair? vars)
+      (emit-code src (make-glil-bind (vars->bind-list vars allocation)))))
 
-(define (codegen x)
-  (define stack '())
-  (define (push-code! src code)
-    (set! stack (cons code stack))
-    (if src (set! stack (cons (make-glil-source src) stack))))
-  (define (var->binding var)
-    (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
-  (define (push-bindings! src vars)
-    (if (not (null? vars))
-        (push-code! src (make-glil-bind (map var->binding vars)))))
-  (define (comp tree tail drop)
-    (define (push-label! label)
-      (push-code! #f (make-glil-label label)))
-    (define (push-branch! src inst label)
-      (push-code! src (make-glil-branch inst label)))
-    (define (push-call! src inst args)
-      (for-each comp-push args)
-      (push-code! src (make-glil-call inst (length args))))
-    ;; possible tail position
-    (define (comp-tail tree) (comp tree tail drop))
-    ;; push the result
-    (define (comp-push tree) (comp tree #f #f))
-    ;; drop the result
-    (define (comp-drop tree) (comp tree #f #t))
-    ;; drop the result if unnecessary
-    (define (maybe-drop)
-      (if drop (push-code! #f *ia-drop*)))
-    ;; return here if necessary
-    (define (maybe-return)
-      (if tail (push-code! #f *ia-return*)))
-    ;; return this code if necessary
-    (define (return-code! src code)
-      (if (not drop) (push-code! src code))
-      (maybe-return))
-    ;; return void if necessary
-    (define (return-void!)
-      (return-code! #f *ia-void*))
-    ;; return object if necessary
-    (define (return-object! src obj)
-      (return-code! src (make-glil-const obj)))
-    ;;
-    ;; dispatch
-    (record-case tree
-      ((<ghil-void>)
-       (return-void!))
+(define (with-output-to-code proc)
+  (let ((out '()))
+    (define (emit-code src x)
+      (set! out (cons x out))
+      (if src
+          (set! out (cons (make-glil-source src) out))))
+    (proc emit-code)
+    (reverse out)))
 
-      ((<ghil-quote> env src obj)
-       (return-object! src obj))
+(define (flatten-lambda x level allocation)
+  (receive (vars nargs nrest)
+      (let lp ((vars (lambda-vars x)) (out '()) (n 0))
+          (cond ((null? vars) (values (reverse out) n 0))
+                ((pair? vars) (lp (cdr vars) (cons (car vars) out) (1+ n)))
+                (else (values (reverse (cons vars out)) (1+ n) 1))))
+    (let ((nlocs (car (hashq-ref allocation x)))
+          (nexts (cdr (hashq-ref allocation x))))
+      (make-glil-program
+       nargs nrest nlocs nexts (lambda-meta x)
+       (with-output-to-code
+        (lambda (emit-code)
+          ;; write bindings and source debugging info
+          (emit-bindings #f vars allocation emit-code)
+          (if (lambda-src x)
+              (emit-code (make-glil-src (lambda-src x))))
 
-      ((<ghil-ref> env src var)
-       (return-code! src (make-glil-var 'ref env var)))
+          ;; copy args to the heap if necessary
+          (let lp ((in vars) (n 0))
+            (if (not (null? in))
+                (let ((loc (hashq-ref allocation (car vars))))
+                  (case (car loc)
+                    ((heap)
+                     (emit-code (make-glil-argument 'ref n))
+                     (emit-code (make-glil-external 'set 0 (cddr loc)))))
+                  (lp (cdr in) (1+ n)))))
 
-      ((<ghil-set> env src var val)
-       (comp-push val)
-       (push-code! src (make-glil-var 'set env var))
-       (return-void!))
+          ;; and here, here, dear reader: we compile.
+          (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
 
-      ((<toplevel-define> src name exp)
-       (comp-push exp)
-       (push-code! src (make-glil-var 'define env var))
-       (return-void!))
+(define (flatten x level allocation 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)))
+
+  (let comp ((x x) (context 'tail))
+    (define (comp-tail tree) (comp tree context))
+    (define (comp-push tree) (comp tree 'push))
+    (define (comp-drop tree) (comp tree 'drop))
+
+    (record-case x
+      ((<void>)
+       (case context
+         ((push) (emit-code #f (make-glil-void)))
+         ((tail)
+          (emit-code #f (make-glil-void))
+          (emit-code #f (make-glil-call 'return 1)))))
+
+      ((<const> src exp)
+       (case context
+         ((push) (emit-code src (make-glil-const exp)))
+         ((tail)
+          (emit-code src (make-glil-const exp))
+          (emit-code #f (make-glil-call 'return 1)))))
+
+      ;; FIXME: should represent sequence as exps tail
+      ((<sequence> src exps)
+       (let lp ((exps exps))
+         (if (null? (cdr exps))
+             (comp-tail (car exps))
+             (begin
+               (comp-drop (car exps))
+               (lp (cdr exps))))))
+
+      ((<application> src proc args)
+       (comp-push proc)
+       (for-each comp-push args)
+       (emit-code src (make-glil-call (case context
+                                        ((tail) 'goto/args)
+                                        (else 'call))
+                                      (length args))))
 
       ((<conditional> src test then else)
        ;;     TEST
@@ -312,228 +148,130 @@
        ;; L2:
        (let ((L1 (make-label)) (L2 (make-label)))
          (comp-push test)
-         (push-branch! src 'br-if-not L1)
+         (emit-branch src 'br-if-not L1)
          (comp-tail then)
-         (if (not tail) (push-branch! #f 'br L2))
-         (push-label! L1)
+         (if (not (eq? context 'tail))
+             (emit-branch #f 'br L2))
+         (emit-label L1)
          (comp-tail else)
-         (if (not tail) (push-label! L2))))
+         (if (not (eq? context 'tail))
+             (emit-label L2))))
 
-      ((<sequence> src exps)
-       ;; EXPS...
-       ;; TAIL
-       (if (null? exps)
-           (return-void!)
-           (do ((exps exps (cdr exps)))
-      	 ((null? (cdr exps))
-      	  (comp-tail (car exps)))
-             (comp-drop (car exps)))))
+      ((<primitive-ref> src name)
+       (case context
+         ((push)
+          (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)))))
 
-      ((<let> src vars vals body)
-       ;; VALS...
-       ;; (set VARS)...
-       ;; BODY
+      ((<lexical-ref> src name gensym)
+       (case context
+         ((push 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)))))))
+
+      ((<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))))
+       (case context
+         ((push)
+          (emit-code #f (make-glil-void)))
+         ((tail) 
+          (emit-code #f (make-glil-void))
+          (emit-code #f (make-glil-call 'return 1)))))
+      
+      ((<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)))))
+      
+      ((<module-set> src mod name public? exp)
+       (comp-push exp)
+       (emit-code src (make-glil-module 'set mod name public?))
+       (case context
+         ((push)
+          (emit-code #f (make-glil-void)))
+         ((tail) 
+          (emit-code #f (make-glil-void))
+          (emit-code #f (make-glil-call 'return 1)))))
+
+      ((<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)))))
+      
+      ((<toplevel-set> src name exp)
+       (comp-push exp)
+       (emit-code src (make-glil-toplevel 'set name))
+       (case context
+         ((push)
+          (emit-code #f (make-glil-void)))
+         ((tail) 
+          (emit-code #f (make-glil-void))
+          (emit-code #f (make-glil-call 'return 1)))))
+      
+      ((<toplevel-define> src name exp)
+       (comp-push exp)
+       (emit-code src (make-glil-toplevel 'define name))
+       (case context
+         ((push)
+          (emit-code #f (make-glil-void)))
+         ((tail) 
+          (emit-code #f (make-glil-void))
+          (emit-code #f (make-glil-call 'return 1)))))
+
+      ((<lambda>)
+       (case context
+         ((push)
+          (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> src vars vals exp)
        (for-each comp-push vals)
-       (push-bindings! src vars)
-       (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
-      	   (reverse vars))
-       (comp-tail body)
-       (push-code! #f (make-glil-unbind)))
+       (emit-bindings src 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)))))
+                 (reverse vars))
+       (comp-tail exp)
+       (emit-code #f (make-glil-unbind)))
 
-      ((<ghil-mv-bind> env src producer vars rest body)
-       ;; VALS...
-       ;; (set VARS)...
-       ;; BODY
-       (let ((MV (make-label)))
-         (comp-push producer)
-         (push-code! src (make-glil-mv-call 0 MV))
-         (push-code! #f (make-glil-const 1))
-         (push-label! MV)
-         (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
-         (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
-                   (reverse vars)))
-       (comp-tail body)
-       (push-code! #f (make-glil-unbind)))
-
-      ((<ghil-lambda> env src vars rest meta body)
-       (return-code! src (codegen tree)))
-
-      ((<ghil-inline> env src inline args)
-       ;; ARGS...
-       ;; (INST NARGS)
-       (let ((tail-table '((call . goto/args)
-                           (apply . goto/apply)
-                           (call/cc . goto/cc))))
-         (cond ((and tail (assq-ref tail-table inline))
-                => (lambda (tail-inst)
-                     (push-call! src tail-inst args)))
-               (else
-                (push-call! src inline args)
-                (maybe-drop)
-                (maybe-return)))))
-
-      ((<ghil-values> env src values)
-       (cond (tail ;; (lambda () (values 1 2))
-              (push-call! src 'return/values values))
-             (drop ;; (lambda () (values 1 2) 3)
-              (for-each comp-drop values))
-             (else ;; (lambda () (list (values 10 12) 1))
-              (push-code! #f (make-glil-const 'values))
-              (push-code! #f (make-glil-call 'link-now 1))
-              (push-code! #f (make-glil-call 'variable-ref 0))
-              (push-call! src 'call values))))
-              
-      ((<ghil-values*> env src values)
-       (cond (tail ;; (lambda () (apply values '(1 2)))
-              (push-call! src 'return/values* values))
-             (drop ;; (lambda () (apply values '(1 2)) 3)
-              (for-each comp-drop values))
-             (else ;; (lambda () (list (apply values '(10 12)) 1))
-              (push-code! #f (make-glil-const 'values))
-              (push-code! #f (make-glil-call 'link-now 1))
-              (push-code! #f (make-glil-call 'variable-ref 0))
-              (push-call! src 'apply values))))
-              
-      ((<ghil-call> env src proc args)
-       ;; PROC
-       ;; ARGS...
-       ;; ([tail-]call NARGS)
-       (comp-push proc)
-       (let ((nargs (length args)))
-         (cond ((< nargs 255)
-                (push-call! src (if tail 'goto/args 'call) args))
-               (else
-                (push-call! src 'mark '())
-                (for-each comp-push args)
-                (push-call! src 'list-mark '())
-                (push-code! src (make-glil-call (if tail 'goto/apply 'apply) 2)))))
-       (maybe-drop))
-
-      ((<ghil-mv-call> env src producer consumer)
-       ;; CONSUMER
-       ;; PRODUCER
-       ;; (mv-call MV)
-       ;; ([tail]-call 1)
-       ;; goto POST
-       ;; MV: [tail-]call/nargs
-       ;; POST: (maybe-drop)
-       (let ((MV (make-label)) (POST (make-label)))
-         (comp-push consumer)
-         (comp-push producer)
-         (push-code! src (make-glil-mv-call 0 MV))
-         (push-code! src (make-glil-call (if tail 'goto/args 'call) 1))
-         (cond ((not tail)
-                (push-branch! #f 'br POST)))
-         (push-label! MV)
-         (push-code! src (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
-         (cond ((not tail)
-                (push-label! POST)
-                (maybe-drop)))))
-
-      ((<ghil-reified-env> env src)
-       (return-object! src (ghil-env-reify env)))))
-
-  ;;
-  ;; main
-  ;;
-
-  ;; analyze vars: partition into args, locs, exts, and assign indices
-  (record-case x
-    ((<ghil-lambda> env src vars rest meta body)
-     (let* ((evars (ghil-env-variables env))
-            (srcs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
-            (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
-            (nargs (allocate-indices-linearly! vars))
-            (nlocs (allocate-locals! locs body))
-            (nexts (allocate-indices-linearly! exts)))
-       ;; meta bindings
-       (push-bindings! #f vars)
-       ;; push on definition source location
-       (if src (set! stack (cons (make-glil-source src) stack)))
-       ;; copy args to the heap if they're marked as external
-       (do ((n 0 (1+ n))
-            (l vars (cdr l)))
-           ((null? l))
-         (let ((v (car l)))
-           (case (ghil-var-kind v)
-             ((external)
-              (push-code! #f (make-glil-argument 'ref n))
-              (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
-       ;; compile body
-       (comp body #t #f)
-       ;; create GLIL
-       (make-glil-program nargs (if rest 1 0) nlocs nexts meta
-                          (reverse! stack))))))
-
-(define (allocate-indices-linearly! vars)
-  (do ((n 0 (1+ n))
-       (l vars (cdr l)))
-      ((null? l) n)
-    (let ((v (car l))) (set! (ghil-var-index v) n))))
-
-(define (allocate-locals! vars body)
-  (let ((free '()) (nlocs 0))
-    (define (allocate! var)
-      (cond
-       ((pair? free)
-        (set! (ghil-var-index var) (car free))
-        (set! free (cdr free)))
-       (else
-        (set! (ghil-var-index var) nlocs)
-        (set! nlocs (1+ nlocs)))))
-    (define (deallocate! var)
-      (set! free (cons (ghil-var-index var) free)))
-    (let lp ((x body))
-      (record-case x
-        ((<ghil-void>))
-        ((<ghil-quote>))
-	((<ghil-quasiquote> exp)
-	 (let qlp ((x exp))
-           (cond ((list? x) (for-each qlp x))
-                 ((pair? x) (qlp (car x)) (qlp (cdr x)))
-                 ((record? x)
-                  (record-case x
-                   ((<ghil-unquote> exp) (lp exp))
-                   ((<ghil-unquote-splicing> exp) (lp exp)))))))
-        ((<ghil-unquote> exp)
-         (lp exp))
-        ((<ghil-unquote-splicing> exp)
-         (lp exp))
-        ((<ghil-reified-env>))
-        ((<ghil-set> val)
-         (lp val))
-        ((<ghil-ref>))
-        ((<ghil-define> val)
-         (lp val))
-        ((<ghil-if> test then else)
-         (lp test) (lp then) (lp else))
-        ((<ghil-and> exps)
-         (for-each lp exps))
-        ((<ghil-or> exps)
-         (for-each lp exps))
-        ((<ghil-begin> exps)
-         (for-each lp exps))
-        ((<ghil-bind> vars vals body)
-         (for-each allocate! vars)
-         (for-each lp vals)
-         (lp body)
-         (for-each deallocate! vars))
-        ((<ghil-mv-bind> vars producer body)
-         (lp producer)
-         (for-each allocate! vars)
-         (lp body)
-         (for-each deallocate! vars))
-        ((<ghil-inline> args)
-         (for-each lp args))
-        ((<ghil-call> proc args)
-         (lp proc)
-         (for-each lp args))
-        ((<ghil-lambda>))
-        ((<ghil-mv-call> producer consumer)
-         (lp producer)
-         (lp consumer))
-        ((<ghil-values> values)
-         (for-each lp values))
-        ((<ghil-values*> values)
-         (for-each lp values))))
-    nlocs))
+      ((<letrec> src vars vals exp)
+       (for-each comp-push vals)
+       (emit-bindings src 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)))))
+                 (reverse vars))
+       (comp-tail exp)
+       (emit-code #f (make-glil-unbind))))))