mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

New annotated-tree-il Module

Browse source 
* 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.
This commit is contained in:
Noah Lavine 2011-12-25 16:47:46 -05:00
parent 79c6cf0eb0
commit 34b7639464
2 changed files with 244 additions and 215 deletions
Download patch file Download diff file Expand all files Collapse all files

225
module/analyzer/analyze.scm
View file

@ -2,12 +2,9 @@
#:use-module (analyzer value-sets) #:use-module (analyzer value-sets)
#:use-module (analyzer set-queue) #:use-module (analyzer set-queue)
#:use-module (analyzer lexical-envs) #:use-module (analyzer lexical-envs)
#:use-module (analyzer annotated-tree-il)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (language tree-il)
#:use-module (system base syntax)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (system base compile) #: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 (define default-environment
(environment-append-pairs (make-environment) (environment-append-pairs (make-environment)
(cons 'cons (value-set-with-values prim-cons)) (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) (define (primitive-lookup name)
(environment-lookup default-environment 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 *values-need-inference* (make-set-queue))
(define *verifies* '()) (define *verifies* '())
;; this procedure is called on a node whose child node gained a ;; 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 ;; value. it decides what to do about this. the parent can be #f, which
;; means the child is at the top level ;; 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)) (set-queue-insert! *values-need-inference* parent))
(else #t))) (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?) (define (all-verifies-pass?)
(let outer ((v *verifies*)) (let outer ((v *verifies*))
(if (null? v) (if (null? v)
@ -319,9 +108,15 @@ points to the value-set of this expression's return value.
(define (go sexp) (define (go sexp)
(set! *values-need-inference* (make-set-queue)) (set! *values-need-inference* (make-set-queue))
(set! *verifies* '()) (set! *verifies* '())
(set! *tree* (let ((verifies-box (make-variable '())))
(tree-il->annotated-tree-il! (set! *tree*
(compile sexp #:to 'tree-il))) (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!) (infer-value-sets!)
(all-verifies-pass?)) (all-verifies-pass?))

234
module/analyzer/annotated-tree-il.scm Normal file
View file

@ -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!"))
)))