summaryrefslogtreecommitdiff
path: root/module/analyzer/analyze.scm
diff options
context:
space:
mode:
authorNoah Lavine <noah.b.lavine@gmail.com>2011-12-25 16:47:46 -0500
committerNoah Lavine <noah.b.lavine@gmail.com>2011-12-25 16:47:46 -0500
commit34b76394643b4454ace2215206886f453bd1cb63 (patch)
tree6bd5b9faf697f181dccd19f8f4616a1d4ed899bb /module/analyzer/analyze.scm
parent79c6cf0eb0e0fdc406f9e860d5087f9978982499 (diff)
downloadguile-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.scm225
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?))