be smarter about allocating local variables, reusing slots if possible

* module/language/Makefile.am: OK, we can compile compile-ghil.scm now,
  thankfully.

* module/language/ecmascript/compile-ghil.scm (ormatch): New macro, a
  wrapper around pmatch to avoid some of the more egregious
  non-tail recursiveness.
  (comp): Use ormatch.

* module/language/ghil.scm (unparse-ghil): The body of bind and mv-bind
  is a single expression, not a list of expressions.

* module/language/ghil/compile-glil.scm (codegen): Be more clever when
  allocating "local" variables -- if a variable goes out of scope, its
  index can be re-used later.

* module/language/glil.scm (parse-glil, unparse-ghil): The "rest" of a
  mv-bind is a flag, not a list. The "ra" of an mv-call is a label, not a
  GLIL expression.

* module/language/objcode/spec.scm (collapse-locals, decompile-value):
  When decompiling a value, process the bindings list differently.
  Comments in the code.

* module/language/scheme/compile-ghil.scm (define-scheme-translator): Fix
  the generated error procedure.
  (let): Re-indent.
  (letrec): Re-indent.

* module/system/base/syntax.scm (record-case): If the body of a clause is
  null, fill it with the unspecified value.

module/language/Makefile.am

@@ -6,11 +6,11 @@ SOURCES=ghil.scm glil.scm assembly.scm \
 	ecmascript/impl.scm \
 	ecmascript/base.scm \
 	ecmascript/function.scm \
-	ecmascript/array.scm
-# unfortunately, the ones that we want to compile can't yet be compiled
-# -- too many local vars in the first case, and some non-tail-recursion
-# in pmatch in the second.
-NOCOMP_SOURCES = ecmascript/parse.scm \
+	ecmascript/array.scm \
 	ecmascript/compile-ghil.scm
+# unfortunately, the one that we want to compile can't yet be compiled
+# -- too many external vars, or something. seems like we need to do
+# closure elimination or something.
+NOCOMP_SOURCES = ecmascript/parse.scm
 modpath = language
 include $(top_srcdir)/am/guilec

module/language/assembly/disassemble.scm

@@ -135,9 +135,14 @@
        (and objs (list "~s" (vector-ref objs (car args)))))
       ((local-ref local-set)
        (and blocs
-            (let ((b (list-ref blocs (car args))))
-              (list "`~a'~@[ (arg)~]"
-                    (binding:name b) (< (binding:index b) nargs)))))
+            (let lp ((bindings (list-ref blocs (car args))))
+              (and (pair? bindings)
+                   (let ((b (car bindings)))
+                     (if (and (< (binding:start (car bindings)) end-addr)
+                              (>= (binding:end (car bindings)) end-addr))
+                         (list "`~a'~@[ (arg)~]"
+                               (binding:name b) (< (binding:index b) nargs))
+                         (lp (cdr bindings))))))))
       ((external-ref external-set)
        (and bexts
             (if (< (car args) (length bexts))

module/language/ecmascript/compile-ghil.scm

@@ -25,8 +25,6 @@
   #:use-module (system base pmatch)
   #:export (compile-ghil))
 
-(eval-case ((load-toplevel) (debug-set! stack 0)))
-
 (define (compile-ghil exp env opts)
   (values
   (call-with-ghil-environment (make-ghil-toplevel-env) '()
@@ -48,6 +46,15 @@
                    (@implv ,e ,l ,sym)
                    ,args))
 
+(define-macro (ormatch x . clauses)
+  (let ((X (gensym)))
+    `(let ((,X ,x))
+       (or ,@(map (lambda (c)
+                    (if (eq? (car c) 'else)
+                        `(begin . ,(cdr c))
+                        `(pmatch ,X ,c (else #f))))
+                  clauses)))))
+
 (define (comp x e)
   (let ((l (location x)))
     (define (let1 what proc)
@@ -62,7 +69,7 @@
                           (make-ghil-begin
                            e l (list (proc (car vars))
                                      (make-ghil-ref e l (car vars))))))))
-    (pmatch x
+    (ormatch x
       (null
        ;; FIXME, null doesn't have much relation to EOL...
        (make-ghil-quote e l '()))

module/language/ghil.scm

@@ -452,10 +452,10 @@
      `(begin ,@(map unparse-ghil exps)))
     ((<ghil-bind> env loc vars vals body)
      `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
-            ,@(map unparse-ghil body)))
+            ,(unparse-ghil body)))
     ((<ghil-mv-bind> env loc producer vars rest body)
      `(mv-bind ,(map ghil-var-name vars) ,rest
-               ,(unparse-ghil producer) ,@(map unparse-ghil body)))
+               ,(unparse-ghil producer) ,(unparse-ghil body)))
     ((<ghil-lambda> env loc vars rest meta body)
      `(lambda ,(map ghil-var-name vars) ,rest ,meta
               ,(unparse-ghil body)))

module/language/ghil/compile-glil.scm

@@ -415,14 +415,13 @@
       ((<ghil-lambda> env loc vars rest meta body)
        (let* ((evars (ghil-env-variables env))
 	      (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
-	      (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
-	 ;; initialize variable indexes
-	 (finalize-index! vars)
-	 (finalize-index! locs)
-	 (finalize-index! exts)
+	      (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)
-	 ;; export arguments
+	 ;; copy args to the heap if they're marked as external
 	 (do ((n 0 (1+ n))
 	      (l vars (cdr l)))
 	     ((null? l))
@@ -436,12 +435,78 @@
 	 ;; compile body
 	 (comp body #t #f)
 	 ;; create GLIL
-         (make-glil-program
-          (length vars) (if rest 1 0) (length locs) (length exts)
-          meta (reverse! stack)))))))
+         (make-glil-program nargs (if rest 1 0) nlocs nexts meta
+                            (reverse! stack)))))))
 
-(define (finalize-index! list)
+(define (allocate-indices-linearly! vars)
   (do ((n 0 (1+ n))
-       (l list (cdr l)))
-      ((null? l))
+       (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))

module/language/glil.scm

@@ -120,7 +120,7 @@
     ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
      (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
     ((bind . ,vars) (make-glil-bind vars))
-    ((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
+    ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
     ((unbind) (make-glil-unbind))
     ((source ,props) (make-glil-source props))
     ((void) (make-glil-void))
@@ -143,7 +143,7 @@
     ((<glil-program> nargs nrest nlocs nexts meta body)
      `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
     ((<glil-bind> vars) `(bind ,@vars))
-    ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
+    ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
     ((<glil-unbind>) `(unbind))
     ((<glil-source> props) `(source ,props))
     ;; constants
@@ -164,4 +164,4 @@
     ((<glil-label> label) `(label ,label))
     ((<glil-branch> inst label) `(branch ,inst ,label))
     ((<glil-call> inst nargs) `(call ,inst ,nargs))
-    ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))
+    ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))))

