and, or, cond etc use syntax-rules, compile scheme through tree-il

* libguile/vm-i-system.c:
* libguile/vm-engine.h (ASSERT_BOUND): New assertion, that a value is
  bound. Used by local-ref and external-ref in paranoid mode.

* module/ice-9/boot-9.scm (and, or, cond, case, do): Since we are
  switching to use psyntax as the first pass of the compiler, and perhaps
  soon of the interpreter too, we need to make sure it expands out all
  forms to primitive expressions. So define expanders for these derived
  syntax forms, as in the R5RS report.

* module/ice-9/psyntax-pp.scm: Regenerate, with core forms fully
  expanded.

* module/ice-9/psyntax.scm (build-void): New constructor, for making
  undefined values.
  (build-primref): Add in a hack so that primitive refs in the boot
  module expand out to toplevel refs, not module refs.
  (chi-void): Use build-void.
  (if): Define an expander for if that calls build-conditional.

* module/language/scheme/compile-tree-il.scm (compile-tree-il): Use let*
  so as not to depend on binding order for the result of
  (current-module).

* module/language/scheme/spec.scm (scheme): Switch over to tree-il as the
  primary intermediate language. Not yet fully tested, but at least it
  can compile psyntax-pp.scm.

* module/language/tree-il/analyze.scm (analyze-lexicals): Arguments don't
  count towards a function's nlocs.

