summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNoah Lavine <nlavine@haverford.edu>2011-12-12 23:15:12 -0500
committerNoah Lavine <nlavine@haverford.edu>2011-12-12 23:15:12 -0500
commitde1d31b123aea757d14afb0266e87a47ee4c85f8 (patch)
tree3a60b1e1e66783249af11fb61f33343f248280ef
parent4f2b34ff640060ec7e75a922db110d7850b6c1c7 (diff)
downloadguile-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.scm321
-rw-r--r--module/analyzer/set-queue.scm38
-rw-r--r--module/analyzer/value-sets.scm103
-rw-r--r--test-suite/tests/analyzer.test43
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))))