new language: tree-il. psyntax generates it when run in compile mode.

* module/Makefile.am: Add tree-il sources.

* module/ice-9/compile-psyntax.scm: Adjust for sc-expand producing
  tree-il in compile mode.

* module/ice-9/psyntax.scm: Switch from expand-support to tree-il for
  generating output in compile mode. Completely generate tree-il -- the
  output wasn't Scheme before, but now it's completely not Scheme.

* module/ice-9/psyntax-pp.scm: Regenerated.

* module/language/scheme/compile-ghil.scm: Strip structures using
  tree-il, not expand-support.

* module/language/tree-il.scm:
* module/language/tree-il/spec.scm
* module/language/tree-il/compile-glil.scm: New language. It will compile
  to GLIL, though it doesn't yet.

module/Makefile.am

@@ -35,9 +35,11 @@ SOURCES =								\
   system/base/pmatch.scm system/base/syntax.scm				\
   system/base/compile.scm system/base/language.scm			\
 									\
+  language/tree-il.scm							\
   language/ghil.scm language/glil.scm language/assembly.scm		\
 									\
   $(SCHEME_LANG_SOURCES) 						\
+  $(TREE_IL_LANG_SOURCES)						\
   $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES)				\
   $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES)			\
   $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)				\
@@ -67,6 +69,9 @@ SCHEME_LANG_SOURCES =						\
   language/scheme/compile-ghil.scm language/scheme/spec.scm	\
   language/scheme/inline.scm
 
+TREE_IL_LANG_SOURCES =	\
+  language/tree-il/spec.scm language/tree-il/compile-glil.scm
+
 GHIL_LANG_SOURCES =					\
   language/ghil/spec.scm language/ghil/compile-glil.scm
 

module/ice-9/compile-psyntax.scm