module/language/objcode/spec.scm

@@ -43,6 +43,25 @@
            (values (thunk) #f)))
         (values (thunk) #f))))
 
+;; since locals are allocated on the stack and can have limited scope,
+;; in many cases we use one local for more than one lexical variable. so
+;; the returned locals set is a list, where element N of the list is
+;; itself a list of bindings for local variable N.
+(define (collapse-locals locs)
+  (let lp ((ret '()) (locs locs))
+    (if (null? locs)
+        (map cdr (sort! ret 
+                        (lambda (x y) (< (car x) (car y)))))
+        (let ((b (car locs)))
+          (cond
+           ((assv-ref ret (binding:index b))
+            => (lambda (bindings)
+                 (append! bindings (list b))
+                 (lp ret (cdr locs))))
+           (else
+            (lp (acons (binding:index b) (list b) ret)
+                (cdr locs))))))))
+
 (define (decompile-value x env opts)
   (cond
    ((program? x)
@@ -53,9 +72,10 @@
           (srcs  (program-sources x))
           (nargs (arity:nargs (program-arity x))))
       (let ((blocs (and binds
-                        (append (list-head binds nargs)
-                                (filter (lambda (x) (not (binding:extp x)))
-                                        (list-tail binds nargs)))))
+                        (collapse-locals
+                         (append (list-head binds nargs)
+                                 (filter (lambda (x) (not (binding:extp x)))
+                                         (list-tail binds nargs))))))
             (bexts (and binds
                         (filter binding:extp binds))))
         (values (program-objcode x)

module/language/scheme/compile-ghil.scm

@@ -175,7 +175,7 @@
                  (pmatch (cdr exp)
                          ,@clauses
                          ,@(if (assq 'else clauses) '()
-                               '((else
+                               `((else
                                   (syntax-error l (format #f "bad ~A" ',sym) exp))))))))
 
 (define-scheme-translator quote
@@ -261,8 +261,8 @@
                       (maybe-name-value! (retrans (cadr b)) (car b)))
                     bindings)))
      (call-with-ghil-bindings e (map car bindings)
-                              (lambda (vars)
-                                (make-ghil-bind e l vars vals (trans-body e l body)))))))
+       (lambda (vars)
+         (make-ghil-bind e l vars vals (trans-body e l body)))))))
 
 (define-scheme-translator let*
   ;; (let* ((SYM VAL) ...) BODY...)
@@ -275,12 +275,12 @@
   ;; (letrec ((SYM VAL) ...) BODY...)
   ((,bindings . ,body) (guard (valid-bindings? bindings))
    (call-with-ghil-bindings e (map car bindings)
-                            (lambda (vars)
-                              (let ((vals (map (lambda (b)
-                                                 (maybe-name-value!
-                                                  (retrans (cadr b)) (car b)))
-                                               bindings)))
-                                (make-ghil-bind e l vars vals (trans-body e l body)))))))
+     (lambda (vars)
+       (let ((vals (map (lambda (b)
+                          (maybe-name-value!
+                           (retrans (cadr b)) (car b)))
+                        bindings)))
+         (make-ghil-bind e l vars vals (trans-body e l body)))))))
 
 (define-scheme-translator cond
   ;; (cond (CLAUSE BODY...) ...)

module/system/base/syntax.scm

@@ -180,7 +180,7 @@
                                  `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
                                  `(,slot (,(symbol-append stem '- slot) ,r))))
                            slots)
-                  ,@body))))))
+                  ,@(if (pair? body) body '((if #f #f)))))))))
     `(let* ((,r ,record)
             (,rtd (struct-vtable ,r)))
        (cond ,@(let ((clauses (map process-clause clauses)))