diff options
author | Noah Lavine <noah.b.lavine@gmail.com> | 2011-12-25 16:47:46 -0500 |
---|---|---|
committer | Noah Lavine <noah.b.lavine@gmail.com> | 2011-12-25 16:47:46 -0500 |
commit | 34b76394643b4454ace2215206886f453bd1cb63 (patch) | |
tree | 6bd5b9faf697f181dccd19f8f4616a1d4ed899bb /module/analyzer/analyze.scm | |
parent | 79c6cf0eb0e0fdc406f9e860d5087f9978982499 (diff) | |
download | guile-wip-compiler.tar.gz |
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.
Diffstat (limited to 'module/analyzer/analyze.scm')
-rw-r--r-- | module/analyzer/analyze.scm | 225 |
1 files changed, 10 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?)) |