@@ -1,4 +1,4 @@
-(use-modules (ice-9 expand-support))
+(use-modules (language tree-il))
 (let ((source (list-ref (command-line) 1))
       (target (list-ref (command-line) 2)))
   (let ((in (open-input-file source))
@@ -12,7 +12,7 @@
             (close-port out)
             (close-port in))
           (begin
-            (write (strip-expansion-structures
+            (write (tree-il->scheme
                     (sc-expand x 'c '(compile load eval)))
                    out)
             (newline out)

module/ice-9/psyntax.scm

@@ -304,7 +304,7 @@
     (primitive-eval
      `(,noexpand
        ,(case (fluid-ref *mode*)
-          ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
+          ((c) ((@ (language tree-il) tree-il->scheme) x))
           (else x))))))
 
 (define local-eval-hook
@@ -312,7 +312,7 @@
     (primitive-eval
      `(,noexpand
        ,(case (fluid-ref *mode*)
-          ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
+          ((c) ((@ (language tree-il) tree-il->scheme) x))
           (else x))))))
 
 (define-syntax gensym-hook
@@ -351,132 +351,150 @@
 
 
 ;;; output constructors
-(define (build-annotated src exp)
+(define build-application
-  (if (and src (not (annotation? exp)))
+  (lambda (source fun-exp arg-exps)
-      (make-annotation exp src #t)
+    (case (fluid-ref *mode*)
-      exp))
+      ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+      (else `(,fun-exp . ,arg-exps)))))
 
-(define-syntax build-application
+(define build-conditional
-  (syntax-rules ()
+  (lambda (source test-exp then-exp else-exp)
-    ((_ source fun-exp arg-exps)
+    (case (fluid-ref *mode*)
-     (build-annotated source `(,fun-exp . ,arg-exps)))))
+      ((c) ((@ (language tree-il) make-conditional)
-
+            source test-exp then-exp else-exp))
-(define-syntax build-conditional
+      (else `(if ,test-exp ,then-exp ,else-exp)))))
-  (syntax-rules ()
-    ((_ source test-exp then-exp else-exp)
-     (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
 
 (define build-lexical-reference
   (lambda (type source name var)
-    (build-annotated
-     source 
     (case (fluid-ref *mode*)
-       ((c) ((@ (ice-9 expand-support) make-lexical) source name var))
+      ((c) ((@ (language tree-il) make-lexical-ref) source name var))
-       (else var)))))
+      (else var))))
 
 (define build-lexical-assignment
   (lambda (source name var exp)
-    (build-annotated
+    (case (fluid-ref *mode*)
-     source
+      ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
-     `(set! ,(build-lexical-reference 'set no-source name var)
+      (else `(set! ,var ,exp)))))
-            ,exp))))
 
 ;; Before modules are booted, we can't expand into data structures from
-;; (ice-9 expand-support) -- we need to give the evaluator the
+;; (language tree-il) -- we need to give the evaluator the
 ;; s-expressions that it understands natively. Actually the real truth
 ;; of the matter is that the evaluator doesn't understand expand-support
 ;; structures at all. So until we fix the evaluator, if ever, the
-;; conflation that we should use expand-support iff we are compiling
+;; conflation that we should use tree-il iff we are compiling
 ;; holds true.
 ;;
-(define build-global-reference
+(define (analyze-variable mod var modref-cont bare-cont)
-  (lambda (source var mod)
-    (build-annotated
-     source
   (if (not mod)
-         var
+      (bare-cont var)
-         (let ((make-module-ref
+      (let ((kind (car mod))
-                (case (fluid-ref *mode*)
-                  ((c) (@ (ice-9 expand-support) make-module-ref))
-                  (else (lambda (source mod var public?)
-                          (list (if public? '@ '@@) mod var)))))
-               (kind (car mod))
             (mod (cdr mod)))
         (case kind
-             ((public) (make-module-ref #f mod var #t))
+          ((public) (modref-cont mod var #t))
           ((private) (if (not (equal? mod (module-name (current-module))))
-                            (make-module-ref #f mod var #f)
+                         (modref-cont mod var #f)
-                            var))
+                         (bare-cont var)))
-             ((bare) var)
+          ((bare) (bare-cont var))
           ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
                               (module-variable (resolve-module mod) var))
-                            (make-module-ref #f mod var #f)
+                         (modref-cont mod var #f)
-                            var))
+                         (bare-cont var)))
-             (else (syntax-violation #f "bad module kind" var mod))))))))
+          (else (syntax-violation #f "bad module kind" var mod))))))
+
+(define build-global-reference
+  (lambda (source var mod)
+    (analyze-variable
+     mod var
+     (lambda (mod var public?) 
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
+         (else (list (if public? '@ '@@) mod var))))
+     (lambda (var)
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+         (else var))))))
 
 (define build-global-assignment
   (lambda (source var exp mod)
-    (let ((ref (build-global-reference source var mod)))
+    (analyze-variable
-      (build-annotated
+     mod var
-       source
+     (lambda (mod var public?) 
-       `(set! ,ref ,exp)))))
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
+         (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+     (lambda (var)
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+         (else `(set! ,var ,exp)))))))
 
-(define-syntax build-global-definition
+(define build-global-definition
-  (syntax-rules ()
+  (lambda (source var exp)
-    ((_ source var exp)
+    (case (fluid-ref *mode*)
-     (build-annotated source `(define ,var ,exp)))))
+      ((c) ((@ (language tree-il) make-toplevel-define) source var exp))
+      (else `(define ,var ,exp)))))
 
-(define-syntax build-lambda
+(define build-lambda
-  (syntax-rules ()
+  (lambda (src vars docstring exp)
-    ((_ src vars docstring exp)
+    (case (fluid-ref *mode*)
-     (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
+      ((c) ((@ (language tree-il) make-lambda) src vars
-                                   ,exp)))
+            (if docstring `((documentation . ,docstring)) '())
-    ((_ src vars exp)
+            exp))
-     (build-annotated src `(lambda ,vars ,exp)))))
+      (else `(lambda ,vars ,@(if docstring (list docstring) '())
+                     ,exp)))))
 
-;; FIXME: wingo: add modules here somehow?
+(define build-primref
-(define-syntax build-primref
+  (lambda (src name)
-  (syntax-rules ()
+    (case (fluid-ref *mode*)
-    ((_ src name) (build-annotated src name))
+      ((c) ((@ (language tree-il) make-primitive-ref) src name))
-    ((_ src level name) (build-annotated src name))))
+      ;; hygiene guile is a hack
+      (else (build-global-reference src name '(hygiene guile))))))
 
 (define (build-data src exp)
-  (if (and (self-evaluating? exp)
+  (case (fluid-ref *mode*)
-	   (not (vector? exp)))
+    ((c) ((@ (language tree-il) make-const) src exp))
-      (build-annotated src exp)
+    (else (if (and (self-evaluating? exp) (not (vector? exp)))
-      (build-annotated src (list 'quote exp))))
+              exp
+              (list 'quote exp)))))
 
 (define build-sequence
   (lambda (src exps)
     (if (null? (cdr exps))
-        (build-annotated src (car exps))
+        (car exps)
-        (build-annotated src `(begin ,@exps)))))
+        (case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) make-sequence) src exps))
+          (else `(begin ,@exps))))))
 
 (define build-let
   (lambda (src vars val-exps body-exp)
     (if (null? vars)
-	(build-annotated src body-exp)
+	body-exp
-	(build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
+        (case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) make-let) src vars val-exps body-exp))
+          (else `(let ,(map list vars val-exps) ,body-exp))))))
 
 (define build-named-let
   (lambda (src vars val-exps body-exp)
-    (if (null? vars)
+    (let ((f (car vars))
-	(build-annotated src body-exp)
+          (vars (cdr vars)))
-	(build-annotated src
+      (case (fluid-ref *mode*)
-                         `(let ,(car vars)
+        ((c) ((@ (language tree-il) make-letrec) src
-                            ,(map list (cdr vars) val-exps) ,body-exp)))))
+              (list f) (list (build-lambda src vars #f body-exp))
+              (build-application src (build-lexical-reference 'fun src f f)
+                                 val-exps)))
+        (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
 
 (define build-letrec
   (lambda (src vars val-exps body-exp)
     (if (null? vars)
-        (build-annotated src body-exp)
+        body-exp
-        (build-annotated src
+        (case (fluid-ref *mode*)
-                         `(letrec ,(map list vars val-exps) ,body-exp)))))
+          ((c) ((@ (language tree-il) make-letrec) src vars val-exps body-exp))
+          (else `(letrec ,(map list vars val-exps) ,body-exp))))))
 
-;; FIXME: wingo: use make-lexical
+;; FIXME: wingo: use make-lexical ?
 (define-syntax build-lexical-var
   (syntax-rules ()
-    ((_ src id) (build-annotated src (gensym (symbol->string id))))))
+    ((_ src id) (gensym (symbol->string id)))))
 
 (define-structure (syntax-object expression wrap module))
 
@@ -1729,13 +1747,12 @@
           ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
           ((primitive) (build-primref no-source (cadr x)))
           ((quote) (build-data no-source (cadr x)))
-          ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+          ((lambda) (build-lambda no-source (cadr x) #f (regen (caddr x))))
           ((map) (let ((ls (map regen (cdr x))))
                    (build-application no-source
-                     (if (fx= (length ls) 2)
+                     ;; this check used to be here, not sure what for:
+                     ;; (if (fx= (length ls) 2)
                      (build-primref no-source 'map)
-                        ; really need to do our own checking here
-                         (build-primref no-source 2 'map)) ; require error check
                      ls)))
           (else (build-application no-source
                   (build-primref no-source (car x))
@@ -1913,7 +1930,7 @@
           (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
             (build-application no-source
               (build-primref no-source 'apply)
-              (list (build-lambda no-source new-vars
+              (list (build-lambda no-source new-vars #f
                       (chi exp
                            (extend-env
                             labels
@@ -1940,7 +1957,7 @@
                (let ((y (gen-var 'tmp)))
                  ; fat finger binding and references to temp variable y
                  (build-application no-source
-                   (build-lambda no-source (list y)
+                   (build-lambda no-source (list y) #f
                      (let ((y (build-lexical-reference 'value no-source
                                                        'tmp y)))
                        (build-conditional no-source
@@ -1974,7 +1991,7 @@
                    (let ((labels (list (gen-label)))
                          (var (gen-var (syntax pat))))
                      (build-application no-source
-                       (build-lambda no-source (list var)
+                       (build-lambda no-source (list var) #f
                          (chi (syntax exp)
                               (extend-env labels
                                 (list (make-binding 'syntax `(,var . 0)))
@@ -2000,7 +2017,7 @@
                (let ((x (gen-var 'tmp)))
                  ; fat finger binding and references to temp variable x
                  (build-application s
-                   (build-lambda no-source (list x)
+                   (build-lambda no-source (list x) #f
                      (gen-syntax-case (build-lexical-reference 'value no-source
                                                                'tmp x)
                        (syntax (key ...)) (syntax (m ...))

module/language/scheme/compile-ghil.scm

@@ -27,7 +27,7 @@
   #:use-module (system vm objcode)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
-  #:use-module (ice-9 expand-support)
+  #:use-module (language tree-il)
   #:use-module ((system base compile) #:select (syntax-error))
   #:export (compile-ghil translate-1
             *translate-table* define-scheme-translator))
@@ -70,7 +70,7 @@
      (and=> (cenv-module e) set-current-module)
      (call-with-ghil-environment (cenv-ghil-env e) '()
        (lambda (env vars)
-         (let ((x (strip-expansion-structures
+         (let ((x (tree-il->scheme
                    (sc-expand x 'c '(compile load eval)))))
            (let ((x (make-ghil-lambda env #f vars #f '()
                                       (translate-1 env #f x)))

module/language/tree-il.scm

@@ -0,0 +1,248 @@
+;;;; 	Copyright (C) 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+
+(define-module (language tree-il)
+  #:use-module (system base pmatch)
+  #:use-module (system base syntax)
+  :export (tree-il-loc
+
+           <lexical> make-lexical
+           lexical-name lexical-gensym
+
+           <application> make-application application-loc application-proc application-args
+           <conditional> make-conditional conditional-loc conditional-test conditional-then conditional-else
+           <primitive-ref> make-primitive-ref primitive-ref-loc primitive-ref-name
+           <lexical-ref> make-lexical-ref lexical-ref-loc lexical-ref-name lexical-ref-gensym
+           <lexical-set> make-lexical-set lexical-set-loc lexical-set-name lexical-set-gensym lexical-set-exp
+           <module-ref> make-module-ref module-ref-loc module-ref-mod module-ref-name module-ref-public?
+           <module-set> make-module-set module-set-loc module-set-mod module-set-name module-set-public? module-set-exp
+           <toplevel-ref> make-toplevel-ref toplevel-ref-loc toplevel-ref-name
+           <toplevel-set> make-toplevel-set toplevel-set-loc toplevel-set-name toplevel-set-exp
+           <toplevel-define> make-toplevel-define toplevel-define-loc toplevel-define-name toplevel-define-exp
+           <lambda> make-lambda lambda-loc lambda-vars lambda-meta lambda-body
+           <const> make-const const-loc const-exp
+           <sequence> make-sequence sequence-loc sequence-exps
+           <let> make-let let-loc let-vars let-vals let-exp
+           <letrec> make-letrec letrec-loc letrec-vars letrec-vals letrec-exp
+
+           parse-tree-il
+           unparse-tree-il
+           tree-il->scheme))
+
+(define-type (<tree-il> #:common-slots (src))
+  (<application> proc args)
+  (<conditional> test then else)
+  (<primitive-ref> name)
+  (<lexical-ref> name gensym)
+  (<lexical-set> name gensym exp)
+  (<module-ref> mod name public?)
+  (<module-set> mod name public? exp)
+  (<toplevel-ref> name)
+  (<toplevel-set> name exp)
+  (<toplevel-define> name exp)
+  (<lambda> vars meta body)
+  (<const> exp)
+  (<sequence> exps)
+  (<let> vars vals exp)
+  (<letrec> vars vals exp))
+  
+(define <lexical> <lexical-ref>)
+(define lexical? lexical-ref?)
+(define make-lexical make-lexical-ref)
+(define lexical-name lexical-ref-name)
+(define lexical-gensym lexical-ref-gensym)
+
+
+
+;; FIXME: use this in psyntax
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (not (null? props))
+	      (vector (assq-ref props 'line)
+                      (assq-ref props 'column)
+                      (assq-ref props 'filename))))))
+
+(define (parse-tree-il env exp)
+  (let ((loc (location exp))
+        (retrans (lambda (x) (parse-ghil env x))))
+    (pmatch exp
+     ((apply ,proc ,args)
+      (make-application loc (retrans proc) (retrans args)))
+
+     ((if ,test ,then ,else)
+      (make-conditional loc (retrans test) (retrans then) (retrans else)))
+
+     ((primitive ,name) (guard (symbol? name))
+      (make-primitive-ref loc name))
+
+     ((lexical ,name) (guard (symbol? name))
+      (make-lexical-ref loc name name))
+
+     ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+      (make-lexical-ref loc name sym))
+
+     ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+      (make-lexical-set loc name sym (retrans exp)))
+
+     ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-ref loc mod name #t))
+
+     ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-set loc mod name #t (retrans exp)))
+
+     ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-ref loc mod name #f))
+
+     ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+      (make-module-set loc mod name #f (retrans exp)))
+
+     ((toplevel ,name) (guard (symbol? name))
+      (make-toplevel-ref loc name))
+
+     ((set! (toplevel ,name) exp) (guard (symbol? name))
+      (make-toplevel-set loc name (retrans exp)))
+
+     ((define ,name exp) (guard (symbol? name))
+      (make-toplevel-define loc name (retrans exp)))
+
+     ((lambda ,vars ,exp)
+      (make-lambda loc vars '() (retrans exp)))
+
+     ((lambda ,vars ,meta ,exp)
+      (make-lambda loc vars meta (retrans exp)))
+
+     ((const ,exp)
+      (make-const loc exp))
+
+     ((begin . ,exps)
+      (make-sequence loc (map retrans exps)))
+
+     ((let ,vars ,vals ,exp)
+      (make-let loc vars vals (retrans exp)))
+
+     ((letrec ,vars ,vals ,exp)
+      (make-letrec loc vars vals (retrans exp)))
+
+     (else
+      (error "unrecognized tree-il" exp)))))
+
+(define (unparse-tree-il tree-il)
+  (record-case tree-il
+    ((<application> proc args)
+     `(apply ,(unparse-tree-il proc) ,(map unparse-tree-il args)))
+
+    ((<conditional> test then else)
+     `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
+
+    ((<primitive-ref> name)
+     `(primitive ,name))
+
+    ((<lexical-ref> name gensym)
+     `(lexical ,name ,gensym))
+
+    ((<lexical-set> name gensym exp)
+     `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
+
+    ((<module-ref> mod name public?)
+     `(,(if public? '@ '@@) ,mod ,name))
+
+    ((<module-set> mod name public? exp)
+     `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
+
+    ((<toplevel-ref> name)
+     `(toplevel ,name))
+
+    ((<toplevel-set> name exp)
+     `(set! (toplevel ,name) ,(unparse-tree-il exp)))
+
+    ((<toplevel-define> name exp)
+     `(define ,name ,(unparse-tree-il exp)))
+
+    ((<lambda> vars meta body)
+     `(lambda ,vars ,meta ,(unparse-tree-il body)))
+
+    ((<const> exp)
+     `(const ,exp))
+
+    ((<sequence> exps)
+     `(begin ,@(map unparse-tree-il exps)))
+
+    ((<let> vars vals exp)
+     `(let ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+
+    ((<letrec> vars vals exp)
+     `(letrec ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))))
+
+(define (tree-il->scheme e)
+  (cond ((list? e)
+         (map tree-il->scheme e))
+        ((pair? e)
+         (cons (tree-il->scheme (car e))
+               (tree-il->scheme (cdr e))))
+        ((record? e)
+         (record-case e
+           ((<application> proc args)
+            `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+           ((<conditional> test then else)
+            `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))
+
+           ((<primitive-ref> name)
+            name)
+           
+           ((<lexical-ref> name gensym)
+            gensym)
+           
+           ((<lexical-set> name gensym exp)
+            `(set! ,gensym ,(tree-il->scheme exp)))
+           
+           ((<module-ref> mod name public?)
+            `(,(if public? '@ '@@) ,mod ,name))
+           
+           ((<module-set> mod name public? exp)
+            `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
+           
+           ((<toplevel-ref> name)
+            name)
+           
+           ((<toplevel-set> name exp)
+            `(set! ,name ,(tree-il->scheme exp)))
+           
+           ((<toplevel-define> name exp)
+            `(define ,name ,(tree-il->scheme exp)))
+           
+           ((<lambda> vars meta body)
+            `(lambda ,vars
+               ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
+               ,(tree-il->scheme body)))
+           
+           ((<const> exp)
+            (if (and (self-evaluating? exp) (not (vector? exp)))
+                exp
+                (list 'quote exp)))
+           
+           ((<sequence> exps)
+            `(begin ,@(map tree-il->scheme exps)))
+           
+           ((<let> vars vals exp)
+            `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
+           
+           ((<letrec> vars vals exp)
+            `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))))
+        (else e)))

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

@@ -0,0 +1,591 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001 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 compile-glil)
+  #:use-module (system base syntax)
+  #:use-module (language glil)
+  #:use-module (language tree-il)
+  #:use-module (ice-9 common-list)
+  #:export (compile-glil))
+
+(define (compile-glil x e opts)
+  (if (memq #:O opts) (set! x (optimize x)))
+  (values (codegen x)
+          (and e (cons (car e) (cddr e)))
+          e))
+
+
+;;;
+;;; Stage 2: Optimization
+;;;
+
+(define (lift-variables! env)
+  (let ((parent-env (ghil-env-parent env)))
+    (for-each (lambda (v)
+                (case (ghil-var-kind v)
+                  ((argument) (set! (ghil-var-kind v) 'local)))
+                (set! (ghil-var-env v) parent-env)
+                (ghil-env-add! parent-env v))
+              (ghil-env-variables env))))
+
+;; The premise of this, unused, approach to optimization is that you can
+;; determine the environment of a variable lexically, because they have
+;; been alpha-renamed. It makes the transformations *much* easier.
+;; Unfortunately it doesn't work yet.
+(define (optimize* x)
+  (transform-record (<ghil> env loc) x
+    ((quasiquote exp)
+     (define (optimize-qq x)
+       (cond ((list? x) (map optimize-qq x))
+             ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
+             ((record? x) (optimize x))
+             (else x)))
+     (-> (quasiquote (optimize-qq x))))
+
+    ((unquote exp)
+     (-> (unquote (optimize exp))))
+
+    ((unquote-splicing exp)
+     (-> (unquote-splicing (optimize exp))))
+
+    ((set var val)
+     (-> (set var (optimize val))))
+
+    ((define var val)
+     (-> (define var (optimize val))))
+
+    ((if test then else)
+     (-> (if (optimize test) (optimize then) (optimize else))))
+
+    ((and exps)
+     (-> (and (map optimize exps))))
+
+    ((or exps)
+     (-> (or (map optimize exps))))
+
+    ((begin exps)
+     (-> (begin (map optimize exps))))
+
+    ((bind vars vals body)
+     (-> (bind vars (map optimize vals) (optimize body))))
+
+    ((mv-bind producer vars rest body)
+     (-> (mv-bind (optimize producer) vars rest (optimize body))))
+
+    ((inline inst args)
+     (-> (inline inst (map optimize args))))
+
+    ((call (proc (lambda vars (rest #f) meta body)) args)
+     (-> (bind vars (optimize args) (optimize body))))
+
+    ((call proc args)
+     (-> (call (optimize proc) (map optimize args))))
+
+    ((lambda vars rest meta body)
+     (-> (lambda vars rest meta (optimize body))))
+
+    ((mv-call producer (consumer (lambda vars rest meta body)))
+     (-> (mv-bind (optimize producer) vars rest (optimize body))))
+
+    ((mv-call producer consumer)
+     (-> (mv-call (optimize producer) (optimize consumer))))
+
+    ((values values)
+     (-> (values (map optimize values))))
+
+    ((values* values)
+     (-> (values* (map optimize values))))
+
+    (else
+     (error "unrecognized GHIL" x))))
+
+(define (optimize x)
+  (record-case x
+    ((<ghil-set> env loc var val)
+     (make-ghil-set env var (optimize val)))
+
+    ((<ghil-define> env loc var val)
+     (make-ghil-define env var (optimize val)))
+
+    ((<ghil-if> env loc test then else)
+     (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
+
+    ((<ghil-and> env loc exps)
+     (make-ghil-and env loc (map optimize exps)))
+
+    ((<ghil-or> env loc exps)
+     (make-ghil-or env loc (map optimize exps)))
+
+    ((<ghil-begin> env loc exps)
+     (make-ghil-begin env loc (map optimize exps)))
+
+    ((<ghil-bind> env loc vars vals body)
+     (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
+
+    ((<ghil-lambda> env loc vars rest meta body)
+     (make-ghil-lambda env loc vars rest meta (optimize body)))
+
+    ((<ghil-inline> env loc instruction args)
+     (make-ghil-inline env loc instruction (map optimize args)))
+
+    ((<ghil-call> env loc proc args)
+     (let ((parent-env env))
+       (record-case proc
+         ;; ((@lambda (VAR...) BODY...) ARG...) =>
+         ;;   (@let ((VAR ARG) ...) BODY...)
+         ((<ghil-lambda> env loc vars rest meta body)
+          (cond
+           ((not rest)
+            (lift-variables! env)
+            (make-ghil-bind parent-env loc (map optimize args)))
+           (else
+            (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
+         (else
+          (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
+
+    ((<ghil-mv-call> env loc producer consumer)
+     (record-case consumer
+      ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
+      ;;   (mv-let PRODUCER ARGS BODY...)
+      ((<ghil-lambda> env loc vars rest meta body)
+       (lift-variables! env)
+       (make-ghil-mv-bind producer vars rest body))
+      (else
+       (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
+
+    (else x)))
+
+
+;;;
+;;; Stage 3: Code generation
+;;;
+
+(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 (constant? x)
+  (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
+        ((pair? x) (and (constant? (car x))
+                        (constant? (cdr x))))
+        ((vector? x) (let lp ((i (vector-length x)))
+                       (or (zero? i)
+                           (and (constant? (vector-ref x (1- i)))
+                                (lp (1- i))))))))
+
+(define (codegen ghil)
+  (let ((stack '()))
+    (define (push-code! loc code)
+      (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)))
+    (define (push-bindings! loc vars)
+      (if (not (null? vars))
+          (push-code! loc (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! loc inst label)
+	(push-code! loc (make-glil-branch inst label)))
+      (define (push-call! loc inst args)
+	(for-each comp-push args)
+	(push-code! loc (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! loc code)
+	(if (not drop) (push-code! loc code))
+	(maybe-return))
+      ;; return void if necessary
+      (define (return-void!)
+	(return-code! #f *ia-void*))
+      ;; return object if necessary
+      (define (return-object! loc obj)
+	(return-code! loc (make-glil-const obj)))
+      ;;
+      ;; dispatch
+      (record-case tree
+	((<ghil-void>)
+	 (return-void!))
+
+	((<ghil-quote> env loc obj)
+	 (return-object! loc obj))
+
+	((<ghil-quasiquote> env loc exp)
+	 (let loop ((x exp) (in-car? #f))
+           (cond
+            ((list? x)
+             (push-call! #f 'mark '())
+             (for-each (lambda (x) (loop x #t)) x)
+             (push-call! #f 'list-mark '()))
+            ((pair? x)
+             (push-call! #f 'mark '())
+             (loop (car x) #t)
+             (loop (cdr x) #f)
+             (push-call! #f 'cons-mark '()))
+            ((record? x)
+             (record-case x
+              ((<ghil-unquote> env loc exp)
+               (comp-push exp))
+              ((<ghil-unquote-splicing> env loc exp)
+               (if (not in-car?)
+                   (error "unquote-splicing in the cdr of a pair" exp))
+               (comp-push exp)
+               (push-call! #f 'list-break '()))))
+            ((constant? x)
+             (push-code! #f (make-glil-const x)))
+            (else
+             (error "element of quasiquote can't be compiled" x))))
+	 (maybe-drop)
+	 (maybe-return))
+
+	((<ghil-unquote> env loc exp)
+         (error "unquote outside of quasiquote" exp))
+
+	((<ghil-unquote-splicing> env loc exp)
+         (error "unquote-splicing outside of quasiquote" exp))
+
+	((<ghil-ref> env loc var)
+	 (return-code! loc (make-glil-var 'ref env var)))
+
+	((<ghil-set> env loc var val)
+	 (comp-push val)
+	 (push-code! loc (make-glil-var 'set env var))
+	 (return-void!))
+
+	((<ghil-define> env loc var val)
+	 (comp-push val)
+	 (push-code! loc (make-glil-var 'define env var))
+	 (return-void!))
+
+	((<ghil-if> env loc test then else)
+	 ;;     TEST
+	 ;;     (br-if-not L1)
+	 ;;     THEN
+	 ;;     (br L2)
+	 ;; L1: ELSE
+	 ;; L2:
+	 (let ((L1 (make-label)) (L2 (make-label)))
+	   (comp-push test)
+	   (push-branch! loc 'br-if-not L1)
+	   (comp-tail then)
+	   (if (not tail) (push-branch! #f 'br L2))
+	   (push-label! L1)
+	   (comp-tail else)
+	   (if (not tail) (push-label! L2))))
+
+	((<ghil-and> env loc exps)
+	 ;;     EXP
+	 ;;     (br-if-not L1)
+	 ;;     ...
+	 ;;     TAIL
+	 ;;     (br L2)
+	 ;; L1: (const #f)
+	 ;; L2:
+         (cond ((null? exps) (return-object! loc #t))
+               ((null? (cdr exps)) (comp-tail (car exps)))
+               (else
+                (let ((L1 (make-label)) (L2 (make-label)))
+                  (let lp ((exps exps))
+                    (cond ((null? (cdr exps))
+                           (comp-tail (car exps))
+                           (push-branch! #f 'br L2)
+                           (push-label! L1)
+                           (return-object! #f #f)
+                           (push-label! L2)
+                           (maybe-return))
+                          (else
+                           (comp-push (car exps))
+                           (push-branch! #f 'br-if-not L1)
+                           (lp (cdr exps)))))))))
+
+	((<ghil-or> env loc exps)
+	 ;;     EXP
+	 ;;     (dup)
+	 ;;     (br-if L1)
+	 ;;     (drop)
+	 ;;     ...
+	 ;;     TAIL
+	 ;; L1:
+         (cond ((null? exps) (return-object! loc #f))
+               ((null? (cdr exps)) (comp-tail (car exps)))
+               (else
+                (let ((L1 (make-label)))
+                  (let lp ((exps exps))
+                    (cond ((null? (cdr exps))
+                           (comp-tail (car exps))
+                           (push-label! L1)
+                           (maybe-return))
+                          (else
+                           (comp-push (car exps))
+                           (if (not drop)
+                               (push-call! #f 'dup '()))
+                           (push-branch! #f 'br-if L1)
+                           (if (not drop)
+                               (push-code! loc (make-glil-call 'drop 1)))
+                           (lp (cdr exps)))))))))
+
+	((<ghil-begin> env loc exps)
+	 ;; EXPS...
+	 ;; TAIL
+	 (if (null? exps)
+	     (return-void!)
+	     (do ((exps exps (cdr exps)))
+		 ((null? (cdr exps))
+		  (comp-tail (car exps)))
+	       (comp-drop (car exps)))))
+
+	((<ghil-bind> env loc vars vals body)
+	 ;; VALS...
+	 ;; (set VARS)...
+	 ;; BODY
+	 (for-each comp-push vals)
+         (push-bindings! loc 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)))
+
+	((<ghil-mv-bind> env loc producer vars rest body)
+	 ;; VALS...
+	 ;; (set VARS)...
+	 ;; BODY
+         (let ((MV (make-label)))
+           (comp-push producer)
+           (push-code! loc (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 loc vars rest meta body)
+	 (return-code! loc (codegen tree)))
+
+	((<ghil-inline> env loc 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! loc tail-inst args)))
+                 (else
+                  (push-call! loc inline args)
+                  (maybe-drop)
+                  (maybe-return)))))
+
+        ((<ghil-values> env loc values)
+         (cond (tail ;; (lambda () (values 1 2))
+                (push-call! loc '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! loc 'call values))))
+                
+        ((<ghil-values*> env loc values)
+         (cond (tail ;; (lambda () (apply values '(1 2)))
+                (push-call! loc '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! loc 'apply values))))
+                
+	((<ghil-call> env loc proc args)
+	 ;; PROC
+	 ;; ARGS...
+	 ;; ([tail-]call NARGS)
+	 (comp-push proc)
+         (let ((nargs (length args)))
+           (cond ((< nargs 255)
+                  (push-call! loc (if tail 'goto/args 'call) args))
+                 (else
+                  (push-call! loc 'mark '())
+                  (for-each comp-push args)
+                  (push-call! loc 'list-mark '())
+                  (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
+	 (maybe-drop))
+
+	((<ghil-mv-call> env loc 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! loc (make-glil-mv-call 0 MV))
+           (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
+           (cond ((not tail)
+                  (push-branch! #f 'br POST)))
+           (push-label! MV)
+           (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
+           (cond ((not tail)
+                  (push-label! POST)
+                  (maybe-drop)))))
+
+        ((<ghil-reified-env> env loc)
+         (return-object! loc (ghil-env-reify env)))))
+
+    ;;
+    ;; main
+    (record-case ghil
+      ((<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))
+              (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 loc (set! stack (cons (make-glil-source loc) 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))

module/language/tree-il/spec.scm

@@ -0,0 +1,52 @@
+;;; Tree Intermediate Language
+
+;; Copyright (C) 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 spec)
+  #:use-module (system base language)
+  #:use-module (language glil)
+  #:use-module (language tree-il)
+  #:use-module (language tree-il compile-glil)
+  #:export (tree-il))
+
+(define (write-tree-il exp . port)
+  (apply write (unparse-tree-il exp) port))
+
+(define (parse x)
+  (make-lambda #f '() '() (parse-tree-il x)))
+
+(define (join exps env)
+  (if (or-map (lambda (x)
+                (or (not (lambda? x))
+                    (not (null? (lambda-vars x)))))
+              exps)
+      (error "tree-il expressions to join must be thunks"))
+
+  (make-lambda #f '() '() (make-sequence #f (map lambda-body exps))))
+
+(define-language tree-il
+  #:title	"Tree Intermediate Language"
+  #:version	"1.0"
+  #:reader	read
+  #:printer	write-tree-il
+  #:parser      parse
+  #:joiner      join
+  #:compilers   `((glil . ,compile-glil))
+  )