Commit | Line | Data |
---|---|---|
da9b2b71 AW |
1 | ;;; Effects analysis on Tree-IL |
2 | ||
19113f1c | 3 | ;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. |
da9b2b71 AW |
4 | |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | (define-module (language tree-il effects) | |
20 | #:use-module (language tree-il) | |
21 | #:use-module (language tree-il primitives) | |
22 | #:use-module (ice-9 match) | |
23 | #:export (make-effects-analyzer | |
24 | &mutable-lexical | |
25 | &toplevel | |
26 | &fluid | |
27 | &definite-bailout | |
28 | &possible-bailout | |
29 | &zero-values | |
30 | &allocation | |
31 | &mutable-data | |
32 | &type-check | |
33 | &all-effects | |
34 | effects-commute? | |
35 | exclude-effects | |
36 | effect-free? | |
37 | constant? | |
38 | depends-on-effects? | |
39 | causes-effects?)) | |
40 | ||
41 | ;;; | |
42 | ;;; Hey, it's some effects analysis! If you invoke | |
43 | ;;; `make-effects-analyzer', you get a procedure that computes the set | |
44 | ;;; of effects that an expression depends on and causes. This | |
45 | ;;; information is useful when writing algorithms that move code around, | |
46 | ;;; while preserving the semantics of an input program. | |
47 | ;;; | |
48 | ;;; The effects set is represented by a bitfield, as a fixnum. The set | |
49 | ;;; of possible effects is modelled rather coarsely. For example, a | |
50 | ;;; toplevel reference to FOO is modelled as depending on the &toplevel | |
51 | ;;; effect, and causing a &type-check effect. If any intervening code | |
52 | ;;; sets any toplevel variable, that will block motion of FOO. | |
53 | ;;; | |
54 | ;;; For each effect, two bits are reserved: one to indicate that an | |
55 | ;;; expression depends on the effect, and the other to indicate that an | |
56 | ;;; expression causes the effect. | |
57 | ;;; | |
58 | ||
59 | (define-syntax define-effects | |
60 | (lambda (x) | |
61 | (syntax-case x () | |
62 | ((_ all name ...) | |
63 | (with-syntax (((n ...) (iota (length #'(name ...))))) | |
64 | #'(begin | |
036c366d | 65 | (define-syntax name (identifier-syntax (ash 1 (* n 2)))) |
da9b2b71 | 66 | ... |
036c366d | 67 | (define-syntax all (identifier-syntax (logior name ...))))))))) |
da9b2b71 AW |
68 | |
69 | ;; Here we define the effects, indicating the meaning of the effect. | |
70 | ;; | |
71 | ;; Effects that are described in a "depends on" sense can also be used | |
72 | ;; in the "causes" sense. | |
73 | ;; | |
74 | ;; Effects that are described as causing an effect are not usually used | |
75 | ;; in a "depends-on" sense. Although the "depends-on" sense is used | |
76 | ;; when checking for the existence of the "causes" effect, the effects | |
77 | ;; analyzer will not associate the "depends-on" sense of these effects | |
78 | ;; with any expression. | |
79 | ;; | |
80 | (define-effects &all-effects | |
81 | ;; Indicates that an expression depends on the value of a mutable | |
82 | ;; lexical variable. | |
83 | &mutable-lexical | |
84 | ||
85 | ;; Indicates that an expression depends on the value of a toplevel | |
86 | ;; variable. | |
87 | &toplevel | |
88 | ||
89 | ;; Indicates that an expression depends on the value of a fluid | |
90 | ;; variable. | |
91 | &fluid | |
92 | ||
93 | ;; Indicates that an expression definitely causes a non-local, | |
94 | ;; non-resumable exit -- a bailout. Only used in the "changes" sense. | |
95 | &definite-bailout | |
96 | ||
97 | ;; Indicates that an expression may cause a bailout. | |
98 | &possible-bailout | |
99 | ||
100 | ;; Indicates than an expression may return zero values -- a "causes" | |
101 | ;; effect. | |
102 | &zero-values | |
103 | ||
104 | ;; Indicates that an expression may return a fresh object -- a | |
105 | ;; "causes" effect. | |
106 | &allocation | |
107 | ||
108 | ;; Indicates that an expression depends on the value of a mutable data | |
109 | ;; structure. | |
110 | &mutable-data | |
111 | ||
112 | ;; Indicates that an expression may cause a type check. A type check, | |
113 | ;; for the purposes of this analysis, is the possibility of throwing | |
114 | ;; an exception the first time an expression is evaluated. If the | |
115 | ;; expression did not cause an exception to be thrown, users can | |
116 | ;; assume that evaluating the expression again will not cause an | |
117 | ;; exception to be thrown. | |
118 | ;; | |
119 | ;; For example, (+ x y) might throw if X or Y are not numbers. But if | |
120 | ;; it doesn't throw, it should be safe to elide a dominated, common | |
121 | ;; subexpression (+ x y). | |
122 | &type-check) | |
123 | ||
036c366d | 124 | (define-syntax &no-effects (identifier-syntax 0)) |
da9b2b71 AW |
125 | |
126 | ;; Definite bailout is an oddball effect. Since it indicates that an | |
127 | ;; expression definitely causes bailout, it's not in the set of effects | |
128 | ;; of a call to an unknown procedure. At the same time, it's also | |
129 | ;; special in that a definite bailout in a subexpression doesn't always | |
130 | ;; cause an outer expression to include &definite-bailout in its | |
131 | ;; effects. For that reason we have to treat it specially. | |
132 | ;; | |
036c366d AW |
133 | (define-syntax &all-effects-but-bailout |
134 | (identifier-syntax | |
135 | (logand &all-effects (lognot &definite-bailout)))) | |
da9b2b71 | 136 | |
036c366d | 137 | (define-inlinable (cause effect) |
da9b2b71 AW |
138 | (ash effect 1)) |
139 | ||
036c366d | 140 | (define-inlinable (&depends-on a) |
da9b2b71 | 141 | (logand a &all-effects)) |
036c366d | 142 | (define-inlinable (&causes a) |
da9b2b71 AW |
143 | (logand a (cause &all-effects))) |
144 | ||
145 | (define (exclude-effects effects exclude) | |
146 | (logand effects (lognot (cause exclude)))) | |
147 | (define (effect-free? effects) | |
148 | (zero? (&causes effects))) | |
149 | (define (constant? effects) | |
150 | (zero? effects)) | |
151 | ||
036c366d | 152 | (define-inlinable (depends-on-effects? x effects) |
da9b2b71 | 153 | (not (zero? (logand (&depends-on x) effects)))) |
036c366d | 154 | (define-inlinable (causes-effects? x effects) |
da9b2b71 AW |
155 | (not (zero? (logand (&causes x) (cause effects))))) |
156 | ||
036c366d | 157 | (define-inlinable (effects-commute? a b) |
da9b2b71 AW |
158 | (and (not (causes-effects? a (&depends-on b))) |
159 | (not (causes-effects? b (&depends-on a))))) | |
160 | ||
161 | (define (make-effects-analyzer assigned-lexical?) | |
162 | "Returns a procedure of type EXP -> EFFECTS that analyzes the effects | |
163 | of an expression." | |
164 | ||
83bd53ab AW |
165 | (let ((cache (make-hash-table))) |
166 | (define* (compute-effects exp #:optional (lookup (lambda (x) #f))) | |
167 | (define (compute-effects exp) | |
da9b2b71 AW |
168 | (or (hashq-ref cache exp) |
169 | (let ((effects (visit exp))) | |
170 | (hashq-set! cache exp effects) | |
83bd53ab AW |
171 | effects))) |
172 | ||
173 | (define (accumulate-effects exps) | |
174 | (let lp ((exps exps) (out &no-effects)) | |
175 | (if (null? exps) | |
176 | out | |
177 | (lp (cdr exps) (logior out (compute-effects (car exps))))))) | |
178 | ||
179 | (define (visit exp) | |
180 | (match exp | |
181 | (($ <const>) | |
182 | &no-effects) | |
183 | (($ <void>) | |
184 | &no-effects) | |
185 | (($ <lexical-ref> _ _ gensym) | |
186 | (if (assigned-lexical? gensym) | |
187 | &mutable-lexical | |
188 | &no-effects)) | |
189 | (($ <lexical-set> _ name gensym exp) | |
190 | (logior (cause &mutable-lexical) | |
191 | (compute-effects exp))) | |
192 | (($ <let> _ names gensyms vals body) | |
193 | (logior (if (or-map assigned-lexical? gensyms) | |
194 | (cause &allocation) | |
195 | &no-effects) | |
196 | (accumulate-effects vals) | |
197 | (compute-effects body))) | |
198 | (($ <letrec> _ in-order? names gensyms vals body) | |
199 | (logior (if (or-map assigned-lexical? gensyms) | |
200 | (cause &allocation) | |
201 | &no-effects) | |
202 | (accumulate-effects vals) | |
203 | (compute-effects body))) | |
204 | (($ <fix> _ names gensyms vals body) | |
205 | (logior (if (or-map assigned-lexical? gensyms) | |
206 | (cause &allocation) | |
207 | &no-effects) | |
208 | (accumulate-effects vals) | |
209 | (compute-effects body))) | |
210 | (($ <let-values> _ producer consumer) | |
211 | (logior (compute-effects producer) | |
212 | (compute-effects consumer) | |
213 | (cause &type-check))) | |
83bd53ab AW |
214 | (($ <toplevel-ref>) |
215 | (logior &toplevel | |
216 | (cause &type-check))) | |
217 | (($ <module-ref>) | |
218 | (logior &toplevel | |
219 | (cause &type-check))) | |
220 | (($ <module-set> _ mod name public? exp) | |
221 | (logior (cause &toplevel) | |
222 | (cause &type-check) | |
223 | (compute-effects exp))) | |
224 | (($ <toplevel-define> _ name exp) | |
225 | (logior (cause &toplevel) | |
226 | (compute-effects exp))) | |
227 | (($ <toplevel-set> _ name exp) | |
228 | (logior (cause &toplevel) | |
229 | (compute-effects exp))) | |
230 | (($ <primitive-ref>) | |
231 | &no-effects) | |
232 | (($ <conditional> _ test consequent alternate) | |
233 | (let ((tfx (compute-effects test)) | |
234 | (cfx (compute-effects consequent)) | |
235 | (afx (compute-effects alternate))) | |
236 | (if (causes-effects? (logior tfx (logand afx cfx)) | |
237 | &definite-bailout) | |
238 | (logior tfx cfx afx) | |
239 | (exclude-effects (logior tfx cfx afx) | |
240 | &definite-bailout)))) | |
241 | ||
242 | ;; Zero values. | |
74bbb994 | 243 | (($ <primcall> _ 'values ()) |
83bd53ab AW |
244 | (cause &zero-values)) |
245 | ||
246 | ;; Effect-free primitives. | |
2aed2667 | 247 | (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args) |
37081d5d AW |
248 | (accumulate-effects args)) |
249 | ||
2aed2667 AW |
250 | (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol? |
251 | 'vector? 'struct? 'string? 'number? | |
252 | 'char?) | |
37081d5d AW |
253 | (arg)) |
254 | (compute-effects arg)) | |
255 | ||
256 | ;; Primitives that allocate memory. | |
2aed2667 | 257 | (($ <primcall> _ 'cons (x y)) |
37081d5d AW |
258 | (logior (compute-effects x) (compute-effects y) |
259 | &allocation)) | |
260 | ||
2aed2667 | 261 | (($ <primcall> _ (or 'list 'vector) args) |
37081d5d AW |
262 | (logior (accumulate-effects args) &allocation)) |
263 | ||
2aed2667 | 264 | (($ <primcall> _ 'make-prompt-tag ()) |
37081d5d AW |
265 | &allocation) |
266 | ||
2aed2667 | 267 | (($ <primcall> _ 'make-prompt-tag (arg)) |
37081d5d AW |
268 | (logior (compute-effects arg) &allocation)) |
269 | ||
86d0eb31 | 270 | (($ <primcall> _ 'fluid-ref (fluid)) |
5e0253f1 AW |
271 | (logior (compute-effects fluid) |
272 | (cause &type-check) | |
273 | &fluid)) | |
274 | ||
275 | (($ <primcall> _ 'fluid-set! (fluid exp)) | |
276 | (logior (compute-effects fluid) | |
277 | (compute-effects exp) | |
278 | (cause &type-check) | |
279 | (cause &fluid))) | |
86d0eb31 | 280 | |
c32b7c4c AW |
281 | (($ <primcall> _ 'push-fluid (fluid val)) |
282 | (logior (compute-effects fluid) | |
283 | (compute-effects val) | |
284 | (cause &type-check) | |
285 | (cause &fluid))) | |
286 | ||
287 | (($ <primcall> _ 'pop-fluid ()) | |
288 | (logior (cause &fluid))) | |
289 | ||
37081d5d AW |
290 | ;; Primitives that are normally effect-free, but which might |
291 | ;; cause type checks, allocate memory, or access mutable | |
292 | ;; memory. FIXME: expand, to be more precise. | |
74bbb994 | 293 | (($ <primcall> _ (and name (? effect-free-primitive?)) args) |
83bd53ab AW |
294 | (logior (accumulate-effects args) |
295 | (cause &type-check) | |
296 | (if (constructor-primitive? name) | |
297 | (cause &allocation) | |
298 | (if (accessor-primitive? name) | |
299 | &mutable-data | |
300 | &no-effects)))) | |
da9b2b71 | 301 | |
83bd53ab | 302 | ;; Lambda applications might throw wrong-number-of-args. |
74bbb994 | 303 | (($ <call> _ ($ <lambda> _ _ body) args) |
83bd53ab AW |
304 | (logior (accumulate-effects args) |
305 | (match body | |
306 | (($ <lambda-case> _ req #f #f #f () syms body #f) | |
307 | (logior (compute-effects body) | |
308 | (if (= (length req) (length args)) | |
309 | 0 | |
310 | (cause &type-check)))) | |
311 | (($ <lambda-case>) | |
312 | (logior (compute-effects body) | |
19113f1c AW |
313 | (cause &type-check))) |
314 | (#f | |
315 | ;; Calling a case-lambda with no clauses | |
316 | ;; definitely causes bailout. | |
317 | (logior (cause &definite-bailout) | |
318 | (cause &possible-bailout)))))) | |
da9b2b71 | 319 | |
83bd53ab | 320 | ;; Bailout primitives. |
74bbb994 | 321 | (($ <primcall> _ (? bailout-primitive? name) args) |
83bd53ab AW |
322 | (logior (accumulate-effects args) |
323 | (cause &definite-bailout) | |
324 | (cause &possible-bailout))) | |
325 | ||
326 | ;; A call to a lexically bound procedure, perhaps labels | |
327 | ;; allocated. | |
74bbb994 | 328 | (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args) |
83bd53ab AW |
329 | (cond |
330 | ((lookup sym) | |
331 | => (lambda (proc) | |
74bbb994 | 332 | (compute-effects (make-call #f proc args)))) |
83bd53ab AW |
333 | (else |
334 | (logior &all-effects-but-bailout | |
335 | (cause &all-effects-but-bailout))))) | |
336 | ||
337 | ;; A call to an unknown procedure can do anything. | |
74bbb994 AW |
338 | (($ <primcall> _ name args) |
339 | (logior &all-effects-but-bailout | |
340 | (cause &all-effects-but-bailout))) | |
341 | (($ <call> _ proc args) | |
83bd53ab AW |
342 | (logior &all-effects-but-bailout |
343 | (cause &all-effects-but-bailout))) | |
344 | ||
345 | (($ <lambda> _ meta body) | |
346 | &no-effects) | |
347 | (($ <lambda-case> _ req opt rest kw inits gensyms body alt) | |
348 | (logior (exclude-effects (accumulate-effects inits) | |
349 | &definite-bailout) | |
350 | (if (or-map assigned-lexical? gensyms) | |
351 | (cause &allocation) | |
352 | &no-effects) | |
353 | (compute-effects body) | |
354 | (if alt (compute-effects alt) &no-effects))) | |
355 | ||
74bbb994 AW |
356 | (($ <seq> _ head tail) |
357 | (logior | |
358 | ;; Returning zero values to a for-effect continuation is | |
359 | ;; not observable. | |
360 | (exclude-effects (compute-effects head) | |
361 | (cause &zero-values)) | |
362 | (compute-effects tail))) | |
83bd53ab | 363 | |
178a4092 | 364 | (($ <prompt> _ escape-only? tag body handler) |
83bd53ab AW |
365 | (logior (compute-effects tag) |
366 | (compute-effects body) | |
367 | (compute-effects handler))) | |
368 | ||
369 | (($ <abort> _ tag args tail) | |
370 | (logior &all-effects-but-bailout | |
371 | (cause &all-effects-but-bailout))))) | |
372 | ||
373 | (compute-effects exp)) | |
374 | ||
375 | compute-effects)) |