1 ;;; Effects analysis on Tree-IL
3 ;; Copyright (C) 2011, 2012, 2013 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
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
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.
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.
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.
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.
62 (define-syntax define-effects
66 (with-syntax (((n ...) (iota (length #'(name ...)))))
68 (define-syntax name (identifier-syntax (ash 1 (* n 2))))
70 (define-syntax all (identifier-syntax (logior name ...)))))))))
72 (define-syntax compile-time-cond
77 ((_ (exp body ...) clause ...)
78 (if (eval (syntax->datum #'exp) (current-module))
80 #'(compile-time-cond clause ...))))))
82 ;; Here we define the effects, indicating the meaning of the effect.
84 ;; Effects that are described in a "depends on" sense can also be used
85 ;; in the "causes" sense.
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.
94 ((>= (logcount most-positive-fixnum) 60)
95 (define-effects &all-effects
96 ;; Indicates that an expression depends on the value of a mutable
100 ;; Indicates that an expression depends on the value of a toplevel
104 ;; Indicates that an expression depends on the value of a fluid
108 ;; Indicates that an expression definitely causes a non-local,
109 ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
112 ;; Indicates that an expression may cause a bailout.
115 ;; Indicates than an expression may return zero values -- a "causes"
119 ;; Indicates that an expression may return a fresh object -- a
123 ;; Indicates that an expression depends on the value of the car of a
127 ;; Indicates that an expression depends on the value of the cdr of a
131 ;; Indicates that an expression depends on the value of a vector
132 ;; field. We cannot be more precise, as vectors may alias other
136 ;; Indicates that an expression depends on the value of a variable
140 ;; Indicates that an expression depends on the value of a particular
142 &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+
144 ;; Indicates that an expression depends on the contents of a string.
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.
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.
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).
164 ;; Indicates that an expression depends on the contents of an unknown
166 (define-syntax &struct
168 (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))
171 ;; For systems with smaller fixnums, be less precise regarding struct
173 (define-effects &all-effects
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))))
197 (define-syntax &no-effects (identifier-syntax 0))
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.
206 (define-syntax &all-effects-but-bailout
208 (logand &all-effects (lognot &definite-bailout))))
210 (define-inlinable (cause effect)
213 (define-inlinable (&depends-on a)
214 (logand a &all-effects))
215 (define-inlinable (&causes a)
216 (logand a (cause &all-effects)))
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)
225 (define-inlinable (depends-on-effects? x effects)
226 (not (zero? (logand (&depends-on x) effects))))
227 (define-inlinable (causes-effects? x effects)
228 (not (zero? (logand (&causes x) (cause effects)))))
230 (define-inlinable (effects-commute? a b)
231 (and (not (causes-effects? a (&depends-on b)))
232 (not (causes-effects? b (&depends-on a)))))
234 (define (make-effects-analyzer assigned-lexical?)
235 "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
238 (let ((cache (make-hash-table)))
239 (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
240 (define (compute-effects exp)
241 (or (hashq-ref cache exp)
242 (let ((effects (visit exp)))
243 (hashq-set! cache exp effects)
246 (define (accumulate-effects exps)
247 (let lp ((exps exps) (out &no-effects))
250 (lp (cdr exps) (logior out (compute-effects (car exps)))))))
258 (($ <lexical-ref> _ _ gensym)
259 (if (assigned-lexical? gensym)
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)
269 (accumulate-effects vals)
270 (compute-effects body)))
271 (($ <letrec> _ in-order? names gensyms vals body)
272 (logior (if (or-map assigned-lexical? gensyms)
275 (accumulate-effects vals)
276 (compute-effects body)))
277 (($ <fix> _ names gensyms vals body)
278 (logior (if (or-map assigned-lexical? gensyms)
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)))
289 (cause &type-check)))
292 (cause &type-check)))
293 (($ <module-set> _ mod name public? exp)
294 (logior (cause &toplevel)
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)))
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))
312 (exclude-effects (logior tfx cfx afx)
313 &definite-bailout))))
316 (($ <primcall> _ 'values ())
317 (cause &zero-values))
319 ;; Effect-free primitives.
320 (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
321 (accumulate-effects args))
323 (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
324 'vector? 'struct? 'string? 'number?
327 (compute-effects arg))
329 ;; Primitives that allocate memory.
330 (($ <primcall> _ 'cons (x y))
331 (logior (compute-effects x) (compute-effects y)
334 (($ <primcall> _ (or 'list 'vector) args)
335 (logior (accumulate-effects args) &allocation))
337 (($ <primcall> _ 'make-prompt-tag ())
340 (($ <primcall> _ 'make-prompt-tag (arg))
341 (logior (compute-effects arg) &allocation))
343 (($ <primcall> _ 'fluid-ref (fluid))
344 (logior (compute-effects fluid)
348 (($ <primcall> _ 'fluid-set! (fluid exp))
349 (logior (compute-effects fluid)
350 (compute-effects exp)
354 (($ <primcall> _ 'push-fluid (fluid val))
355 (logior (compute-effects fluid)
356 (compute-effects val)
360 (($ <primcall> _ 'pop-fluid ())
361 (logior (cause &fluid)))
363 (($ <primcall> _ 'car (x))
364 (logior (compute-effects x)
367 (($ <primcall> _ 'set-car! (x y))
368 (logior (compute-effects x)
373 (($ <primcall> _ 'cdr (x))
374 (logior (compute-effects x)
377 (($ <primcall> _ 'set-cdr! (x y))
378 (logior (compute-effects x)
383 (($ <primcall> _ (or 'memq 'memv) (x y))
384 (logior (compute-effects x)
389 (($ <primcall> _ 'vector-ref (v n))
390 (logior (compute-effects v)
394 (($ <primcall> _ 'vector-set! (v n x))
395 (logior (compute-effects v)
401 (($ <primcall> _ 'variable-ref (v))
402 (logior (compute-effects v)
405 (($ <primcall> _ 'variable-set! (v x))
406 (logior (compute-effects v)
411 (($ <primcall> _ 'struct-ref (s n))
412 (logior (compute-effects s)
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+)
424 (($ <primcall> _ 'struct-set! (s n x))
425 (logior (compute-effects s)
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)))))
439 (($ <primcall> _ 'string-ref (s n))
440 (logior (compute-effects s)
444 (($ <primcall> _ 'string-set! (s n c))
445 (logior (compute-effects s)
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)
462 (logior (compute-effects bv)
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!)
477 (logior (compute-effects bv)
481 (cause &bytevector)))
483 ;; Primitives that are normally effect-free, but which might
484 ;; cause type checks or allocate memory. Nota bene,
485 ;; primitives that access mutable memory should be given their
486 ;; own inline cases above!
487 (($ <primcall> _ (and name (? effect-free-primitive?)) args)
488 (logior (accumulate-effects args)
490 (if (constructor-primitive? name)
494 ;; Lambda applications might throw wrong-number-of-args.
495 (($ <call> _ ($ <lambda> _ _ body) args)
496 (logior (accumulate-effects args)
498 (($ <lambda-case> _ req #f #f #f () syms body #f)
499 (logior (compute-effects body)
500 (if (= (length req) (length args))
502 (cause &type-check))))
504 (logior (compute-effects body)
505 (cause &type-check)))
507 ;; Calling a case-lambda with no clauses
508 ;; definitely causes bailout.
509 (logior (cause &definite-bailout)
510 (cause &possible-bailout))))))
512 ;; Bailout primitives.
513 (($ <primcall> _ (? bailout-primitive? name) args)
514 (logior (accumulate-effects args)
515 (cause &definite-bailout)
516 (cause &possible-bailout)))
519 ($ <module-ref> _ mod name public?)
523 (module-ref (if public?
524 (resolve-interface mod)
525 (resolve-module mod))
527 'definite-bailout?)))))
529 (logior (compute-effects proc)
530 (accumulate-effects args)
531 (cause &definite-bailout)
532 (cause &possible-bailout)))
534 ;; A call to a lexically bound procedure, perhaps labels
536 (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
540 (compute-effects (make-call #f proc args))))
542 (logior &all-effects-but-bailout
543 (cause &all-effects-but-bailout)))))
545 ;; A call to an unknown procedure can do anything.
546 (($ <primcall> _ name args)
547 (logior &all-effects-but-bailout
548 (cause &all-effects-but-bailout)))
549 (($ <call> _ proc args)
550 (logior &all-effects-but-bailout
551 (cause &all-effects-but-bailout)))
553 (($ <lambda> _ meta body)
555 (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
556 (logior (exclude-effects (accumulate-effects inits)
558 (if (or-map assigned-lexical? gensyms)
561 (compute-effects body)
562 (if alt (compute-effects alt) &no-effects)))
564 (($ <seq> _ head tail)
566 ;; Returning zero values to a for-effect continuation is
568 (exclude-effects (compute-effects head)
569 (cause &zero-values))
570 (compute-effects tail)))
572 (($ <prompt> _ escape-only? tag body handler)
573 (logior (compute-effects tag)
574 (compute-effects body)
575 (compute-effects handler)))
577 (($ <abort> _ tag args tail)
578 (logior &all-effects-but-bailout
579 (cause &all-effects-but-bailout)))))
581 (compute-effects exp))