[bpt/guile.git] / module / language / tree-il / effects.scm

;;; Effects analysis on Tree-IL

;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (language tree-il effects)
  #:use-module (language tree-il)
  #:use-module (language tree-il primitives)
  #:use-module (ice-9 match)
  #:export (make-effects-analyzer
            &mutable-lexical
            &toplevel
            &fluid
            &definite-bailout
            &possible-bailout
            &zero-values
            &allocation
            &mutable-data
            &type-check
            &all-effects
            effects-commute?
            exclude-effects
            effect-free?
            constant?
            depends-on-effects?
            causes-effects?))

;;;
;;; Hey, it's some effects analysis!  If you invoke
;;; `make-effects-analyzer', you get a procedure that computes the set
;;; of effects that an expression depends on and causes.  This
;;; information is useful when writing algorithms that move code around,
;;; while preserving the semantics of an input program.
;;;
;;; The effects set is represented by a bitfield, as a fixnum.  The set
;;; of possible effects is modelled rather coarsely.  For example, a
;;; toplevel reference to FOO is modelled as depending on the &toplevel
;;; effect, and causing a &type-check effect.  If any intervening code
;;; sets any toplevel variable, that will block motion of FOO.
;;;
;;; For each effect, two bits are reserved: one to indicate that an
;;; expression depends on the effect, and the other to indicate that an
;;; expression causes the effect.
;;;

(define-syntax define-effects
  (lambda (x)
    (syntax-case x ()
      ((_ all name ...)
       (with-syntax (((n ...) (iota (length #'(name ...)))))
         #'(begin
             (define-syntax name (identifier-syntax (ash 1 (* n 2))))
             ...
             (define-syntax all (identifier-syntax (logior name ...)))))))))

;; Here we define the effects, indicating the meaning of the effect.
;;
;; Effects that are described in a "depends on" sense can also be used
;; in the "causes" sense.
;;
;; Effects that are described as causing an effect are not usually used
;; in a "depends-on" sense.  Although the "depends-on" sense is used
;; when checking for the existence of the "causes" effect, the effects
;; analyzer will not associate the "depends-on" sense of these effects
;; with any expression.
;;
(define-effects &all-effects
  ;; Indicates that an expression depends on the value of a mutable
  ;; lexical variable.
  &mutable-lexical

  ;; Indicates that an expression depends on the value of a toplevel
  ;; variable.
  &toplevel

  ;; Indicates that an expression depends on the value of a fluid
  ;; variable.
  &fluid

  ;; Indicates that an expression definitely causes a non-local,
  ;; non-resumable exit -- a bailout.  Only used in the "changes" sense.
  &definite-bailout

  ;; Indicates that an expression may cause a bailout.
  &possible-bailout

  ;; Indicates than an expression may return zero values -- a "causes"
  ;; effect.
  &zero-values

  ;; Indicates that an expression may return a fresh object -- a
  ;; "causes" effect.
  &allocation

  ;; Indicates that an expression depends on the value of a mutable data
  ;; structure.
  &mutable-data

  ;; Indicates that an expression may cause a type check.  A type check,
  ;; for the purposes of this analysis, is the possibility of throwing
  ;; an exception the first time an expression is evaluated.  If the
  ;; expression did not cause an exception to be thrown, users can
  ;; assume that evaluating the expression again will not cause an
  ;; exception to be thrown.
  ;;
  ;; For example, (+ x y) might throw if X or Y are not numbers.  But if
  ;; it doesn't throw, it should be safe to elide a dominated, common
  ;; subexpression (+ x y).
  &type-check)

(define-syntax &no-effects (identifier-syntax 0))

;; Definite bailout is an oddball effect.  Since it indicates that an
;; expression definitely causes bailout, it's not in the set of effects
;; of a call to an unknown procedure.  At the same time, it's also
;; special in that a definite bailout in a subexpression doesn't always
;; cause an outer expression to include &definite-bailout in its
;; effects.  For that reason we have to treat it specially.
;;
(define-syntax &all-effects-but-bailout
  (identifier-syntax
   (logand &all-effects (lognot &definite-bailout))))

(define-inlinable (cause effect)
  (ash effect 1))

(define-inlinable (&depends-on a)
  (logand a &all-effects))
(define-inlinable (&causes a)
  (logand a (cause &all-effects)))

(define (exclude-effects effects exclude)
  (logand effects (lognot (cause exclude))))
(define (effect-free? effects)
  (zero? (&causes effects)))
(define (constant? effects)
  (zero? effects))

(define-inlinable (depends-on-effects? x effects)
  (not (zero? (logand (&depends-on x) effects))))
(define-inlinable (causes-effects? x effects)
  (not (zero? (logand (&causes x) (cause effects)))))

(define-inlinable (effects-commute? a b)
  (and (not (causes-effects? a (&depends-on b)))
       (not (causes-effects? b (&depends-on a)))))

(define (make-effects-analyzer assigned-lexical?)
  "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
of an expression."

  (let ((cache (make-hash-table)))
    (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
      (define (compute-effects exp)
        (or (hashq-ref cache exp)
            (let ((effects (visit exp)))
              (hashq-set! cache exp effects)
              effects)))

      (define (accumulate-effects exps)
        (let lp ((exps exps) (out &no-effects))
          (if (null? exps)
              out
              (lp (cdr exps) (logior out (compute-effects (car exps)))))))

      (define (visit exp)
        (match exp
          (($ <const>)
           &no-effects)
          (($ <void>)
           &no-effects)
          (($ <lexical-ref> _ _ gensym)
           (if (assigned-lexical? gensym)
               &mutable-lexical
               &no-effects))
          (($ <lexical-set> _ name gensym exp)
           (logior (cause &mutable-lexical)
                   (compute-effects exp)))
          (($ <let> _ names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <letrec> _ in-order? names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <fix> _ names gensyms vals body)
           (logior (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (accumulate-effects vals)
                   (compute-effects body)))
          (($ <let-values> _ producer consumer)
           (logior (compute-effects producer)
                   (compute-effects consumer)
                   (cause &type-check)))
          (($ <toplevel-ref>)
           (logior &toplevel
                   (cause &type-check)))
          (($ <module-ref>)
           (logior &toplevel
                   (cause &type-check)))
          (($ <module-set> _ mod name public? exp)
           (logior (cause &toplevel)
                   (cause &type-check)
                   (compute-effects exp)))
          (($ <toplevel-define> _ name exp)
           (logior (cause &toplevel)
                   (compute-effects exp)))
          (($ <toplevel-set> _ name exp)
           (logior (cause &toplevel)
                   (compute-effects exp)))
          (($ <primitive-ref>)
           &no-effects)
          (($ <conditional> _ test consequent alternate)
           (let ((tfx (compute-effects test))
                 (cfx (compute-effects consequent))
                 (afx (compute-effects alternate)))
             (if (causes-effects? (logior tfx (logand afx cfx))
                                  &definite-bailout)
                 (logior tfx cfx afx)
                 (exclude-effects (logior tfx cfx afx)
                                  &definite-bailout))))

          ;; Zero values.
          (($ <primcall> _ 'values ())
           (cause &zero-values))

          ;; Effect-free primitives.
          (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
           (accumulate-effects args))

          (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
                               'vector? 'struct? 'string? 'number?
                               'char?)
              (arg))
           (compute-effects arg))

          ;; Primitives that allocate memory.
          (($ <primcall> _ 'cons (x y))
           (logior (compute-effects x) (compute-effects y)
                   &allocation))

          (($ <primcall> _ (or 'list 'vector) args)
           (logior (accumulate-effects args) &allocation))

          (($ <primcall> _ 'make-prompt-tag ())
           &allocation)

          (($ <primcall> _ 'make-prompt-tag (arg))
           (logior (compute-effects arg) &allocation))

          (($ <primcall> _ 'fluid-ref (fluid))
           (logior (compute-effects fluid)
                   (cause &type-check)
                   &fluid))

          (($ <primcall> _ 'fluid-set! (fluid exp))
           (logior (compute-effects fluid)
                   (compute-effects exp)
                   (cause &type-check)
                   (cause &fluid)))

          (($ <primcall> _ 'push-fluid (fluid val))
           (logior (compute-effects fluid)
                   (compute-effects val)
                   (cause &type-check)
                   (cause &fluid)))

          (($ <primcall> _ 'pop-fluid ())
           (logior (cause &fluid)))

          ;; Primitives that are normally effect-free, but which might
          ;; cause type checks, allocate memory, or access mutable
          ;; memory.  FIXME: expand, to be more precise.
          (($ <primcall> _ (and name (? effect-free-primitive?)) args)
           (logior (accumulate-effects args)
                   (cause &type-check)
                   (if (constructor-primitive? name)
                       (cause &allocation)
                       (if (accessor-primitive? name)
                           &mutable-data
                           &no-effects))))
      
          ;; Lambda applications might throw wrong-number-of-args.
          (($ <call> _ ($ <lambda> _ _ body) args)
           (logior (accumulate-effects args)
                   (match body
                     (($ <lambda-case> _ req #f #f #f () syms body #f)
                      (logior (compute-effects body)
                              (if (= (length req) (length args))
                                  0
                                  (cause &type-check))))
                     (($ <lambda-case>)
                      (logior (compute-effects body)
                              (cause &type-check)))
                     (#f
                      ;; Calling a case-lambda with no clauses
                      ;; definitely causes bailout.
                      (logior (cause &definite-bailout)
                              (cause &possible-bailout))))))
        
          ;; Bailout primitives.
          (($ <primcall> _ (? bailout-primitive? name) args)
           (logior (accumulate-effects args)
                   (cause &definite-bailout)
                   (cause &possible-bailout)))

          ;; A call to a lexically bound procedure, perhaps labels
          ;; allocated.
          (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
           (cond
            ((lookup sym)
             => (lambda (proc)
                  (compute-effects (make-call #f proc args))))
            (else
             (logior &all-effects-but-bailout
                     (cause &all-effects-but-bailout)))))

          ;; A call to an unknown procedure can do anything.
          (($ <primcall> _ name args)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))
          (($ <call> _ proc args)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))

          (($ <lambda> _ meta body)
           &no-effects)
          (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
           (logior (exclude-effects (accumulate-effects inits)
                                    &definite-bailout)
                   (if (or-map assigned-lexical? gensyms)
                       (cause &allocation)
                       &no-effects)
                   (compute-effects body)
                   (if alt (compute-effects alt) &no-effects)))

          (($ <seq> _ head tail)
           (logior
            ;; Returning zero values to a for-effect continuation is
            ;; not observable.
            (exclude-effects (compute-effects head)
                             (cause &zero-values))
            (compute-effects tail)))

          (($ <prompt> _ escape-only? tag body handler)
           (logior (compute-effects tag)
                   (compute-effects body)
                   (compute-effects handler)))

          (($ <abort> _ tag args tail)
           (logior &all-effects-but-bailout
                   (cause &all-effects-but-bailout)))))

      (compute-effects exp))

    compute-effects))
Commit	Line	Data
da9b2b71 AW	1	;;; Effects analysis on Tree-IL
da9b2b71 AW	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))
da9b2b71 AW	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)))))
da9b2b71 AW	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))
37081d5d AW	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))
37081d5d AW	263
2aed2667	264	(($ <primcall> _ 'make-prompt-tag ())
37081d5d AW	265	&allocation)
37081d5d AW	266
2aed2667	267	(($ <primcall> _ 'make-prompt-tag (arg))
37081d5d AW	268	(logior (compute-effects arg) &allocation))
37081d5d AW	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))