summaryrefslogtreecommitdiff
path: root/module/analyzer/annotated-tree-il.scm
blob: a639586c2198e31780ab3584caabdd199f85892c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
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!"))
)))