diff options
author | Noah Lavine <nlavine@haverford.edu> | 2011-12-12 23:15:12 -0500 |
---|---|---|
committer | Noah Lavine <nlavine@haverford.edu> | 2011-12-12 23:15:12 -0500 |
commit | de1d31b123aea757d14afb0266e87a47ee4c85f8 (patch) | |
tree | 3a60b1e1e66783249af11fb61f33343f248280ef | |
parent | 4f2b34ff640060ec7e75a922db110d7850b6c1c7 (diff) | |
download | guile-de1d31b123aea757d14afb0266e87a47ee4c85f8.tar.gz |
Initial Analyzer Work
* module/analyzer: create folder
* module/analyzer/value-sets.scm: a data structure for possible
values
* module/analyzer/set-queue.scm: a new type of queue
* module/analyzer/analyze.scm: the analyzer itself
-rw-r--r-- | module/analyzer/analyze.scm | 321 | ||||
-rw-r--r-- | module/analyzer/set-queue.scm | 38 | ||||
-rw-r--r-- | module/analyzer/value-sets.scm | 103 | ||||
-rw-r--r-- | test-suite/tests/analyzer.test | 43 |
4 files changed, 505 insertions, 0 deletions
diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm new file mode 100644 index 000000000..2e8c5989b --- /dev/null +++ b/module/analyzer/analyze.scm @@ -0,0 +1,321 @@ +(define-module (analyzer analyze) + #:use-module (analyzer value-sets) + #:use-module (analyzer set-queue) + #: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) + + #:export (go)) + +#| + +Our goal is to turn a collection of tree-il forms into a collection +of "tree-il instances", represented with the <annotated-tree-il> data +type. + +The annotated-tree-il contains the program structure (just like the +Tree-IL) and also whatever information we have been able to infer +about the program at that location. + +The current inference plan uses only one annotated-tree-il node for +every tree-il node. We create these nodes with the function +tree-il->annotated-tree-il and then walk the program, adding elements +to value-sets, stopping when we have nothing else to add, and hoping +to add very few elements. + +In the future, we might like to switch to a representation with more +than one annotated-tree-il node per tree-il node, so we can represent +situations where the same function is called with very different +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)) + +;; this returns a value-set for its tree's return value and a new +;; environment to replace entry-environment (in case it's a set form) +;; entry-environment should include an entry for all of the top-level +;; defines in the program, and any module defines that it will use. + +(define (make-environment) + '()) + +;; append some name-value pairs to an environment +;; environments match names to value-sets. +(define (environment-append-pairs env . args) + (if (null? args) + env + (let loop ((args args) + (frame '())) + (cond ((null? args) + (cons frame env)) + ((null? (cdr args)) + (error "environment-append-pairs" (car args))) + (else + (loop (cddr args) + (cons (cons (car args) (cadr args)) frame))))))) + +(define (environment-lookup env name) + (cond ((null? env) #f) + ((assq-ref (car env) name) + => (lambda (k) k)) + (else + (environment-lookup (cdr env) name)))) + +(define default-environment + `( (cons . ,(value-set-with-values 'cons)) + (car . ,(value-set-with-values 'car)) + (cdr . ,(value-set-with-values 'cdr)) + )) + +(define (primitive-lookup name) + (environment-lookup default-environment name)) + +(define-syntax-rule (push! list obj) + (set! list (cons list obj))) + +(define *values-need-inference* (make-set-queue)) + +;; 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 + ))) + (if parent + (set-queue-insert! *values-need-inference* parent)) + ret)) + (($ <const> src exp) + (let ((ret + (make-a-const src parent + #t ; can-return? + (value-set-with-values exp) ; return-value-set + exp + ))) + (if parent + (set-queue-insert! *values-need-inference* parent)) + ret)) + (($ <primitive-ref> src name) + (let ((ret + (make-a-primitive-ref src parent + #t ; can-return? + (primitive-lookup name) ; return-value-set + name))) + (if parent + (set-queue-insert! *values-need-inference* parent)) + ret)) + (($ <lexical-ref> src name gensym) + (make-a-lexical-ref src parent + #t ; can-return? + (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 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? + (value-set-nothing) ; 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 env)) + 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 *tree* '()) + +;; This function starts with the annotated tree-il nodes in +;; *values-need-inference* and infers as many value sets as it can, with +;; the following limitations: +;; - each tree node can only have one value set, and they do not +;; support logical implication +;; - it assumes that each function will return to its default +;; continuation (for now). +;; It uses *values-need-inference* as a queue. +(define (infer-value-sets!) + (emptying-set-queue! *values-need-inference* + (lambda (node) + (match node + (($ <a-call> src parent can-return? return-value-set + proc args) + (if (and (value-set-has-values? + (annotated-tree-il-return-value-set proc)) + (every (lambda (x) (value-set-has-values? + (annotated-tree-il-return-value-set x))) + args)) + (begin + )))) +))) + +(define (go sexp) + (set! *values-need-inference* (make-set-queue)) + (set! *tree* + (tree-il->annotated-tree-il! + (compile sexp #:to 'tree-il))) + (pretty-print *tree*)) + +#| + +This procedure attempts to annotate each expression in the tree-il +with the most specific value set that can describe that expression at +any point in this program. This is basically Hindley-Milner type +inference, except that it will catch enumerations. Note for myself +that there are two other choices of annotation style: + +- You might compute the most general type that a given procedure could +possibly accept. This is what you would do if you wanted to make a +compiled library version of a procedure with no specialization. But I +think that whole idea is wrong. + +- You might also compute the most specific types of every expression +at all points in the program, allowing duplication. This would let you +compile to the fastest possible code, and is what I hope to do later. + +|# diff --git a/module/analyzer/set-queue.scm b/module/analyzer/set-queue.scm new file mode 100644 index 000000000..89a6afa0c --- /dev/null +++ b/module/analyzer/set-queue.scm @@ -0,0 +1,38 @@ +(define-module (analyzer set-queue) + #:export (make-set-queue + set-queue-insert! + set-queue-remove! + set-queue-empty? + emptying-set-queue!)) + +;; The following are helper functions for using list-based set-queues: +;; queues where an element is only inserted if it is not already in +;; the queue. +(define (make-set-queue) + (cons '() '())) + +(define (set-queue-insert! sq elt) + (cond ((null? (car sq)) + (set-car! sq (list elt)) + (set-cdr! sq (car sq))) + ((memq elt (car sq))) + (else + (let ((new-pair (list elt))) + (set-cdr! (cdr sq) new-pair) + (set-cdr! sq new-pair))))) + +(define (set-queue-remove! sq) + (let ((res (car sq))) + (set-car! sq (cdr (car sq))) + (if (eq? (cdr sq) res) + (set-cdr! sq '())) + (car res))) + +(define (set-queue-empty? sq) + (null? (car sq))) + +(define (emptying-set-queue! sq func) + (if (not (set-queue-empty? sq)) + (let ((next (set-queue-remove! sq))) + (func next) + (emptying-set-queue! sq func)))) diff --git a/module/analyzer/value-sets.scm b/module/analyzer/value-sets.scm new file mode 100644 index 000000000..3c23d4be3 --- /dev/null +++ b/module/analyzer/value-sets.scm @@ -0,0 +1,103 @@ +(define-module (analyzer value-sets) + #:use-module (srfi srfi-9) + #:export (value-set value-set-type + make-value-set value-set? + value-set-values set-value-set-values! + value-set-properties set-value-set-properties! + + value-set-nothing value-set-anything + value-set-can-be-anything? value-set-has-values? + value-set-with-values + value-set-value-satisfying)) + +#| + + To keep things simple in the beginning, it's best to just have a few simple types and a few compound types. We attempt the following four simple types: + - booleans + - numbers (but no differentiation within numbers) + - strings + - symbols + and we use pairs as our only compound data type (this includes lists). + + We also need a small vocabulary of procedures. Here's one: + - not + - boolean? + - number? + - + + - string? + - symbol? + - eq? + +|# + + +(define-record-type value-set-type + #| a value set has two sorts of things: + - values is a list of individual Scheme values + - properties is a list of representations of sets of Scheme values, like + integers. the value-set describes the union of these two items + + properties is a list of possible descriptions. each description is a + list of primitive predicates that this value would satisfy. so + properties is like a propositional logic formula in disjunctive normal + form. + + |# + (value-set values properties) + value-set? + (values value-set-values set-value-set-values!) + (properties value-set-properties set-value-set-properties!)) + +; convenience constructors +(define (value-set-anything) + (value-set '() '((anything)))) +(define (value-set-nothing) + (value-set '() '())) +(define (value-set-with-values . vals) + (value-set vals '())) + +; and predicates +(define (value-set-has-values? vs) + (or (not (null? (value-set-values vs))) + (not (null? (value-set-properties vs))))) + +(define (value-set-can-be-anything? vs) + (let loop ((props (value-set-properties vs))) + (cond ((null? props) #f) + ((eq? (caar props) 'anything) #t) + (else (loop (cdr props)))))) + +; and a selector +(define (value-set-value-satisfying vs pred) + (let loop ((vals (value-set-values vs))) + (cond ((null? vals) #f) + ((pred (car vals)) (car vals)) + (else (loop (cdr vals)))))) + +(define-record-type primitive-procedure-type + ;; this type holds the value-set version of a primitive procedure + (primitive-procedure evaluator) + primitive-procedure? + (evaluator primitive-procedure-evaluator)) + +(define (vs-cons a b) + (values + (value-set (list (cons a b)) + '()) + '())) + +(define (vs-car p) + (if (value-set-can-be-anything? p) + (value-set-anything) + (let ((pair (value-set-value-satisfying p pair?))) + (if pair + (car pair) + (value-set-nothing))))) + +(define (vs-cdr p) + (if (value-set-can-be-anything? p) + (value-set-anything) + (let ((pair (value-set-value-satisfying p pair?))) + (if pair + (car pair) + (value-set-nothing))))) diff --git a/test-suite/tests/analyzer.test b/test-suite/tests/analyzer.test new file mode 100644 index 000000000..21bbaa3d0 --- /dev/null +++ b/test-suite/tests/analyzer.test @@ -0,0 +1,43 @@ +(use-modules (test-suite lib) + (analyzer set-queue)) + +;; test the set queue functions + +(define sq (make-set-queue)) + +(pass-if "set-queue-insert!" + (begin + (set-queue-insert! sq 1) + (set-queue-insert! sq 2) + (set-queue-insert! sq 3) + #t)) ;; pass if you get here without an exception + +(pass-if "set-queue-remove" + (equal? (set-queue-remove! sq) 1)) + +(pass-if "set-queue-remove" + (equal? (set-queue-remove! sq) 2)) + +(pass-if "set-queue-empty?" + (not (set-queue-empty? sq))) + +(pass-if "set-queue-remove" + (equal? (set-queue-remove! sq) 3)) + +(pass-if "set-queue-empty?" + (set-queue-empty? sq)) + +(pass-if "set-queue-insert!" + (begin + (set-queue-insert! sq 1) + (set-queue-insert! sq 2) + (set-queue-insert! sq 3) + + (set-queue-insert! sq 1) + #t)) + +(define lst '()) +(pass-if "emptying-set-queue" + (begin + (emptying-set-queue! sq (lambda (x) (set! lst (cons x lst)))) + (equal? lst '(3 2 1)))) |