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 ( - #:common-slots (src parent can-return? return-value-set)) - ;; to do: add printer - - () - ( exp) - ( name) - ( name gensym) - ( target-value-set - name gensym exp) - ( mod name public?) - ( target-value-set - mod name public? exp) - ( name) - ( target-value-set - name exp) - ( name exp) - ( test consequent alternate) - ( proc args) - ( head tail) - ( meta body) - ( req opt rest kw inits gensyms body alternate) - ( names gensyms vals body) - ( in-order? names gensyms vals body) - ( fluids vals body) - ( fluid) - ( target-value-set fluid exp) - ( winder body unwinder) - ( tag body handler) - ( tag args tail) - ( names gensyms vals body) - ( exp body) - ( 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 - (($ src) - (let ((ret - (make-a-void src parent - #t ; can-return? - (value-set-nothing) ; return-value-set - ))) - (child-gained-value! parent) - ret)) - (($ 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)) - (($ 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)) - (($ 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)) - (($ 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)) - (($ src mod name public?) - (error "No module-ref yet!")) - (($ src mod name public? exp) - (error "No module-set yet!")) - (($ src name) - (make-a-toplevel-ref src parent - #t ; can-return? - (environment-lookup env name) ; return-value-set - name)) - (($ 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)) - (($ 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. - (($ 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)) - (($ src ($ 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)) - (($ 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)) - (($ src name args) - (error "No primcalls!")) - ;; To do: rewrite primcalls as (call (primitive-ref ...) ...) - (($ 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)) - (($ 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)) - (($ src req opt rest kw inits gensyms body alternate) - (error "No lambda-case right now!")) - (($ 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)) - (($ 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)) - (($ src fluids vals body) - (error "No dynlet yet!")) - (($ src fluid) - (error "No dynref yet!")) - (($ src fluid exp) - (error "No dynset yet!")) - (($ src winder body unwinder) - (error "No dynwind yet!")) - (($ src tag body handler) - (error "No prompt yet!")) - (($ src tag args tail) - (error "No abort yet!")) - (($ src names gensyms exp body) - (error "No let-values yet!")) - (($ 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? make-a-void + + a-const? make-a-const a-const-exp + + a-primitive-ref? a-primitive-ref-name + + a-lexical-ref? a-lexical-ref-name + a-lexical-ref-gensym + + 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-mod a-module-ref-name + a-module-ref-public? + + 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-name + + a-toplevel-set? a-toplevel-set-target-value-set + a-toplevel-set-name a-toplevel-set-exp + + a-toplevel-define? a-toplevel-define-name + a-toplevel-define-exp + + a-conditional? a-conditional-test + a-conditional-consequent a-conditional-alternate + + a-call? a-call-proc a-call-args + + a-seq? a-seq-head a-seq-tail + + a-lambda? a-lambda-meta a-lambda-body + + 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-names a-let-gensyms a-let-vals a-let-body + + a-letrec? a-letrec-in-order? a-letrec-names + a-letrec-gensyms a-letrec-vals a-letrec-body + + a-dynlet? a-dynlet-fluids a-dynlet-vals a-dynlet-body + + a-dynref? a-dynref-fluid + + a-dynset? a-dynset-target-value-set a-dynset-fluid + a-dynset-exp + + a-dynwind? a-dynwind-winter a-dynwind-body + a-dynwind-handler + + a-prompt? a-prompt-tag a-prompt-body a-prompt-handler + + a-abort? a-abort-tag a-abort-args a-abort-tail + + a-fix? a-fix-names a-fix-gensyms a-fix-vals a-fix-body + + a-let-values? a-let-values-exp a-let-values-body + + 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 ( + #:common-slots (src parent can-return? return-value-set)) + ;; to do: add printer + + () + ( exp) + ( name) + ( name gensym) + ( target-value-set + name gensym exp) + ( mod name public?) + ( target-value-set + mod name public? exp) + ( name) + ( target-value-set + name exp) + ( name exp) + ( test consequent alternate) + ( proc args) + ( head tail) + ( meta body) + ( req opt rest kw inits gensyms body alternate) + ( names gensyms vals body) + ( in-order? names gensyms vals body) + ( fluids vals body) + ( fluid) + ( target-value-set fluid exp) + ( winder body unwinder) + ( tag body handler) + ( tag args tail) + ( names gensyms vals body) + ( exp body) + ( 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 + (($ src) + (error "No voids yet!")) + (($ 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)) + (($ src name) + (error "No primitive-refs yet!")) + (($ 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)) + (($ src name gensym exp) + (error "No lexical sets yet!")) + (($ src mod name public?) + (error "No module-ref yet!")) + (($ src mod name public? exp) + (error "No module-set yet!")) + (($ src name) + (make-a-toplevel-ref src parent + #t ; can-return? + (environment-lookup env name) ; return-value-set + name)) + (($ src name exp) + (error "No toplevel sets yet!")) + (($ 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. + (($ src test consequent alternate) + (error "No conditionals yet!")) + (($ src ($ 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)) + (($ 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)) + (($ src name args) + (error "No primcalls!")) + ;; To do: rewrite primcalls as (call (primitive-ref ...) ...) + (($ src head tail) + (error "No seqs yet!")) + (($ src meta body) + (error "No lambdas yet!")) + (($ src req opt rest kw inits gensyms body alternate) + (error "No lambda-case right now!")) + (($ 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)) + (($ src in-order? names gensyms vals body) + (error "No letrecs yet!")) + (($ src fluids vals body) + (error "No dynlet yet!")) + (($ src fluid) + (error "No dynref yet!")) + (($ src fluid exp) + (error "No dynset yet!")) + (($ src winder body unwinder) + (error "No dynwind yet!")) + (($ src tag body handler) + (error "No prompt yet!")) + (($ src tag args tail) + (error "No abort yet!")) + (($ src names gensyms exp body) + (error "No let-values yet!")) + (($ src names gensyms vals body) + (error "No fix yet!")) +)))