Commit | Line | Data |
---|---|---|
d20b4a1c AW |
1 | ;;; Effects analysis on CPS |
2 | ||
e2fafeb9 | 3 | ;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. |
d20b4a1c 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 | ;;; Commentary: | |
20 | ;;; | |
146c8e72 AW |
21 | ;;; A helper module to compute the set of effects caused by an |
22 | ;;; expression. This information is useful when writing algorithms that | |
23 | ;;; move code around, while preserving the semantics of an input | |
24 | ;;; program. | |
d20b4a1c | 25 | ;;; |
146c8e72 AW |
26 | ;;; The effects set is represented as an integer with three parts. The |
27 | ;;; low 4 bits indicate effects caused by an expression, as a bitfield. | |
28 | ;;; The next 4 bits indicate the kind of memory accessed by the | |
29 | ;;; expression, if it accesses mutable memory. Finally the rest of the | |
30 | ;;; bits indicate the field in the object being accessed, if known, or | |
31 | ;;; -1 for unknown. | |
d20b4a1c | 32 | ;;; |
146c8e72 AW |
33 | ;;; In this way we embed a coarse type-based alias analysis in the |
34 | ;;; effects analysis. For example, a "car" call is modelled as causing | |
35 | ;;; a read to field 0 on a &pair, and causing a &type-check effect. If | |
36 | ;;; any intervening code sets the car of any pair, that will block | |
37 | ;;; motion of the "car" call, because any write to field 0 of a pair is | |
38 | ;;; seen by effects analysis as being a write to field 0 of all pairs. | |
d20b4a1c AW |
39 | ;;; |
40 | ;;; Code: | |
41 | ||
42 | (define-module (language cps effects-analysis) | |
43 | #:use-module (language cps) | |
44 | #:use-module (language cps dfg) | |
45 | #:use-module (ice-9 match) | |
46 | #:export (expression-effects | |
47 | compute-effects | |
6119a905 | 48 | synthesize-definition-effects! |
d20b4a1c | 49 | |
5d25fdae AW |
50 | &allocation |
51 | &type-check | |
52 | &read | |
53 | &write | |
54 | ||
d20b4a1c AW |
55 | &fluid |
56 | &prompt | |
d20b4a1c AW |
57 | &car |
58 | &cdr | |
59 | &vector | |
60 | &box | |
61 | &module | |
62 | &struct | |
63 | &string | |
64 | &bytevector | |
5d25fdae AW |
65 | |
66 | &object | |
67 | &field | |
68 | ||
69 | &allocate | |
70 | &read-object | |
71 | &read-field | |
72 | &write-object | |
73 | &write-field | |
d20b4a1c AW |
74 | |
75 | &no-effects | |
76 | &all-effects | |
d20b4a1c | 77 | |
d20b4a1c AW |
78 | exclude-effects |
79 | effect-free? | |
80 | constant? | |
5d25fdae AW |
81 | causes-effect? |
82 | causes-all-effects? | |
83 | effect-clobbers?)) | |
d20b4a1c | 84 | |
5d25fdae | 85 | (define-syntax define-flags |
d20b4a1c AW |
86 | (lambda (x) |
87 | (syntax-case x () | |
5d25fdae AW |
88 | ((_ all shift name ...) |
89 | (let ((count (length #'(name ...)))) | |
90 | (with-syntax (((n ...) (iota count)) | |
91 | (count count)) | |
92 | #'(begin | |
93 | (define-syntax name (identifier-syntax (ash 1 n))) | |
94 | ... | |
95 | (define-syntax all (identifier-syntax (1- (ash 1 count)))) | |
96 | (define-syntax shift (identifier-syntax count))))))))) | |
97 | ||
e7f2fe1b AW |
98 | (define-syntax define-enumeration |
99 | (lambda (x) | |
100 | (define (count-bits n) | |
101 | (let lp ((out 1)) | |
102 | (if (< n (ash 1 (1- out))) | |
103 | out | |
104 | (lp (1+ out))))) | |
105 | (syntax-case x () | |
106 | ((_ mask shift name ...) | |
107 | (let* ((len (length #'(name ...))) | |
108 | (bits (count-bits len))) | |
109 | (with-syntax (((n ...) (iota len)) | |
110 | (bits bits)) | |
111 | #'(begin | |
112 | (define-syntax name (identifier-syntax n)) | |
113 | ... | |
114 | (define-syntax mask (identifier-syntax (1- (ash 1 bits)))) | |
115 | (define-syntax shift (identifier-syntax bits))))))))) | |
116 | ||
5d25fdae AW |
117 | (define-flags &all-effect-kinds &effect-kind-bits |
118 | ;; Indicates that an expression may cause a type check. A type check, | |
119 | ;; for the purposes of this analysis, is the possibility of throwing | |
120 | ;; an exception the first time an expression is evaluated. If the | |
121 | ;; expression did not cause an exception to be thrown, users can | |
122 | ;; assume that evaluating the expression again will not cause an | |
123 | ;; exception to be thrown. | |
124 | ;; | |
125 | ;; For example, (+ x y) might throw if X or Y are not numbers. But if | |
126 | ;; it doesn't throw, it should be safe to elide a dominated, common | |
127 | ;; subexpression (+ x y). | |
128 | &type-check | |
129 | ||
130 | ;; Indicates that an expression may return a fresh object. The kind | |
131 | ;; of object is indicated in the object kind field. | |
132 | &allocation | |
133 | ||
134 | ;; Indicates that an expression may cause a read from memory. The | |
135 | ;; kind of memory is given in the object kind field. Some object | |
136 | ;; kinds have finer-grained fields; those are expressed in the "field" | |
137 | ;; part of the effects value. -1 indicates "the whole object". | |
138 | &read | |
139 | ||
140 | ;; Indicates that an expression may cause a write to memory. | |
141 | &write) | |
142 | ||
e7f2fe1b AW |
143 | (define-enumeration &memory-kind-mask &memory-kind-bits |
144 | ;; Indicates than an expression may access unknown kinds of memory. | |
145 | &unknown-memory-kinds | |
146 | ||
5d25fdae AW |
147 | ;; Indicates that an expression depends on the value of a fluid |
148 | ;; variable, or on the current fluid environment. | |
149 | &fluid | |
150 | ||
151 | ;; Indicates that an expression depends on the current prompt | |
152 | ;; stack. | |
153 | &prompt | |
154 | ||
155 | ;; Indicates that an expression depends on the value of the car or cdr | |
156 | ;; of a pair. | |
157 | &pair | |
158 | ||
159 | ;; Indicates that an expression depends on the value of a vector | |
160 | ;; field. The effect field indicates the specific field, or zero for | |
161 | ;; an unknown field. | |
162 | &vector | |
163 | ||
164 | ;; Indicates that an expression depends on the value of a variable | |
165 | ;; cell. | |
166 | &box | |
167 | ||
168 | ;; Indicates that an expression depends on the current module. | |
169 | &module | |
170 | ||
171 | ;; Indicates that an expression depends on the value of a struct | |
172 | ;; field. The effect field indicates the specific field, or zero for | |
173 | ;; an unknown field. | |
174 | &struct | |
175 | ||
176 | ;; Indicates that an expression depends on the contents of a string. | |
177 | &string | |
178 | ||
179 | ;; Indicates that an expression depends on the contents of a | |
180 | ;; bytevector. We cannot be more precise, as bytevectors may alias | |
181 | ;; other bytevectors. | |
182 | &bytevector) | |
183 | ||
184 | (define-inlinable (&field kind field) | |
185 | (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits)) | |
186 | (define-inlinable (&object kind) | |
187 | (&field kind -1)) | |
188 | ||
189 | (define-inlinable (&allocate kind) | |
190 | (logior &allocation (&object kind))) | |
191 | (define-inlinable (&read-field kind field) | |
192 | (logior &read (&field kind field))) | |
193 | (define-inlinable (&read-object kind) | |
194 | (logior &read (&object kind))) | |
195 | (define-inlinable (&write-field kind field) | |
196 | (logior &write (&field kind field))) | |
197 | (define-inlinable (&write-object kind) | |
198 | (logior &write (&object kind))) | |
d20b4a1c AW |
199 | |
200 | (define-syntax &no-effects (identifier-syntax 0)) | |
5d25fdae AW |
201 | (define-syntax &all-effects |
202 | (identifier-syntax | |
e7f2fe1b | 203 | (logior &all-effect-kinds (&object &unknown-memory-kinds)))) |
d20b4a1c | 204 | |
cfb42b4c | 205 | (define-inlinable (constant? effects) |
d20b4a1c | 206 | (zero? effects)) |
d20b4a1c | 207 | |
5d25fdae AW |
208 | (define-inlinable (causes-effect? x effects) |
209 | (not (zero? (logand x effects)))) | |
210 | ||
211 | (define-inlinable (causes-all-effects? x) | |
212 | (eqv? x &all-effects)) | |
213 | ||
214 | (define (effect-clobbers? a b) | |
215 | "Return true if A clobbers B. This is the case if A is a write, and B | |
216 | is or might be a read or a write to the same location as A." | |
217 | (define (locations-same?) | |
e7f2fe1b AW |
218 | (let ((a (ash a (- &effect-kind-bits))) |
219 | (b (ash b (- &effect-kind-bits)))) | |
220 | (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask)) | |
221 | (eqv? &unknown-memory-kinds (logand b &memory-kind-mask)) | |
222 | (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask)) | |
223 | ;; A negative field indicates "the whole object". | |
224 | ;; Non-negative fields indicate only part of the object. | |
225 | (or (< a 0) (< b 0) (= a b)))))) | |
5d25fdae AW |
226 | (and (not (zero? (logand a &write))) |
227 | (not (zero? (logand b (logior &read &write)))) | |
228 | (locations-same?))) | |
d20b4a1c AW |
229 | |
230 | (define (lookup-constant-index sym dfg) | |
231 | (call-with-values (lambda () (find-constant-value sym dfg)) | |
232 | (lambda (has-const? val) | |
233 | (and has-const? (integer? val) (exact? val) (<= 0 val) val)))) | |
234 | ||
5d25fdae AW |
235 | (define-inlinable (indexed-field kind n dfg) |
236 | (cond | |
237 | ((lookup-constant-index n dfg) | |
238 | => (lambda (idx) | |
239 | (&field kind idx))) | |
240 | (else (&object kind)))) | |
241 | ||
d20b4a1c AW |
242 | (define *primitive-effects* (make-hash-table)) |
243 | ||
5d25fdae AW |
244 | (define-syntax-rule (define-primitive-effects* dfg |
245 | ((name . args) effects ...) | |
246 | ...) | |
d20b4a1c AW |
247 | (begin |
248 | (hashq-set! *primitive-effects* 'name | |
5d25fdae AW |
249 | (case-lambda* |
250 | ((dfg . args) (logior effects ...)) | |
251 | (_ &all-effects))) | |
d20b4a1c AW |
252 | ...)) |
253 | ||
5d25fdae AW |
254 | (define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...) |
255 | (define-primitive-effects* dfg ((name . args) effects ...) ...)) | |
d20b4a1c AW |
256 | |
257 | ;; Miscellaneous. | |
258 | (define-primitive-effects | |
ae67b159 | 259 | ((values . _))) |
d20b4a1c | 260 | |
5d25fdae | 261 | ;; Generic effect-free predicates. |
d20b4a1c | 262 | (define-primitive-effects |
5d25fdae AW |
263 | ((eq? . _)) |
264 | ((eqv? . _)) | |
265 | ((equal? . _)) | |
266 | ((pair? arg)) | |
267 | ((null? arg)) | |
268 | ((nil? arg )) | |
269 | ((symbol? arg)) | |
270 | ((variable? arg)) | |
271 | ((vector? arg)) | |
272 | ((struct? arg)) | |
273 | ((string? arg)) | |
274 | ((number? arg)) | |
275 | ((char? arg)) | |
e2fafeb9 AW |
276 | ((bytevector? arg)) |
277 | ((keyword? arg)) | |
278 | ((bitvector? arg)) | |
5d25fdae AW |
279 | ((procedure? arg)) |
280 | ((thunk? arg))) | |
d20b4a1c AW |
281 | |
282 | ;; Fluids. | |
283 | (define-primitive-effects | |
5d25fdae AW |
284 | ((fluid-ref f) (&read-object &fluid) &type-check) |
285 | ((fluid-set! f v) (&write-object &fluid) &type-check) | |
286 | ((push-fluid f v) (&write-object &fluid) &type-check) | |
287 | ((pop-fluid) (&write-object &fluid) &type-check)) | |
d20b4a1c AW |
288 | |
289 | ;; Prompts. | |
290 | (define-primitive-effects | |
e7f2fe1b | 291 | ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds))) |
d20b4a1c | 292 | |
d20b4a1c AW |
293 | ;; Pairs. |
294 | (define-primitive-effects | |
5d25fdae AW |
295 | ((cons a b) (&allocate &pair)) |
296 | ((list . _) (&allocate &pair)) | |
297 | ((car x) (&read-field &pair 0) &type-check) | |
298 | ((set-car! x y) (&write-field &pair 0) &type-check) | |
299 | ((cdr x) (&read-field &pair 1) &type-check) | |
300 | ((set-cdr! x y) (&write-field &pair 1) &type-check) | |
301 | ((memq x y) (&read-object &pair) &type-check) | |
302 | ((memv x y) (&read-object &pair) &type-check) | |
303 | ((list? arg) (&read-field &pair 1)) | |
304 | ((length l) (&read-field &pair 1) &type-check)) | |
d20b4a1c AW |
305 | |
306 | ;; Variables. | |
307 | (define-primitive-effects | |
5d25fdae AW |
308 | ((box v) (&allocate &box)) |
309 | ((box-ref v) (&read-object &box) &type-check) | |
310 | ((box-set! v x) (&write-object &box) &type-check)) | |
311 | ||
312 | ;; Vectors. | |
313 | (define (vector-field n dfg) | |
314 | (indexed-field &vector n dfg)) | |
315 | (define (read-vector-field n dfg) | |
316 | (logior &read (vector-field n dfg))) | |
317 | (define (write-vector-field n dfg) | |
318 | (logior &write (vector-field n dfg))) | |
319 | (define-primitive-effects* dfg | |
320 | ((vector . _) (&allocate &vector)) | |
321 | ((make-vector n init) (&allocate &vector) &type-check) | |
322 | ((make-vector/immediate n init) (&allocate &vector)) | |
323 | ((vector-ref v n) (read-vector-field n dfg) &type-check) | |
324 | ((vector-ref/immediate v n) (read-vector-field n dfg) &type-check) | |
325 | ((vector-set! v n x) (write-vector-field n dfg) &type-check) | |
326 | ((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check) | |
327 | ((vector-length v) &type-check)) | |
d20b4a1c AW |
328 | |
329 | ;; Structs. | |
5d25fdae AW |
330 | (define (struct-field n dfg) |
331 | (indexed-field &struct n dfg)) | |
332 | (define (read-struct-field n dfg) | |
333 | (logior &read (struct-field n dfg))) | |
334 | (define (write-struct-field n dfg) | |
335 | (logior &write (struct-field n dfg))) | |
d20b4a1c | 336 | (define-primitive-effects* dfg |
5d25fdae AW |
337 | ((allocate-struct vt n) (&allocate &struct) &type-check) |
338 | ((allocate-struct/immediate v n) (&allocate &struct) &type-check) | |
339 | ((make-struct vt ntail . _) (&allocate &struct) &type-check) | |
340 | ((make-struct/no-tail vt . _) (&allocate &struct) &type-check) | |
341 | ((struct-ref s n) (read-struct-field n dfg) &type-check) | |
342 | ((struct-ref/immediate s n) (read-struct-field n dfg) &type-check) | |
343 | ((struct-set! s n x) (write-struct-field n dfg) &type-check) | |
344 | ((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check) | |
345 | ((struct-vtable s) &type-check)) | |
d20b4a1c AW |
346 | |
347 | ;; Strings. | |
348 | (define-primitive-effects | |
5d25fdae AW |
349 | ((string-ref s n) (&read-object &string) &type-check) |
350 | ((string-set! s n c) (&write-object &string) &type-check) | |
351 | ((number->string _) (&allocate &string) &type-check) | |
352 | ((string->number _) (&read-object &string) &type-check) | |
353 | ((string-length s) &type-check)) | |
d20b4a1c AW |
354 | |
355 | ;; Bytevectors. | |
356 | (define-primitive-effects | |
5d25fdae AW |
357 | ((bytevector-length _) &type-check) |
358 | ||
359 | ((bv-u8-ref bv n) (&read-object &bytevector) &type-check) | |
360 | ((bv-s8-ref bv n) (&read-object &bytevector) &type-check) | |
361 | ((bv-u16-ref bv n) (&read-object &bytevector) &type-check) | |
362 | ((bv-s16-ref bv n) (&read-object &bytevector) &type-check) | |
363 | ((bv-u32-ref bv n) (&read-object &bytevector) &type-check) | |
364 | ((bv-s32-ref bv n) (&read-object &bytevector) &type-check) | |
365 | ((bv-u64-ref bv n) (&read-object &bytevector) &type-check) | |
366 | ((bv-s64-ref bv n) (&read-object &bytevector) &type-check) | |
367 | ((bv-f32-ref bv n) (&read-object &bytevector) &type-check) | |
368 | ((bv-f64-ref bv n) (&read-object &bytevector) &type-check) | |
369 | ||
370 | ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check) | |
371 | ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check) | |
372 | ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check) | |
373 | ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check) | |
374 | ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check) | |
375 | ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check) | |
376 | ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check) | |
377 | ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check) | |
378 | ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check) | |
379 | ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check)) | |
d20b4a1c | 380 | |
5d25fdae | 381 | ;; Modules. |
d20b4a1c | 382 | (define-primitive-effects |
5d25fdae AW |
383 | ((current-module) (&read-object &module)) |
384 | ((cache-current-module! m scope) (&write-object &box)) | |
385 | ((resolve name bound?) (&read-object &module) &type-check) | |
386 | ((cached-toplevel-box scope name bound?) &type-check) | |
387 | ((cached-module-box mod name public? bound?) &type-check) | |
388 | ((define! name val) (&read-object &module) (&write-object &box))) | |
d20b4a1c | 389 | |
5d25fdae | 390 | ;; Numbers. |
d20b4a1c | 391 | (define-primitive-effects |
5d25fdae AW |
392 | ((= . _) &type-check) |
393 | ((< . _) &type-check) | |
394 | ((> . _) &type-check) | |
395 | ((<= . _) &type-check) | |
396 | ((>= . _) &type-check) | |
397 | ((zero? . _) &type-check) | |
398 | ((add . _) &type-check) | |
399 | ((mul . _) &type-check) | |
400 | ((sub . _) &type-check) | |
401 | ((div . _) &type-check) | |
402 | ((sub1 . _) &type-check) | |
403 | ((add1 . _) &type-check) | |
404 | ((quo . _) &type-check) | |
405 | ((rem . _) &type-check) | |
406 | ((mod . _) &type-check) | |
407 | ((complex? _) &type-check) | |
408 | ((real? _) &type-check) | |
409 | ((rational? _) &type-check) | |
410 | ((inf? _) &type-check) | |
411 | ((nan? _) &type-check) | |
412 | ((integer? _) &type-check) | |
413 | ((exact? _) &type-check) | |
414 | ((inexact? _) &type-check) | |
415 | ((even? _) &type-check) | |
416 | ((odd? _) &type-check) | |
417 | ((ash n m) &type-check) | |
418 | ((logand . _) &type-check) | |
419 | ((logior . _) &type-check) | |
420 | ((logxor . _) &type-check) | |
421 | ((lognot . _) &type-check) | |
8006d2d6 AW |
422 | ((logtest a b) &type-check) |
423 | ((logbit? a b) &type-check) | |
5d25fdae AW |
424 | ((sqrt _) &type-check) |
425 | ((abs _) &type-check)) | |
d20b4a1c | 426 | |
5d25fdae | 427 | ;; Characters. |
d20b4a1c | 428 | (define-primitive-effects |
5d25fdae AW |
429 | ((char<? . _) &type-check) |
430 | ((char<=? . _) &type-check) | |
431 | ((char>=? . _) &type-check) | |
432 | ((char>? . _) &type-check) | |
433 | ((integer->char _) &type-check) | |
434 | ((char->integer _) &type-check)) | |
d20b4a1c AW |
435 | |
436 | (define (primitive-effects dfg name args) | |
437 | (let ((proc (hashq-ref *primitive-effects* name))) | |
438 | (if proc | |
439 | (apply proc dfg args) | |
5d25fdae | 440 | &all-effects))) |
d20b4a1c AW |
441 | |
442 | (define (expression-effects exp dfg) | |
443 | (match exp | |
a9ec16f9 | 444 | ((or ($ $const) ($ $prim) ($ $values)) |
d20b4a1c | 445 | &no-effects) |
34ff3af9 | 446 | ((or ($ $fun) ($ $rec)) |
e7f2fe1b | 447 | (&allocate &unknown-memory-kinds)) |
d20b4a1c | 448 | (($ $prompt) |
e7f2fe1b | 449 | (&write-object &prompt)) |
b3ae2b50 | 450 | ((or ($ $call) ($ $callk)) |
5d25fdae | 451 | &all-effects) |
92805e21 AW |
452 | (($ $branch k exp) |
453 | (expression-effects exp dfg)) | |
d20b4a1c AW |
454 | (($ $primcall name args) |
455 | (primitive-effects dfg name args)))) | |
456 | ||
3269e1b6 AW |
457 | (define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg)) |
458 | (label-count (dfg-label-count dfg))) | |
459 | (let ((effects (make-vector label-count &no-effects))) | |
460 | (define (idx->label idx) (+ idx min-label)) | |
d20b4a1c | 461 | (let lp ((n 0)) |
3269e1b6 | 462 | (when (< n label-count) |
d20b4a1c AW |
463 | (vector-set! |
464 | effects | |
465 | n | |
3269e1b6 | 466 | (match (lookup-cont (idx->label n) dfg) |
d20b4a1c AW |
467 | (($ $kargs names syms body) |
468 | (expression-effects (find-expression body) dfg)) | |
36527695 | 469 | (($ $kreceive arity kargs) |
d20b4a1c | 470 | (match arity |
5d25fdae AW |
471 | (($ $arity _ () #f () #f) &type-check) |
472 | (($ $arity () () _ () #f) (&allocate &pair)) | |
473 | (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) | |
5d25fdae AW |
474 | (($ $kfun) &type-check) |
475 | (($ $kclause) &type-check) | |
d20b4a1c AW |
476 | (($ $ktail) &no-effects))) |
477 | (lp (1+ n)))) | |
478 | effects)) | |
6119a905 AW |
479 | |
480 | ;; There is a way to abuse effects analysis in CSE to also do scalar | |
481 | ;; replacement, effectively adding `car' and `cdr' expressions to `cons' | |
482 | ;; expressions, and likewise with other constructors and setters. This | |
483 | ;; routine adds appropriate effects to `cons' and `set-car!' and the | |
484 | ;; like. | |
485 | ;; | |
486 | ;; This doesn't affect CSE's ability to eliminate expressions, given | |
487 | ;; that allocations aren't eliminated anyway, and the new effects will | |
488 | ;; just cause the allocations not to commute with e.g. set-car! which | |
489 | ;; is what we want anyway. | |
490 | (define* (synthesize-definition-effects! effects dfg min-label #:optional | |
491 | (label-count (vector-length effects))) | |
492 | (define (label->idx label) (- label min-label)) | |
493 | (let lp ((label min-label)) | |
494 | (when (< label (+ min-label label-count)) | |
495 | (let* ((lidx (label->idx label)) | |
496 | (fx (vector-ref effects lidx))) | |
5d25fdae AW |
497 | (unless (zero? (logand (logior &write &allocation) fx)) |
498 | (vector-set! effects lidx (logior (vector-ref effects lidx) &read))) | |
6119a905 | 499 | (lp (1+ label)))))) |