New annotated-tree-il Modulewip-compiler

* module/analyzer/annotated-tree-il.scm: new module to hold
  functions that process annotated-tree-il but aren't central to
  the analyzer, like the conversion from tree-il.
* module/analyzer/analyze.scm: remove code that goes in the new
  module.

2 files changed, 244 insertions, 215 deletions

diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm
index b24742845..65fe2734c 100644
--- a/module/analyzer/analyze.scm
+++ b/module/analyzer/analyze.scm
@@ -2,12 +2,9 @@
   #:use-module (analyzer value-sets)
   #:use-module (analyzer set-queue)
   #:use-module (analyzer lexical-envs)
+  #:use-module (analyzer annotated-tree-il)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 receive)
-  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-1)
-  #:use-module (language tree-il)
-  #:use-module (system base syntax)
   #:use-module (ice-9 pretty-print)
   #:use-module (system base compile)
 
@@ -36,46 +33,6 @@ arguments.
 
 |#
 
-#|
-
-The src slot is the same as for regular tree-il. The value-set slot
-points to the value-set of this expression's return value.
-
-|#
-(define-type (<annotated-tree-il>
-              #:common-slots (src parent can-return? return-value-set))
-  ;; to do: add printer
-
-  (<a-void>)
-  (<a-const> exp)
-  (<a-primitive-ref> name)
-  (<a-lexical-ref> name gensym)
-  (<a-lexical-set> target-value-set
-                   name gensym exp)
-  (<a-module-ref> mod name public?)
-  (<a-module-set> target-value-set
-                  mod name public? exp)
-  (<a-toplevel-ref> name)
-  (<a-toplevel-set> target-value-set
-                    name exp)
-  (<a-toplevel-define> name exp)
-  (<a-conditional> test consequent alternate)
-  (<a-call> proc args)
-  (<a-seq> head tail)
-  (<a-lambda> meta body)
-  (<a-lambda-case> req opt rest kw inits gensyms body alternate)
-  (<a-let> names gensyms vals body)
-  (<a-letrec> in-order? names gensyms vals body)
-  (<a-dynlet> fluids vals body)
-  (<a-dynref> fluid)
-  (<a-dynset> target-value-set fluid exp)
-  (<a-dynwind> winder body unwinder)
-  (<a-prompt> tag body handler)
-  (<a-abort> tag args tail)
-  (<a-fix> names gensyms vals body)
-  (<a-let-values> exp body)
-  (<a-verify> exps))
-
 (define default-environment
   (environment-append-pairs (make-environment)
     (cons 'cons (value-set-with-values prim-cons))
@@ -85,14 +42,10 @@ points to the value-set of this expression's return value.
 (define (primitive-lookup name)
   (environment-lookup default-environment name))
 
-(define-syntax-rule (push! list obj)
-  (set! list (cons obj list)))
-
 (define *values-need-inference* (make-set-queue))
 
 (define *verifies* '())
 
-
 ;; this procedure is called on a node whose child node gained a
 ;; value. it decides what to do about this. the parent can be #f, which
 ;; means the child is at the top level
@@ -103,170 +56,6 @@ points to the value-set of this expression's return value.
           (set-queue-insert! *values-need-inference* parent))
          (else #t)))
 
-;; this procedure
-;; - converts tree-il to annotated tree-il.
-;; - annotates nodes with their parents.
-;; - annotates references and sets with the value-sets they use.
-;;   (it creates value-set objects, but doesn't do inference)
-;; - adds nodes to the *values-need-inference* set-queue
-(define (tree-il->annotated-tree-il! tree-il)
-  (let rec ((parent #f)
-            (tree tree-il)
-            (env default-environment))
-    (match tree
-           (($ <void> src)
-            (let ((ret 
-                   (make-a-void src parent
-                                #t ; can-return?
-                                (value-set-nothing) ; return-value-set
-                                )))
-              (child-gained-value! parent)
-              ret))
-           (($ <const> src exp)
-            (let ((ret
-                   (make-a-const src parent
-                                 #t ; can-return?
-                                 (value-set-with-values exp) ; return-value-set
-                                 exp
-                                 )))
-              (child-gained-value! parent)
-              ret))
-           (($ <primitive-ref> src name)
-            (let ((ret
-                   (make-a-primitive-ref src parent
-                                         #t ; can-return?
-                                         (primitive-lookup name) ; return-value-set
-                                         name)))
-              (child-gained-value! parent)
-              ret))
-           (($ <lexical-ref> src name gensym)
-            (make-a-lexical-ref src parent
-                                #t ; can-return?
-                                (annotated-tree-il-return-value-set
-                                 (environment-lookup env gensym)) ; return-value-set
-                                name gensym))
-           (($ <lexical-set> src name gensym exp)
-            (let ((ret (make-a-lexical-set src parent
-                                           #t ; can-return?
-                                           (value-set-nothing) ; return-value-set
-                                           (environment-lookup env gensym) ; target-value-set
-                                           name gensym
-                                           #f)))
-              (set! (a-lexical-set-exp) (rec ret exp env))
-              ret))
-           (($ <module-ref> src mod name public?)
-            (error "No module-ref yet!"))
-           (($ <module-set> src mod name public? exp)
-            (error "No module-set yet!"))
-           (($ <toplevel-ref> src name)
-            (make-a-toplevel-ref src parent
-                                 #t ; can-return?
-                                 (environment-lookup env name) ; return-value-set
-                                 name))
-           (($ <toplevel-set> src name exp)
-            (let ((ret (make-a-toplevel-set src parent
-                                            #t ; can-return?
-                                            (value-set-nothing) ; return-value-set
-                                            (environment-lookup env name) ; target-value-set
-                                            name
-                                            #f)))
-              (set! (a-toplevel-set-exp ret) (rec ret exp env))
-              ret))
-           (($ <toplevel-define> src name exp)
-            (error "No top level defines yet!"))
-           ;; don't need to put this in the *newly-set-value* list
-           ;; because it will be put there once the leaves in its
-           ;; definition have propagated a definition up to the top
-           ;; level. until that happens we don't know enough to infer
-           ;; anything interesting anyway.
-           (($ <conditional> src test consequent alternate)
-            (let ((ret (make-a-conditional src parent
-                                           #t ; can-return?
-                                           (value-set-nothing) ; return-value-set
-                                           #f #f #f)))
-              (set! (a-conditional-test ret) (rec ret test env))
-              (set! (a-conditional-consequent ret) (rec ret consequent env))
-              (set! (a-conditional-alternate ret) (rec ret alternate env))
-              ret))
-           (($ <call> src ($ <toplevel-ref> tsrc 'verify) args)
-            (let ((ret (make-a-verify src parent
-                                      #f ; can-return?
-                                      (value-set-nothing) ; return-value-se
-                                      '())))
-              (set! (a-verify-exps ret)
-                    (map (lambda (x) (rec ret x env)) args))
-              (push! *verifies* ret)
-              ret))
-           (($ <call> src proc args)
-            (let ((ret (make-a-call src parent
-                                    #t ; can-return?
-                                    (value-set-nothing) ; return-value-set
-                                    #f '())))
-              (set! (a-call-proc ret) (rec ret proc env))
-              (set! (a-call-args ret) (map (lambda (x) (rec ret x env)) args))
-              ret))
-           (($ <primcall> src name args)
-            (error "No primcalls!"))
-            ;; To do: rewrite primcalls as (call (primitive-ref ...) ...)
-           (($ <seq> src head tail)
-            (let ((ret (make-a-seq src parent
-                                   #t ; can-return?
-                                   (value-set-nothing) ; return-value-set
-                                   #f #f)))
-              (set! (a-seq-head ret) (rec ret head env))
-              (set! (a-seq-tail ret) (rec ret tail env))
-              ret))
-           (($ <lambda> src meta body)
-            (let ((ret (make-a-lambda src parent
-                                 #t ; can-return?
-                                 (value-set-nothing) ; return-value-set
-                                 meta '())))
-              (set! (a-lambda-body ret) (rec ret body env))
-              ret))
-           (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
-            (error "No lambda-case right now!"))
-           (($ <let> src names gensyms vals body)
-            (let ((ret (make-a-let src parent
-                                   #t ; can-return?
-                                   #f ; return-value-set
-                                   names gensyms
-                                   '() '())))
-              (set! (a-let-vals ret) (map (lambda (x) (rec ret x env)) vals))
-              (set! (a-let-body ret)
-                    (rec ret body
-                         (environment-append-names-values env
-                                                          gensyms
-                                                          (a-let-vals ret))))
-              (set! (annotated-tree-il-return-value-set ret)
-                    (annotated-tree-il-return-value-set (a-let-body ret)))
-              ret))
-           (($ <letrec> src in-order? names gensyms vals body)
-            (let ((ret (make-a-letrec src parent
-                                      #t ; can-return?
-                                      (value-set-nothing) ; return-value-set
-                                      in-order? names gensyms
-                                      '() '())))
-              (set! (a-letrec-vals ret) (map (lambda (x) (rec ret x env)) vals))
-              (set! (a-letrec-body ret) (rec ret body env))
-              ret))
-           (($ <dynlet> src fluids vals body)
-            (error "No dynlet yet!"))
-           (($ <dynref> src fluid)
-            (error "No dynref yet!"))
-           (($ <dynset> src fluid exp)
-            (error "No dynset yet!"))
-           (($ <dynwind> src winder body unwinder)
-            (error "No dynwind yet!"))
-           (($ <prompt> src tag body handler)
-            (error "No prompt yet!"))
-           (($ <abort> src tag args tail)
-            (error "No abort yet!"))
-           (($ <let-values> src names gensyms exp body)
-            (error "No let-values yet!"))
-           (($ <fix> src names gensyms vals body)
-            (error "No fix yet!"))
-)))
-
 (define (all-verifies-pass?)
   (let outer ((v *verifies*))
     (if (null? v)
@@ -319,9 +108,15 @@ points to the value-set of this expression's return value.
 (define (go sexp)
   (set! *values-need-inference* (make-set-queue))
   (set! *verifies* '())
-  (set! *tree*
-   (tree-il->annotated-tree-il!
-    (compile sexp #:to 'tree-il)))
+  (let ((verifies-box (make-variable '())))
+    (set! *tree*
+          (tree-il->annotated-tree-il!
+           (compile sexp #:to 'tree-il)
+           default-environment
+           verifies-box
+           (lambda (leaf) (child-gained-value!
+                      (annotated-tree-il-parent leaf)))))
+    (set! *verifies* (variable-ref verifies-box)))
   (infer-value-sets!)
   (all-verifies-pass?))
 
diff --git a/module/analyzer/annotated-tree-il.scm b/module/analyzer/annotated-tree-il.scm
new file mode 100644
index 000000000..a639586c2
--- /dev/null
+++ b/module/analyzer/annotated-tree-il.scm
@@ -0,0 +1,234 @@
+(define-module (analyzer annotated-tree-il)
+  #:use-module (analyzer value-sets)
+  #:use-module (analyzer set-queue)
+  #:use-module (analyzer lexical-envs)
+  #:use-module (ice-9 match)
+  #:use-module (system base syntax)
+  #:use-module (language tree-il)
+  #:export (annotated-tree-il-src
+            annotated-tree-il-parent
+            annotated-tree-il-can-return?
+            annotated-tree-il-return-value-set
+
+            <a-void> a-void? make-a-void
+            
+            <a-const> a-const? make-a-const a-const-exp
+            
+            <a-primitive-ref> a-primitive-ref? a-primitive-ref-name
+            
+            <a-lexical-ref> a-lexical-ref? a-lexical-ref-name
+            a-lexical-ref-gensym
+
+            <a-lexical-set> a-lexical-set? a-lexical-set-target-value-set
+            a-lexical-set-name a-lexical-set-gensym a-lexical-set-exp
+
+            <a-module-ref> a-module-ref? a-module-ref-mod a-module-ref-name
+            a-module-ref-public?
+
+            <a-module-set> a-module-set? a-module-set-target-value-set
+            a-module-set-mod a-module-set-name a-module-set-public?
+            a-module-set-exp
+
+            <a-toplevel-ref> a-toplevel-ref? a-toplevel-ref-name
+
+            <a-toplevel-set> a-toplevel-set? a-toplevel-set-target-value-set
+            a-toplevel-set-name a-toplevel-set-exp
+
+            <a-toplevel-define> a-toplevel-define? a-toplevel-define-name
+            a-toplevel-define-exp
+
+            <a-conditional> a-conditional? a-conditional-test
+            a-conditional-consequent a-conditional-alternate
+
+            <a-call> a-call? a-call-proc a-call-args
+
+            <a-seq> a-seq? a-seq-head a-seq-tail
+
+            <a-lambda> a-lambda? a-lambda-meta a-lambda-body
+
+            <a-lambda-case> a-lambda-case? a-lambda-case-req a-lambda-case-opt a-lambda-case-rest
+            a-lambda-case-kw a-lambda-case-inits a-lambda-case-gensyms a-lambda-case-body
+            a-lambda-case-alternate
+
+            <a-let> a-let? a-let-names a-let-gensyms a-let-vals a-let-body
+
+            <a-letrec> a-letrec? a-letrec-in-order? a-letrec-names
+            a-letrec-gensyms a-letrec-vals a-letrec-body
+
+            <a-dynlet> a-dynlet? a-dynlet-fluids a-dynlet-vals a-dynlet-body
+
+            <a-dynref> a-dynref? a-dynref-fluid
+
+            <a-dynset> a-dynset? a-dynset-target-value-set a-dynset-fluid
+            a-dynset-exp
+
+            <a-dynwind> a-dynwind? a-dynwind-winter a-dynwind-body
+            a-dynwind-handler
+
+            <a-prompt> a-prompt? a-prompt-tag a-prompt-body a-prompt-handler
+
+            <a-abort> a-abort? a-abort-tag a-abort-args a-abort-tail
+
+            <a-fix> a-fix? a-fix-names a-fix-gensyms a-fix-vals a-fix-body
+
+            <a-let-values> a-let-values? a-let-values-exp a-let-values-body
+
+            <a-verify> a-verify? a-verify-exps
+
+            tree-il->annotated-tree-il!))
+
+#|
+
+The src slot is the same as for regular tree-il. The value-set slot
+points to the value-set of this expression's return value.
+
+|#
+(define-type (<annotated-tree-il>
+              #:common-slots (src parent can-return? return-value-set))
+  ;; to do: add printer
+
+  (<a-void>)
+  (<a-const> exp)
+  (<a-primitive-ref> name)
+  (<a-lexical-ref> name gensym)
+  (<a-lexical-set> target-value-set
+                   name gensym exp)
+  (<a-module-ref> mod name public?)
+  (<a-module-set> target-value-set
+                  mod name public? exp)
+  (<a-toplevel-ref> name)
+  (<a-toplevel-set> target-value-set
+                    name exp)
+  (<a-toplevel-define> name exp)
+  (<a-conditional> test consequent alternate)
+  (<a-call> proc args)
+  (<a-seq> head tail)
+  (<a-lambda> meta body)
+  (<a-lambda-case> req opt rest kw inits gensyms body alternate)
+  (<a-let> names gensyms vals body)
+  (<a-letrec> in-order? names gensyms vals body)
+  (<a-dynlet> fluids vals body)
+  (<a-dynref> fluid)
+  (<a-dynset> target-value-set fluid exp)
+  (<a-dynwind> winder body unwinder)
+  (<a-prompt> tag body handler)
+  (<a-abort> tag args tail)
+  (<a-fix> names gensyms vals body)
+  (<a-let-values> exp body)
+  (<a-verify> exps))
+
+;; this procedure
+;; - converts tree-il to annotated tree-il.
+;; - annotates nodes with their parents.
+;; - annotates references and sets with the value-sets they use.
+;;   (it creates value-set objects, but doesn't do inference)
+;; - adds verify nodes to verifies, a variable object holding a list
+;; - calls leaf-func on nodes that already have values (const nodes),
+;;   after annotated with parents and value sets
+(define (tree-il->annotated-tree-il! tree-il toplevel-env verifies leaf-func)
+  (let rec ((parent #f)
+            (tree tree-il)
+            (env toplevel-env))
+    (match tree
+           (($ <void> src)
+            (error "No voids yet!"))
+           (($ <const> src exp)
+            (let ((ret
+                   (make-a-const src parent
+                                 #t ; can-return?
+                                 (value-set-with-values exp) ; return-value-set
+                                 exp
+                                 )))
+              (leaf-func ret)
+              ret))
+           (($ <primitive-ref> src name)
+            (error "No primitive-refs yet!"))
+           (($ <lexical-ref> src name gensym)
+            (make-a-lexical-ref src parent
+                                #t ; can-return?
+                                (annotated-tree-il-return-value-set
+                                 (environment-lookup env gensym)) ; return-value-set
+                                name gensym))
+           (($ <lexical-set> src name gensym exp)
+            (error "No lexical sets yet!"))
+           (($ <module-ref> src mod name public?)
+            (error "No module-ref yet!"))
+           (($ <module-set> src mod name public? exp)
+            (error "No module-set yet!"))
+           (($ <toplevel-ref> src name)
+            (make-a-toplevel-ref src parent
+                                 #t ; can-return?
+                                 (environment-lookup env name) ; return-value-set
+                                 name))
+           (($ <toplevel-set> src name exp)
+            (error "No toplevel sets yet!"))
+           (($ <toplevel-define> src name exp)
+            (error "No top level defines yet!"))
+           ;; don't need to put this in the *newly-set-value* list
+           ;; because it will be put there once the leaves in its
+           ;; definition have propagated a definition up to the top
+           ;; level. until that happens we don't know enough to infer
+           ;; anything interesting anyway.
+           (($ <conditional> src test consequent alternate)
+            (error "No conditionals yet!"))
+           (($ <call> src ($ <toplevel-ref> tsrc 'verify) args)
+            (let ((ret (make-a-verify src parent
+                                      #f ; can-return?
+                                      (value-set-nothing) ; return-value-se
+                                      '())))
+              (set! (a-verify-exps ret)
+                    (map (lambda (x) (rec ret x env)) args))
+              (variable-set! verifies
+                             (cons ret (variable-ref verifies)))
+              ret))
+           (($ <call> src proc args)
+            (let ((ret (make-a-call src parent
+                                    #t ; can-return?
+                                    (value-set-nothing) ; return-value-set
+                                    #f '())))
+              (set! (a-call-proc ret) (rec ret proc env))
+              (set! (a-call-args ret) (map (lambda (x) (rec ret x env)) args))
+              ret))
+           (($ <primcall> src name args)
+            (error "No primcalls!"))
+            ;; To do: rewrite primcalls as (call (primitive-ref ...) ...)
+           (($ <seq> src head tail)
+            (error "No seqs yet!"))
+           (($ <lambda> src meta body)
+            (error "No lambdas yet!"))
+           (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+            (error "No lambda-case right now!"))
+           (($ <let> src names gensyms vals body)
+            (let ((ret (make-a-let src parent
+                                   #t ; can-return?
+                                   #f ; return-value-set
+                                   names gensyms
+                                   '() '())))
+              (set! (a-let-vals ret) (map (lambda (x) (rec ret x env)) vals))
+              (set! (a-let-body ret)
+                    (rec ret body
+                         (environment-append-names-values env
+                                                          gensyms
+                                                          (a-let-vals ret))))
+              (set! (annotated-tree-il-return-value-set ret)
+                    (annotated-tree-il-return-value-set (a-let-body ret)))
+              ret))
+           (($ <letrec> src in-order? names gensyms vals body)
+            (error "No letrecs yet!"))
+           (($ <dynlet> src fluids vals body)
+            (error "No dynlet yet!"))
+           (($ <dynref> src fluid)
+            (error "No dynref yet!"))
+           (($ <dynset> src fluid exp)
+            (error "No dynset yet!"))
+           (($ <dynwind> src winder body unwinder)
+            (error "No dynwind yet!"))
+           (($ <prompt> src tag body handler)
+            (error "No prompt yet!"))
+           (($ <abort> src tag args tail)
+            (error "No abort yet!"))
+           (($ <let-values> src names gensyms exp body)
+            (error "No let-values yet!"))
+           (($ <fix> src names gensyms vals body)
+            (error "No fix yet!"))
+)))