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 | |
da9b2b71 AW |
31 | &type-check |
32 | &all-effects | |
33 | effects-commute? | |
34 | exclude-effects | |
35 | effect-free? | |
36 | constant? | |
37 | depends-on-effects? | |
38 | causes-effects?)) | |
39 | ||
40 | ;;; | |
41 | ;;; Hey, it's some effects analysis! If you invoke | |
42 | ;;; `make-effects-analyzer', you get a procedure that computes the set | |
43 | ;;; of effects that an expression depends on and causes. This | |
44 | ;;; information is useful when writing algorithms that move code around, | |
45 | ;;; while preserving the semantics of an input program. | |
46 | ;;; | |
47 | ;;; The effects set is represented by a bitfield, as a fixnum. The set | |
48 | ;;; of possible effects is modelled rather coarsely. For example, a | |
49 | ;;; toplevel reference to FOO is modelled as depending on the &toplevel | |
50 | ;;; effect, and causing a &type-check effect. If any intervening code | |
51 | ;;; sets any toplevel variable, that will block motion of FOO. | |
52 | ;;; | |
53 | ;;; For each effect, two bits are reserved: one to indicate that an | |
54 | ;;; expression depends on the effect, and the other to indicate that an | |
55 | ;;; expression causes the effect. | |
56 | ;;; | |
863dd873 AW |
57 | ;;; Since we have more bits in a fixnum on 64-bit systems, we can be |
58 | ;;; more precise without losing efficiency. On a 32-bit system, some of | |
59 | ;;; the more precise effects map to fewer bits. | |
60 | ;;; | |
da9b2b71 AW |
61 | |
62 | (define-syntax define-effects | |
63 | (lambda (x) | |
64 | (syntax-case x () | |
65 | ((_ all name ...) | |
66 | (with-syntax (((n ...) (iota (length #'(name ...))))) | |
67 | #'(begin | |
036c366d | 68 | (define-syntax name (identifier-syntax (ash 1 (* n 2)))) |
da9b2b71 | 69 | ... |
036c366d | 70 | (define-syntax all (identifier-syntax (logior name ...))))))))) |
da9b2b71 | 71 | |
863dd873 AW |
72 | (define-syntax compile-time-cond |
73 | (lambda (x) | |
74 | (syntax-case x (else) | |
75 | ((_ (else body ...)) | |
76 | #'(begin body ...)) | |
77 | ((_ (exp body ...) clause ...) | |
78 | (if (eval (syntax->datum #'exp) (current-module)) | |
79 | #'(begin body ...) | |
80 | #'(compile-time-cond clause ...)))))) | |
81 | ||
da9b2b71 AW |
82 | ;; Here we define the effects, indicating the meaning of the effect. |
83 | ;; | |
84 | ;; Effects that are described in a "depends on" sense can also be used | |
85 | ;; in the "causes" sense. | |
86 | ;; | |
87 | ;; Effects that are described as causing an effect are not usually used | |
88 | ;; in a "depends-on" sense. Although the "depends-on" sense is used | |
89 | ;; when checking for the existence of the "causes" effect, the effects | |
90 | ;; analyzer will not associate the "depends-on" sense of these effects | |
91 | ;; with any expression. | |
92 | ;; | |
863dd873 AW |
93 | (compile-time-cond |
94 | ((>= (logcount most-positive-fixnum) 60) | |
95 | (define-effects &all-effects | |
96 | ;; Indicates that an expression depends on the value of a mutable | |
97 | ;; lexical variable. | |
98 | &mutable-lexical | |
99 | ||
100 | ;; Indicates that an expression depends on the value of a toplevel | |
101 | ;; variable. | |
102 | &toplevel | |
103 | ||
104 | ;; Indicates that an expression depends on the value of a fluid | |
105 | ;; variable. | |
106 | &fluid | |
107 | ||
108 | ;; Indicates that an expression definitely causes a non-local, | |
109 | ;; non-resumable exit -- a bailout. Only used in the "changes" sense. | |
110 | &definite-bailout | |
111 | ||
112 | ;; Indicates that an expression may cause a bailout. | |
113 | &possible-bailout | |
114 | ||
115 | ;; Indicates than an expression may return zero values -- a "causes" | |
116 | ;; effect. | |
117 | &zero-values | |
118 | ||
119 | ;; Indicates that an expression may return a fresh object -- a | |
120 | ;; "causes" effect. | |
121 | &allocation | |
122 | ||
123 | ;; Indicates that an expression depends on the value of the car of a | |
124 | ;; pair. | |
125 | &car | |
126 | ||
127 | ;; Indicates that an expression depends on the value of the cdr of a | |
128 | ;; pair. | |
129 | &cdr | |
130 | ||
131 | ;; Indicates that an expression depends on the value of a vector | |
132 | ;; field. We cannot be more precise, as vectors may alias other | |
133 | ;; vectors. | |
134 | &vector | |
135 | ||
136 | ;; Indicates that an expression depends on the value of a variable | |
137 | ;; cell. | |
138 | &variable | |
139 | ||
140 | ;; Indicates that an expression depends on the value of a particular | |
141 | ;; struct field. | |
142 | &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+ | |
143 | ||
144 | ;; Indicates that an expression depends on the contents of a string. | |
145 | &string | |
146 | ||
147 | ;; Indicates that an expression depends on the contents of a | |
148 | ;; bytevector. We cannot be more precise, as bytevectors may alias | |
149 | ;; other bytevectors. | |
150 | &bytevector | |
151 | ||
152 | ;; Indicates that an expression may cause a type check. A type check, | |
153 | ;; for the purposes of this analysis, is the possibility of throwing | |
154 | ;; an exception the first time an expression is evaluated. If the | |
155 | ;; expression did not cause an exception to be thrown, users can | |
156 | ;; assume that evaluating the expression again will not cause an | |
157 | ;; exception to be thrown. | |
158 | ;; | |
159 | ;; For example, (+ x y) might throw if X or Y are not numbers. But if | |
160 | ;; it doesn't throw, it should be safe to elide a dominated, common | |
161 | ;; subexpression (+ x y). | |
162 | &type-check) | |
163 | ||
164 | ;; Indicates that an expression depends on the contents of an unknown | |
165 | ;; struct field. | |
166 | (define-syntax &struct | |
167 | (identifier-syntax | |
168 | (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+)))) | |
169 | ||
170 | (else | |
171 | ;; For systems with smaller fixnums, be less precise regarding struct | |
172 | ;; fields. | |
173 | (define-effects &all-effects | |
174 | &mutable-lexical | |
175 | &toplevel | |
176 | &fluid | |
177 | &definite-bailout | |
178 | &possible-bailout | |
179 | &zero-values | |
180 | &allocation | |
181 | &car | |
182 | &cdr | |
183 | &vector | |
184 | &variable | |
185 | &struct | |
186 | &string | |
187 | &bytevector | |
188 | &type-check) | |
189 | (define-syntax &struct-0 (identifier-syntax &struct)) | |
190 | (define-syntax &struct-1 (identifier-syntax &struct)) | |
191 | (define-syntax &struct-2 (identifier-syntax &struct)) | |
192 | (define-syntax &struct-3 (identifier-syntax &struct)) | |
193 | (define-syntax &struct-4 (identifier-syntax &struct)) | |
194 | (define-syntax &struct-5 (identifier-syntax &struct)) | |
195 | (define-syntax &struct-6+ (identifier-syntax &struct)))) | |
da9b2b71 | 196 | |
036c366d | 197 | (define-syntax &no-effects (identifier-syntax 0)) |
da9b2b71 AW |
198 | |
199 | ;; Definite bailout is an oddball effect. Since it indicates that an | |
200 | ;; expression definitely causes bailout, it's not in the set of effects | |
201 | ;; of a call to an unknown procedure. At the same time, it's also | |
202 | ;; special in that a definite bailout in a subexpression doesn't always | |
203 | ;; cause an outer expression to include &definite-bailout in its | |
204 | ;; effects. For that reason we have to treat it specially. | |
205 | ;; | |
036c366d AW |
206 | (define-syntax &all-effects-but-bailout |
207 | (identifier-syntax | |
208 | (logand &all-effects (lognot &definite-bailout)))) | |
da9b2b71 | 209 | |
036c366d | 210 | (define-inlinable (cause effect) |
da9b2b71 AW |
211 | (ash effect 1)) |
212 | ||
036c366d | 213 | (define-inlinable (&depends-on a) |
da9b2b71 | 214 | (logand a &all-effects)) |
036c366d | 215 | (define-inlinable (&causes a) |
da9b2b71 AW |
216 | (logand a (cause &all-effects))) |
217 | ||
218 | (define (exclude-effects effects exclude) | |
219 | (logand effects (lognot (cause exclude)))) | |
220 | (define (effect-free? effects) | |
221 | (zero? (&causes effects))) | |
222 | (define (constant? effects) | |
223 | (zero? effects)) | |
224 | ||
036c366d | 225 | (define-inlinable (depends-on-effects? x effects) |
da9b2b71 | 226 | (not (zero? (logand (&depends-on x) effects)))) |
036c366d | 227 | (define-inlinable (causes-effects? x effects) |
da9b2b71 AW |
228 | (not (zero? (logand (&causes x) (cause effects))))) |
229 | ||
036c366d | 230 | (define-inlinable (effects-commute? a b) |
da9b2b71 AW |
231 | (and (not (causes-effects? a (&depends-on b))) |
232 | (not (causes-effects? b (&depends-on a))))) | |
233 | ||
234 | (define (make-effects-analyzer assigned-lexical?) | |
235 | "Returns a procedure of type EXP -> EFFECTS that analyzes the effects | |
236 | of an expression." | |
237 | ||
83bd53ab AW |
238 | (let ((cache (make-hash-table))) |
239 | (define* (compute-effects exp #:optional (lookup (lambda (x) #f))) | |
240 | (define (compute-effects exp) | |
da9b2b71 AW |
241 | (or (hashq-ref cache exp) |
242 | (let ((effects (visit exp))) | |
243 | (hashq-set! cache exp effects) | |
83bd53ab AW |
244 | effects))) |
245 | ||
246 | (define (accumulate-effects exps) | |
247 | (let lp ((exps exps) (out &no-effects)) | |
248 | (if (null? exps) | |
249 | out | |
250 | (lp (cdr exps) (logior out (compute-effects (car exps))))))) | |
251 | ||
252 | (define (visit exp) | |
253 | (match exp | |
254 | (($ <const>) | |
255 | &no-effects) | |
256 | (($ <void>) | |
257 | &no-effects) | |
258 | (($ <lexical-ref> _ _ gensym) | |
259 | (if (assigned-lexical? gensym) | |
260 | &mutable-lexical | |
261 | &no-effects)) | |
262 | (($ <lexical-set> _ name gensym exp) | |
263 | (logior (cause &mutable-lexical) | |
264 | (compute-effects exp))) | |
265 | (($ <let> _ names gensyms vals body) | |
266 | (logior (if (or-map assigned-lexical? gensyms) | |
267 | (cause &allocation) | |
268 | &no-effects) | |
269 | (accumulate-effects vals) | |
270 | (compute-effects body))) | |
271 | (($ <letrec> _ in-order? names gensyms vals body) | |
272 | (logior (if (or-map assigned-lexical? gensyms) | |
273 | (cause &allocation) | |
274 | &no-effects) | |
275 | (accumulate-effects vals) | |
276 | (compute-effects body))) | |
277 | (($ <fix> _ names gensyms vals body) | |
278 | (logior (if (or-map assigned-lexical? gensyms) | |
279 | (cause &allocation) | |
280 | &no-effects) | |
281 | (accumulate-effects vals) | |
282 | (compute-effects body))) | |
283 | (($ <let-values> _ producer consumer) | |
284 | (logior (compute-effects producer) | |
285 | (compute-effects consumer) | |
286 | (cause &type-check))) | |
83bd53ab AW |
287 | (($ <toplevel-ref>) |
288 | (logior &toplevel | |
289 | (cause &type-check))) | |
290 | (($ <module-ref>) | |
291 | (logior &toplevel | |
292 | (cause &type-check))) | |
293 | (($ <module-set> _ mod name public? exp) | |
294 | (logior (cause &toplevel) | |
295 | (cause &type-check) | |
296 | (compute-effects exp))) | |
297 | (($ <toplevel-define> _ name exp) | |
298 | (logior (cause &toplevel) | |
299 | (compute-effects exp))) | |
300 | (($ <toplevel-set> _ name exp) | |
301 | (logior (cause &toplevel) | |
302 | (compute-effects exp))) | |
303 | (($ <primitive-ref>) | |
304 | &no-effects) | |
305 | (($ <conditional> _ test consequent alternate) | |
306 | (let ((tfx (compute-effects test)) | |
307 | (cfx (compute-effects consequent)) | |
308 | (afx (compute-effects alternate))) | |
309 | (if (causes-effects? (logior tfx (logand afx cfx)) | |
310 | &definite-bailout) | |
311 | (logior tfx cfx afx) | |
312 | (exclude-effects (logior tfx cfx afx) | |
313 | &definite-bailout)))) | |
314 | ||
315 | ;; Zero values. | |
74bbb994 | 316 | (($ <primcall> _ 'values ()) |
83bd53ab AW |
317 | (cause &zero-values)) |
318 | ||
319 | ;; Effect-free primitives. | |
2aed2667 | 320 | (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args) |
37081d5d AW |
321 | (accumulate-effects args)) |
322 | ||
2aed2667 AW |
323 | (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol? |
324 | 'vector? 'struct? 'string? 'number? | |
325 | 'char?) | |
37081d5d AW |
326 | (arg)) |
327 | (compute-effects arg)) | |
328 | ||
329 | ;; Primitives that allocate memory. | |
2aed2667 | 330 | (($ <primcall> _ 'cons (x y)) |
37081d5d AW |
331 | (logior (compute-effects x) (compute-effects y) |
332 | &allocation)) | |
333 | ||
2aed2667 | 334 | (($ <primcall> _ (or 'list 'vector) args) |
37081d5d AW |
335 | (logior (accumulate-effects args) &allocation)) |
336 | ||
2aed2667 | 337 | (($ <primcall> _ 'make-prompt-tag ()) |
37081d5d AW |
338 | &allocation) |
339 | ||
2aed2667 | 340 | (($ <primcall> _ 'make-prompt-tag (arg)) |
37081d5d AW |
341 | (logior (compute-effects arg) &allocation)) |
342 | ||
86d0eb31 | 343 | (($ <primcall> _ 'fluid-ref (fluid)) |
5e0253f1 AW |
344 | (logior (compute-effects fluid) |
345 | (cause &type-check) | |
346 | &fluid)) | |
347 | ||
348 | (($ <primcall> _ 'fluid-set! (fluid exp)) | |
349 | (logior (compute-effects fluid) | |
350 | (compute-effects exp) | |
351 | (cause &type-check) | |
352 | (cause &fluid))) | |
86d0eb31 | 353 | |
c32b7c4c AW |
354 | (($ <primcall> _ 'push-fluid (fluid val)) |
355 | (logior (compute-effects fluid) | |
356 | (compute-effects val) | |
357 | (cause &type-check) | |
358 | (cause &fluid))) | |
359 | ||
360 | (($ <primcall> _ 'pop-fluid ()) | |
361 | (logior (cause &fluid))) | |
362 | ||
863dd873 AW |
363 | (($ <primcall> _ 'car (x)) |
364 | (logior (compute-effects x) | |
365 | (cause &type-check) | |
366 | &car)) | |
367 | (($ <primcall> _ 'set-car! (x y)) | |
368 | (logior (compute-effects x) | |
369 | (compute-effects y) | |
370 | (cause &type-check) | |
371 | (cause &car))) | |
372 | ||
373 | (($ <primcall> _ 'cdr (x)) | |
374 | (logior (compute-effects x) | |
375 | (cause &type-check) | |
376 | &cdr)) | |
377 | (($ <primcall> _ 'set-cdr! (x y)) | |
378 | (logior (compute-effects x) | |
379 | (compute-effects y) | |
380 | (cause &type-check) | |
381 | (cause &cdr))) | |
382 | ||
383 | (($ <primcall> _ (or 'memq 'memv) (x y)) | |
384 | (logior (compute-effects x) | |
385 | (compute-effects y) | |
386 | (cause &type-check) | |
387 | &car &cdr)) | |
388 | ||
389 | (($ <primcall> _ 'vector-ref (v n)) | |
390 | (logior (compute-effects v) | |
391 | (compute-effects n) | |
392 | (cause &type-check) | |
393 | &vector)) | |
394 | (($ <primcall> _ 'vector-set! (v n x)) | |
395 | (logior (compute-effects v) | |
396 | (compute-effects n) | |
397 | (compute-effects x) | |
398 | (cause &type-check) | |
399 | (cause &vector))) | |
400 | ||
401 | (($ <primcall> _ 'variable-ref (v)) | |
402 | (logior (compute-effects v) | |
403 | (cause &type-check) | |
404 | &variable)) | |
405 | (($ <primcall> _ 'variable-set! (v x)) | |
406 | (logior (compute-effects v) | |
407 | (compute-effects x) | |
408 | (cause &type-check) | |
409 | (cause &variable))) | |
410 | ||
411 | (($ <primcall> _ 'struct-ref (s n)) | |
412 | (logior (compute-effects s) | |
413 | (compute-effects n) | |
414 | (cause &type-check) | |
415 | (match n | |
416 | (($ <const> _ 0) &struct-0) | |
417 | (($ <const> _ 1) &struct-1) | |
418 | (($ <const> _ 2) &struct-2) | |
419 | (($ <const> _ 3) &struct-3) | |
420 | (($ <const> _ 4) &struct-4) | |
421 | (($ <const> _ 5) &struct-5) | |
422 | (($ <const> _ _) &struct-6+) | |
423 | (_ &struct)))) | |
424 | (($ <primcall> _ 'struct-set! (s n x)) | |
425 | (logior (compute-effects s) | |
426 | (compute-effects n) | |
427 | (compute-effects x) | |
428 | (cause &type-check) | |
429 | (match n | |
430 | (($ <const> _ 0) (cause &struct-0)) | |
431 | (($ <const> _ 1) (cause &struct-1)) | |
432 | (($ <const> _ 2) (cause &struct-2)) | |
433 | (($ <const> _ 3) (cause &struct-3)) | |
434 | (($ <const> _ 4) (cause &struct-4)) | |
435 | (($ <const> _ 5) (cause &struct-5)) | |
436 | (($ <const> _ _) (cause &struct-6+)) | |
437 | (_ (cause &struct))))) | |
438 | ||
439 | (($ <primcall> _ 'string-ref (s n)) | |
440 | (logior (compute-effects s) | |
441 | (compute-effects n) | |
442 | (cause &type-check) | |
443 | &string)) | |
444 | (($ <primcall> _ 'string-set! (s n c)) | |
445 | (logior (compute-effects s) | |
446 | (compute-effects n) | |
447 | (compute-effects c) | |
448 | (cause &type-check) | |
449 | (cause &string))) | |
450 | ||
451 | (($ <primcall> _ | |
452 | (or 'bytevector-u8-ref 'bytevector-s8-ref | |
453 | 'bytevector-u16-ref 'bytevector-u16-native-ref | |
454 | 'bytevector-s16-ref 'bytevector-s16-native-ref | |
455 | 'bytevector-u32-ref 'bytevector-u32-native-ref | |
456 | 'bytevector-s32-ref 'bytevector-s32-native-ref | |
457 | 'bytevector-u64-ref 'bytevector-u64-native-ref | |
458 | 'bytevector-s64-ref 'bytevector-s64-native-ref | |
459 | 'bytevector-ieee-single-ref 'bytevector-ieee-single-native-ref | |
460 | 'bytevector-ieee-double-ref 'bytevector-ieee-double-native-ref) | |
461 | (bv n)) | |
462 | (logior (compute-effects bv) | |
463 | (compute-effects n) | |
464 | (cause &type-check) | |
465 | &bytevector)) | |
466 | (($ <primcall> _ | |
467 | (or 'bytevector-u8-set! 'bytevector-s8-set! | |
468 | 'bytevector-u16-set! 'bytevector-u16-native-set! | |
469 | 'bytevector-s16-set! 'bytevector-s16-native-set! | |
470 | 'bytevector-u32-set! 'bytevector-u32-native-set! | |
471 | 'bytevector-s32-set! 'bytevector-s32-native-set! | |
472 | 'bytevector-u64-set! 'bytevector-u64-native-set! | |
473 | 'bytevector-s64-set! 'bytevector-s64-native-set! | |
474 | 'bytevector-ieee-single-set! 'bytevector-ieee-single-native-set! | |
475 | 'bytevector-ieee-double-set! 'bytevector-ieee-double-native-set!) | |
476 | (bv n x)) | |
477 | (logior (compute-effects bv) | |
478 | (compute-effects n) | |
479 | (compute-effects x) | |
480 | (cause &type-check) | |
481 | (cause &bytevector))) | |
482 | ||
37081d5d | 483 | ;; Primitives that are normally effect-free, but which might |
863dd873 AW |
484 | ;; cause type checks or allocate memory. Nota bene, |
485 | ;; primitives that access mutable memory should be given their | |
486 | ;; own inline cases above! | |
74bbb994 | 487 | (($ <primcall> _ (and name (? effect-free-primitive?)) args) |
83bd53ab AW |
488 | (logior (accumulate-effects args) |
489 | (cause &type-check) | |
490 | (if (constructor-primitive? name) | |
491 | (cause &allocation) | |
863dd873 | 492 | &no-effects))) |
da9b2b71 | 493 | |
83bd53ab | 494 | ;; Lambda applications might throw wrong-number-of-args. |
74bbb994 | 495 | (($ <call> _ ($ <lambda> _ _ body) args) |
83bd53ab AW |
496 | (logior (accumulate-effects args) |
497 | (match body | |
498 | (($ <lambda-case> _ req #f #f #f () syms body #f) | |
499 | (logior (compute-effects body) | |
500 | (if (= (length req) (length args)) | |
501 | 0 | |
502 | (cause &type-check)))) | |
503 | (($ <lambda-case>) | |
504 | (logior (compute-effects body) | |
19113f1c AW |
505 | (cause &type-check))) |
506 | (#f | |
507 | ;; Calling a case-lambda with no clauses | |
508 | ;; definitely causes bailout. | |
509 | (logior (cause &definite-bailout) | |
510 | (cause &possible-bailout)))))) | |
da9b2b71 | 511 | |
83bd53ab | 512 | ;; Bailout primitives. |
74bbb994 | 513 | (($ <primcall> _ (? bailout-primitive? name) args) |
83bd53ab AW |
514 | (logior (accumulate-effects args) |
515 | (cause &definite-bailout) | |
516 | (cause &possible-bailout))) | |
a2972c19 AW |
517 | (($ <call> _ |
518 | (and proc | |
519 | ($ <module-ref> _ mod name public?) | |
520 | (? (lambda (_) | |
521 | (false-if-exception | |
522 | (procedure-property | |
523 | (module-ref (if public? | |
524 | (resolve-interface mod) | |
525 | (resolve-module mod)) | |
526 | name) | |
527 | 'definite-bailout?))))) | |
528 | args) | |
529 | (logior (compute-effects proc) | |
530 | (accumulate-effects args) | |
531 | (cause &definite-bailout) | |
532 | (cause &possible-bailout))) | |
83bd53ab AW |
533 | |
534 | ;; A call to a lexically bound procedure, perhaps labels | |
535 | ;; allocated. | |
74bbb994 | 536 | (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args) |
83bd53ab AW |
537 | (cond |
538 | ((lookup sym) | |
539 | => (lambda (proc) | |
74bbb994 | 540 | (compute-effects (make-call #f proc args)))) |
83bd53ab AW |
541 | (else |
542 | (logior &all-effects-but-bailout | |
543 | (cause &all-effects-but-bailout))))) | |
544 | ||
545 | ;; A call to an unknown procedure can do anything. | |
74bbb994 AW |
546 | (($ <primcall> _ name args) |
547 | (logior &all-effects-but-bailout | |
548 | (cause &all-effects-but-bailout))) | |
549 | (($ <call> _ proc args) | |
83bd53ab AW |
550 | (logior &all-effects-but-bailout |
551 | (cause &all-effects-but-bailout))) | |
552 | ||
553 | (($ <lambda> _ meta body) | |
554 | &no-effects) | |
555 | (($ <lambda-case> _ req opt rest kw inits gensyms body alt) | |
556 | (logior (exclude-effects (accumulate-effects inits) | |
557 | &definite-bailout) | |
558 | (if (or-map assigned-lexical? gensyms) | |
559 | (cause &allocation) | |
560 | &no-effects) | |
561 | (compute-effects body) | |
562 | (if alt (compute-effects alt) &no-effects))) | |
563 | ||
74bbb994 AW |
564 | (($ <seq> _ head tail) |
565 | (logior | |
566 | ;; Returning zero values to a for-effect continuation is | |
567 | ;; not observable. | |
568 | (exclude-effects (compute-effects head) | |
569 | (cause &zero-values)) | |
570 | (compute-effects tail))) | |
83bd53ab | 571 | |
178a4092 | 572 | (($ <prompt> _ escape-only? tag body handler) |
83bd53ab AW |
573 | (logior (compute-effects tag) |
574 | (compute-effects body) | |
575 | (compute-effects handler))) | |
576 | ||
577 | (($ <abort> _ tag args tail) | |
578 | (logior &all-effects-but-bailout | |
579 | (cause &all-effects-but-bailout))))) | |
580 | ||
581 | (compute-effects exp)) | |
582 | ||
583 | compute-effects)) |