1 ;;; Effects analysis on CPS
3 ;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
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.
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.
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
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
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
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.
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
48 synthesize-definition-effects!
85 (define-syntax define-flags
88 ((_ all shift name ...)
89 (let ((count (length #'(name ...))))
90 (with-syntax (((n ...) (iota count))
93 (define-syntax name (identifier-syntax (ash 1 n)))
95 (define-syntax all (identifier-syntax (1- (ash 1 count))))
96 (define-syntax shift (identifier-syntax count)))))))))
98 (define-syntax define-enumeration
100 (define (count-bits n)
102 (if (< n (ash 1 (1- out)))
106 ((_ mask shift name ...)
107 (let* ((len (length #'(name ...)))
108 (bits (count-bits len)))
109 (with-syntax (((n ...) (iota len))
112 (define-syntax name (identifier-syntax n))
114 (define-syntax mask (identifier-syntax (1- (ash 1 bits))))
115 (define-syntax shift (identifier-syntax bits)))))))))
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.
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).
130 ;; Indicates that an expression may return a fresh object. The kind
131 ;; of object is indicated in the object kind field.
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".
140 ;; Indicates that an expression may cause a write to memory.
143 (define-enumeration &memory-kind-mask &memory-kind-bits
144 ;; Indicates than an expression may access unknown kinds of memory.
145 &unknown-memory-kinds
147 ;; Indicates that an expression depends on the value of a fluid
148 ;; variable, or on the current fluid environment.
151 ;; Indicates that an expression depends on the current prompt
155 ;; Indicates that an expression depends on the value of the car or cdr
159 ;; Indicates that an expression depends on the value of a vector
160 ;; field. The effect field indicates the specific field, or zero for
164 ;; Indicates that an expression depends on the value of a variable
168 ;; Indicates that an expression depends on the current module.
171 ;; Indicates that an expression depends on the value of a struct
172 ;; field. The effect field indicates the specific field, or zero for
176 ;; Indicates that an expression depends on the contents of a string.
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.
184 (define-inlinable (&field kind field)
185 (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
186 (define-inlinable (&object kind)
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)))
200 (define-syntax &no-effects (identifier-syntax 0))
201 (define-syntax &all-effects
203 (logior &all-effect-kinds (&object &unknown-memory-kinds))))
205 (define-inlinable (constant? effects)
208 (define-inlinable (causes-effect? x effects)
209 (not (zero? (logand x effects))))
211 (define-inlinable (causes-all-effects? x)
212 (eqv? x &all-effects))
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?)
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))))))
226 (and (not (zero? (logand a &write)))
227 (not (zero? (logand b (logior &read &write))))
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))))
235 (define-inlinable (indexed-field kind n dfg)
237 ((lookup-constant-index n dfg)
240 (else (&object kind))))
242 (define *primitive-effects* (make-hash-table))
244 (define-syntax-rule (define-primitive-effects* dfg
245 ((name . args) effects ...)
248 (hashq-set! *primitive-effects* 'name
250 ((dfg . args) (logior effects ...))
254 (define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
255 (define-primitive-effects* dfg ((name . args) effects ...) ...))
258 (define-primitive-effects
261 ;; Generic effect-free predicates.
262 (define-primitive-effects
280 (define-primitive-effects
281 ((fluid-ref f) (&read-object &fluid) &type-check)
282 ((fluid-set! f v) (&write-object &fluid) &type-check)
283 ((push-fluid f v) (&write-object &fluid) &type-check)
284 ((pop-fluid) (&write-object &fluid) &type-check))
287 (define-primitive-effects
288 ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
291 (define-primitive-effects
292 ((cons a b) (&allocate &pair))
293 ((list . _) (&allocate &pair))
294 ((car x) (&read-field &pair 0) &type-check)
295 ((set-car! x y) (&write-field &pair 0) &type-check)
296 ((cdr x) (&read-field &pair 1) &type-check)
297 ((set-cdr! x y) (&write-field &pair 1) &type-check)
298 ((memq x y) (&read-object &pair) &type-check)
299 ((memv x y) (&read-object &pair) &type-check)
300 ((list? arg) (&read-field &pair 1))
301 ((length l) (&read-field &pair 1) &type-check))
304 (define-primitive-effects
305 ((box v) (&allocate &box))
306 ((box-ref v) (&read-object &box) &type-check)
307 ((box-set! v x) (&write-object &box) &type-check))
310 (define (vector-field n dfg)
311 (indexed-field &vector n dfg))
312 (define (read-vector-field n dfg)
313 (logior &read (vector-field n dfg)))
314 (define (write-vector-field n dfg)
315 (logior &write (vector-field n dfg)))
316 (define-primitive-effects* dfg
317 ((vector . _) (&allocate &vector))
318 ((make-vector n init) (&allocate &vector) &type-check)
319 ((make-vector/immediate n init) (&allocate &vector))
320 ((vector-ref v n) (read-vector-field n dfg) &type-check)
321 ((vector-ref/immediate v n) (read-vector-field n dfg) &type-check)
322 ((vector-set! v n x) (write-vector-field n dfg) &type-check)
323 ((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check)
324 ((vector-length v) &type-check))
327 (define (struct-field n dfg)
328 (indexed-field &struct n dfg))
329 (define (read-struct-field n dfg)
330 (logior &read (struct-field n dfg)))
331 (define (write-struct-field n dfg)
332 (logior &write (struct-field n dfg)))
333 (define-primitive-effects* dfg
334 ((allocate-struct vt n) (&allocate &struct) &type-check)
335 ((allocate-struct/immediate v n) (&allocate &struct) &type-check)
336 ((make-struct vt ntail . _) (&allocate &struct) &type-check)
337 ((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
338 ((struct-ref s n) (read-struct-field n dfg) &type-check)
339 ((struct-ref/immediate s n) (read-struct-field n dfg) &type-check)
340 ((struct-set! s n x) (write-struct-field n dfg) &type-check)
341 ((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check)
342 ((struct-vtable s) &type-check))
345 (define-primitive-effects
346 ((string-ref s n) (&read-object &string) &type-check)
347 ((string-set! s n c) (&write-object &string) &type-check)
348 ((number->string _) (&allocate &string) &type-check)
349 ((string->number _) (&read-object &string) &type-check)
350 ((string-length s) &type-check))
353 (define-primitive-effects
354 ((bytevector-length _) &type-check)
356 ((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
357 ((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
358 ((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
359 ((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
360 ((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
361 ((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
362 ((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
363 ((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
364 ((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
365 ((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
367 ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
368 ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
369 ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
370 ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
371 ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
372 ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
373 ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
374 ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
375 ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
376 ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
379 (define-primitive-effects
380 ((current-module) (&read-object &module))
381 ((cache-current-module! m scope) (&write-object &box))
382 ((resolve name bound?) (&read-object &module) &type-check)
383 ((cached-toplevel-box scope name bound?) &type-check)
384 ((cached-module-box mod name public? bound?) &type-check)
385 ((define! name val) (&read-object &module) (&write-object &box)))
388 (define-primitive-effects
389 ((= . _) &type-check)
390 ((< . _) &type-check)
391 ((> . _) &type-check)
392 ((<= . _) &type-check)
393 ((>= . _) &type-check)
394 ((zero? . _) &type-check)
395 ((add . _) &type-check)
396 ((mul . _) &type-check)
397 ((sub . _) &type-check)
398 ((div . _) &type-check)
399 ((sub1 . _) &type-check)
400 ((add1 . _) &type-check)
401 ((quo . _) &type-check)
402 ((rem . _) &type-check)
403 ((mod . _) &type-check)
404 ((complex? _) &type-check)
405 ((real? _) &type-check)
406 ((rational? _) &type-check)
407 ((inf? _) &type-check)
408 ((nan? _) &type-check)
409 ((integer? _) &type-check)
410 ((exact? _) &type-check)
411 ((inexact? _) &type-check)
412 ((even? _) &type-check)
413 ((odd? _) &type-check)
414 ((ash n m) &type-check)
415 ((logand . _) &type-check)
416 ((logior . _) &type-check)
417 ((logxor . _) &type-check)
418 ((lognot . _) &type-check)
419 ((logtest a b) &type-check)
420 ((logbit? a b) &type-check)
421 ((sqrt _) &type-check)
422 ((abs _) &type-check))
425 (define-primitive-effects
426 ((char<? . _) &type-check)
427 ((char<=? . _) &type-check)
428 ((char>=? . _) &type-check)
429 ((char>? . _) &type-check)
430 ((integer->char _) &type-check)
431 ((char->integer _) &type-check))
433 (define (primitive-effects dfg name args)
434 (let ((proc (hashq-ref *primitive-effects* name)))
436 (apply proc dfg args)
439 (define (expression-effects exp dfg)
441 ((or ($ $void) ($ $const) ($ $prim) ($ $values))
444 (&allocate &unknown-memory-kinds))
446 (&write-object &prompt))
447 ((or ($ $call) ($ $callk))
450 (expression-effects exp dfg))
451 (($ $primcall name args)
452 (primitive-effects dfg name args))))
454 (define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
455 (label-count (dfg-label-count dfg)))
456 (let ((effects (make-vector label-count &no-effects)))
457 (define (idx->label idx) (+ idx min-label))
459 (when (< n label-count)
463 (match (lookup-cont (idx->label n) dfg)
464 (($ $kargs names syms body)
465 (expression-effects (find-expression body) dfg))
466 (($ $kreceive arity kargs)
468 (($ $arity _ () #f () #f) &type-check)
469 (($ $arity () () _ () #f) (&allocate &pair))
470 (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
471 (($ $kfun) &type-check)
472 (($ $kclause) &type-check)
473 (($ $ktail) &no-effects)))
477 ;; There is a way to abuse effects analysis in CSE to also do scalar
478 ;; replacement, effectively adding `car' and `cdr' expressions to `cons'
479 ;; expressions, and likewise with other constructors and setters. This
480 ;; routine adds appropriate effects to `cons' and `set-car!' and the
483 ;; This doesn't affect CSE's ability to eliminate expressions, given
484 ;; that allocations aren't eliminated anyway, and the new effects will
485 ;; just cause the allocations not to commute with e.g. set-car! which
486 ;; is what we want anyway.
487 (define* (synthesize-definition-effects! effects dfg min-label #:optional
488 (label-count (vector-length effects)))
489 (define (label->idx label) (- label min-label))
490 (let lp ((label min-label))
491 (when (< label (+ min-label label-count))
492 (let* ((lidx (label->idx label))
493 (fx (vector-ref effects lidx)))
494 (unless (zero? (logand (logior &write &allocation) fx))
495 (vector-set! effects lidx (logior (vector-ref effects lidx) &read)))