* module/language/tree-il/compile-glil.scm (*comp-module*, compile-glil):
  Define a "compilation module" fluid.
  (flatten-lambda): Fix a call to make-glil-argument. Fix bug in
  heapifying arguments.
  (flatten): Fix number of arguments passed to apply instruction. Add a
  special case for `(values ...)'. If inlining primitive-refs fails,
  try expanding into toplevel-refs if the comp-module's variable is the
  same as the root variable.

* module/language/tree-il/optimize.scm (resolve-primitives!): Add missing
  src variable for <module-ref>.

* test-suite/tests/tree-il.test ("lambda"): Fix nlocs counts. Add a
  closure test case.

libguile/vm-engine.h

@@ -147,8 +147,12 @@
 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
 #define CHECK_IP() \
   do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#define ASSERT_BOUND(x) \
+  do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
+  } while (0)
 #else
 #define CHECK_IP()
+#define ASSERT_BOUND(x)
 #endif
 
 /* Get a local copy of the program's "object table" (i.e. the vector of

libguile/vm-i-system.c

@@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
 VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
 {
   PUSH (LOCAL_REF (FETCH ()));
+  ASSERT_BOUND (*sp);
   NEXT;
 }
 
@@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1)
     }
   CHECK_EXTERNAL(e);
   PUSH (SCM_CAR (e));
+  ASSERT_BOUND (*sp);
   NEXT;
 }
 

module/ice-9/boot-9.scm

@@ -210,6 +210,87 @@
 ;; module system has booted up.
 (define %pre-modules-transformer sc-expand)
 
+(define-syntax and
+  (syntax-rules ()
+    ((_) #t)
+    ((_ x) x)
+    ((_ x y ...) (if x (and y ...) #f))))
+
+(define-syntax or
+  (syntax-rules ()
+    ((_) #f)
+    ((_ x) x)
+    ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+
+(define-syntax cond
+  (syntax-rules (else =>)
+    ((cond (else result1 result2 ...))
+     (begin result1 result2 ...))
+    ((cond (test => result))
+     (let ((temp test))
+       (if temp (result temp))))
+    ((cond (test => result) clause1 clause2 ...)
+     (let ((temp test))
+       (if temp
+           (result temp)
+           (cond clause1 clause2 ...))))
+    ((cond (test)) test)
+    ((cond (test) clause1 clause2 ...)
+     (let ((temp test))
+       (if temp
+           temp
+           (cond clause1 clause2 ...))))
+    ((cond (test result1 result2 ...))
+     (if test (begin result1 result2 ...)))
+    ((cond (test result1 result2 ...)
+           clause1 clause2 ...)
+     (if test
+         (begin result1 result2 ...)
+         (cond clause1 clause2 ...)))))
+
+(define-syntax case
+  (syntax-rules (else)
+    ((case (key ...)
+       clauses ...)
+     (let ((atom-key (key ...)))
+       (case atom-key clauses ...)))
+    ((case key
+       (else result1 result2 ...))
+     (begin result1 result2 ...))
+    ((case key
+       ((atoms ...) result1 result2 ...))
+     (if (memv key '(atoms ...))
+         (begin result1 result2 ...)))
+    ((case key
+       ((atoms ...) result1 result2 ...)
+       clause clauses ...)
+     (if (memv key '(atoms ...))
+         (begin result1 result2 ...)
+         (case key clause clauses ...)))))
+
+(define-syntax do
+  (syntax-rules ()
+    ((do ((var init step ...) ...)
+         (test expr ...)
+         command ...)
+     (letrec
+       ((loop
+         (lambda (var ...)
+           (if test
+               (begin
+                 (if #f #f)
+                 expr ...)
+               (begin
+                 command
+                 ...
+                 (loop (do "step" var step ...)
+                       ...))))))
+       (loop init ...)))
+    ((do "step" x)
+     x)
+    ((do "step" x y)
+     y)))
+
 (define-syntax delay
   (syntax-rules ()
     ((_ exp) (make-promise (lambda () exp)))))

module/ice-9/psyntax.scm

@@ -351,6 +351,12 @@
 
 
 ;;; output constructors
+(define build-void
+  (lambda (source)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-void) source))
+      (else '(if #f #f)))))
+
 (define build-application
   (lambda (source fun-exp arg-exps)
     (case (fluid-ref *mode*)
@@ -444,10 +450,13 @@
 
 (define build-primref
   (lambda (src name)
-    (case (fluid-ref *mode*)
+    (if (equal? (module-name (current-module)) '(guile))
-      ((c) ((@ (language tree-il) make-primitive-ref) src name))
+        (case (fluid-ref *mode*)
-      ;; hygiene guile is a hack
+          ((c) ((@ (language tree-il) make-toplevel-ref) src name))
-      (else (build-global-reference src name '(hygiene guile))))))
+          (else name))
+        (case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
+          (else `(@@ (guile) ,name))))))
 
 (define (build-data src exp)
   (case (fluid-ref *mode*)
@@ -1483,7 +1492,7 @@
 
 (define chi-void
   (lambda ()
-    (build-application no-source (build-primref no-source 'if) '(#f #f))))
+    (build-void no-source)))
 
 (define ellipsis?
   (lambda (x)
@@ -1895,6 +1904,22 @@
                  (syntax->datum
                   (syntax (private mod ...))))))))
 
+(global-extend 'core 'if
+  (lambda (e r w s mod)
+    (syntax-case e ()
+      ((_ test then)
+       (build-conditional
+        s
+        (chi (syntax test) r w mod)
+        (chi (syntax then) r w mod)
+        (build-void no-source)))
+      ((_ test then else)
+       (build-conditional
+        s
+        (chi (syntax test) r w mod)
+        (chi (syntax then) r w mod)
+        (chi (syntax else) r w mod))))))
+
 (global-extend 'begin 'begin '())
 
 (global-extend 'define 'define '())

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

@@ -58,7 +58,7 @@
   (save-module-excursion
    (lambda ()
      (and=> (cenv-module e) set-current-module)
-     (let ((x (sc-expand x 'c '(compile load eval)))
+     (let* ((x (sc-expand x 'c '(compile load eval)))
-           (cenv (make-cenv (current-module)
+            (cenv (make-cenv (current-module)
-                            (cenv-lexicals e) (cenv-externals e))))
+                             (cenv-lexicals e) (cenv-externals e))))
        (values x cenv cenv)))))

module/language/scheme/spec.scm

@@ -47,8 +47,10 @@
   #:version	"0.5"
   #:reader	read
   #:read-file	read-file
-  #:compilers   `((ghil . ,compile-ghil)
+  #:compilers   `(
-                  (tree-il . ,compile-tree-il))
+                  (tree-il . ,compile-tree-il)
+                  (ghil . ,compile-ghil)
+                  )
   #:decompilers `((tree-il . ,decompile-tree-il))
   #:evaluator	(lambda (x module) (primitive-eval x))
   #:printer	write

module/language/tree-il/analyze.scm

@@ -144,7 +144,7 @@
          (let lp ((vars vars) (n 0))
            (if (null? vars)
                (hashq-set! allocation x
-                           (let ((nlocs (allocate! body (1+ level) n)))
+                           (let ((nlocs (- (allocate! body (1+ level) n) n)))
                              (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
                (let ((v (if (pair? vars) (car vars) vars)))
                  (let ((binder (hashq-ref heaps v)))

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

@@ -39,13 +39,17 @@
 ;;  sym -> (local . index) | (heap level . index)
 ;;  lambda -> (nlocs . nexts)
 
+(define *comp-module* (make-fluid))
+
 (define (compile-glil x e opts)
   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
          (x (optimize! x e opts))
          (allocation (analyze-lexicals x)))
-    (values (flatten-lambda x -1 allocation)
+    (with-fluid* *comp-module* (or (and e (car e)) (current-module))
-            (and e (cons (car e) (cddr e)))
+      (lambda ()
-            e)))
+        (values (flatten-lambda x -1 allocation)
+                (and e (cons (car e) (cddr e)))
+                e)))))
 
 
 
@@ -128,11 +132,11 @@
           ;; copy args to the heap if necessary
           (let lp ((in vars) (n 0))
             (if (not (null? in))
-                (let ((loc (hashq-ref allocation (car vars))))
+                (let ((loc (hashq-ref allocation (car in))))
                   (case (car loc)
                     ((heap)
-                     (emit-code (make-glil-argument 'ref n))
+                     (emit-code #f (make-glil-local 'ref n))
-                     (emit-code (make-glil-external 'set 0 (cddr loc)))))
+                     (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
                   (lp (cdr in) (1+ n)))))
 
           ;; and here, here, dear reader: we compile.
@@ -197,11 +201,21 @@
              (comp-push proc)
              (for-each comp-push args)
              (case context
-               ((drop) (emit-code src (make-glil-call 'apply (length args)))
+               ((drop) (emit-code src (make-glil-call 'apply (1+ (length args))))
                        (emit-code src (make-glil-call 'drop 1)))
-               ((tail) (emit-code src (make-glil-call 'goto/apply (length args))))
+               ((tail) (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
-               ((push) (emit-code src (make-glil-call 'apply (length args)))))))))
+               ((push) (emit-code src (make-glil-call 'apply (1+ (length args))))))))))
 
+        ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+              (not (eq? context 'push)))
+         ;; tail: (lambda () (values '(1 2)))
+         ;; drop: (lambda () (values '(1 2)) 3)
+         ;; push: (lambda () (list (values '(10 12)) 1))
+         (case context
+           ((drop) (for-each comp-drop args))
+           ((tail)
+            (for-each comp-push args)
+            (emit-code src (make-glil-call 'return/values (length args))))))
         ((and (primitive-ref? proc)
               (eq? (primitive-ref-name proc) '@call-with-values)
               (= (length args) 2))
@@ -277,12 +291,23 @@
              (emit-label L2))))
 
       ((<primitive-ref> src name)
-       (case context
+       (cond
-         ((push)
+        ((eq? (module-variable (fluid-ref *comp-module*) name)
-          (emit-code src (make-glil-module 'ref '(guile) name #f)))
+              (module-variable the-root-module name))
-         ((tail)
+         (case context
-          (emit-code src (make-glil-module 'ref '(guile) name #f))
+           ((push)
-          (emit-code #f (make-glil-call 'return 1)))))
+            (emit-code src (make-glil-toplevel 'ref name)))
+           ((tail)
+            (emit-code src (make-glil-toplevel 'ref name))
+            (emit-code #f (make-glil-call 'return 1)))))
+        (else
+         (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
+         (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)))))))
 
       ((<lexical-ref> src name gensym)
        (case context

module/language/tree-il/optimize.scm

@@ -78,7 +78,7 @@
         (and (hashq-ref *interesting-primitive-vars*
                         (module-variable mod name))
              (make-primitive-ref src name)))
-       ((<module-ref> mod name public?)
+       ((<module-ref> src mod name public?)
         ;; for the moment, we're disabling primitive resolution for
         ;; public refs because resolve-interface can raise errors.
         (let ((m (and (not public?) (resolve-module mod))))

test-suite/tests/tree-il.test

@@ -102,7 +102,7 @@
 (with-test-prefix "primitive-ref"
   (assert-tree-il->glil
    (primitive +)
-   (program 0 0 0 0 () (module private ref (guile) +) (call return 1)))
+   (program 0 0 0 0 () (toplevel ref +) (call return 1)))
 
   (assert-tree-il->glil
    (begin (primitive +) (const #f))
@@ -110,7 +110,7 @@
 
   (assert-tree-il->glil
    (apply (primitive null?) (primitive +))
-   (program 0 0 0 0 () (module private ref (guile) +) (call null? 1)
+   (program 0 0 0 0 () (toplevel ref +) (call null? 1)
             (call return 1))))
 
 (with-test-prefix "lexical refs"
@@ -309,7 +309,7 @@
   (assert-tree-il->glil
    (lambda (x) (y) () (const 2))
    (program 0 0 0 0 ()
-            (program 1 0 1 0 ()
+            (program 1 0 0 0 ()
                      (bind (x local 0))
                      (const 2) (call return 1))
             (call return 1)))
@@ -317,7 +317,7 @@
   (assert-tree-il->glil
    (lambda (x x1) (y y1) () (const 2))
    (program 0 0 0 0 ()
-            (program 2 0 2 0 ()
+            (program 2 0 0 0 ()
                      (bind (x local 0) (x1 local 1))
                      (const 2) (call return 1))
             (call return 1)))
@@ -325,7 +325,7 @@
   (assert-tree-il->glil
    (lambda x y () (const 2))
    (program 0 0 0 0 ()
-            (program 1 1 1 0 ()
+            (program 1 1 0 0 ()
                      (bind (x local 0))
                      (const 2) (call return 1))
             (call return 1)))
@@ -333,7 +333,7 @@
   (assert-tree-il->glil
    (lambda (x . x1) (y . y1) () (const 2))
    (program 0 0 0 0 ()
-            (program 2 1 2 0 ()
+            (program 2 1 0 0 ()
                      (bind (x local 0) (x1 local 1))
                      (const 2) (call return 1))
             (call return 1)))
@@ -341,7 +341,7 @@
   (assert-tree-il->glil
    (lambda (x . x1) (y . y1) () (lexical x y))
    (program 0 0 0 0 ()
-            (program 2 1 2 0 ()
+            (program 2 1 0 0 ()
                      (bind (x local 0) (x1 local 1))
                      (local ref 0) (call return 1))
             (call return 1)))
@@ -349,9 +349,21 @@
   (assert-tree-il->glil
    (lambda (x . x1) (y . y1) () (lexical x1 y1))
    (program 0 0 0 0 ()
-            (program 2 1 2 0 ()
+            (program 2 1 0 0 ()
                      (bind (x local 0) (x1 local 1))
                      (local ref 1) (call return 1))
+            (call return 1)))
+
+  (assert-tree-il->glil
+   (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
+   (program 0 0 0 0 ()
+            (program 1 0 0 1 ()
+                     (bind (x external 0))
+                     (local ref 0) (external set 0 0)
+                     (program 1 0 0 0 ()
+                              (bind (y local 0))
+                              (external ref 1 0) (call return 1))
+                     (call return 1))
             (call return 1))))
 
 (with-test-prefix "sequence"