add lexical analyzer and allocator

* module/language/tree-il/optimize.scm: Rework to just export the
  optimize! procedure.

* module/language/tree-il/compile-glil.scm (analyze-lexicals): New
  function, analyzes and allocates lexical variables. Almost ready to
  compile now.
  (codegen): Dedent.

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

@@ -23,13 +23,196 @@
   #:use-module (system base syntax)
   #:use-module (language glil)
   #:use-module (language tree-il)
+  #:use-module (language tree-il optimize)
   #:use-module (ice-9 common-list)
   #: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)
+
 (define (compile-glil x e opts)
-  (values (codegen x)
+  (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))
+              e))))
 
 
 
@@ -57,8 +240,9 @@
                        (eq? (ghil-var-kind var) 'public)))
     (else (error "Unknown kind of variable:" var))))
 
-(define (codegen ghil)
+
-  (let ((stack '()))
+(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))))
@@ -251,7 +435,10 @@
 
   ;;
   ;; main
-    (record-case ghil
+  ;;
+
+  ;; 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))
@@ -276,7 +463,7 @@
        (comp body #t #f)
        ;; create GLIL
        (make-glil-program nargs (if rest 1 0) nlocs nexts meta
-                            (reverse! stack)))))))
+                          (reverse! stack))))))
 
 (define (allocate-indices-linearly! vars)
   (do ((n 0 (1+ n))

module/language/tree-il/optimize.scm

@@ -22,7 +22,14 @@
 (define-module (language tree-il optimize)
   #:use-module (system base syntax)
   #:use-module (language tree-il)
-  #:export (resolve-primitives!))
+  #:use-module (language tree-il inline)
+  #:export (optimize!))
+
+(define (env-module e)
+  (if e (car e) (current-module)))
+
+(define (optimize! x env opts)
+  (expand-primitives! (resolve-primitives! x (env-module env))))
 
 ;; Possible optimizations:
 ;; * constant folding, propagation