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

;;; Effects analysis on Tree-IL

;; Copyright (C) 2011, 2012 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 name (ash 1 (* n 2)))
             ...
             (define all (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 &no-effects 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 &all-effects-but-bailout
  (logand &all-effects (lognot &definite-bailout)))

(define (cause effect)
  (ash effect 1))

(define (&depends-on a)
  (logand a &all-effects))
(define (&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 (depends-on-effects? x effects)
  (not (zero? (logand (&depends-on x) effects))))
(define (causes-effects? x effects)
  (not (zero? (logand (&causes x) (cause effects)))))

(define (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."

  (define compute-effects
    (let ((cache (make-hash-table)))
      (lambda (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)))
      (($ <dynwind> _ winder body unwinder)
       (logior (compute-effects winder)
               (compute-effects body)
               (compute-effects unwinder)))
      (($ <dynlet> _ fluids vals body)
       (logior (accumulate-effects fluids)
               (accumulate-effects vals)
               (cause &type-check)
               (cause &fluid)
               (compute-effects body)))
      (($ <dynref> _ fluid)
       (logior (compute-effects fluid)
               (cause &type-check)
               &fluid))
      (($ <dynset> _ fluid exp)
       (logior (compute-effects fluid)
               (compute-effects exp)
               (cause &type-check)
               (cause &fluid)))
      (($ <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.
      (($ <application> _ ($ <primitive-ref> _ 'values) ())
       (cause &zero-values))

      ;; Effect-free primitives.
      (($ <application> _
          ($ <primitive-ref> _ (and name
                                    (? effect+exception-free-primitive?)))
          args)
       (logior (accumulate-effects args)
               (if (constructor-primitive? name)
                   (cause &allocation)
                   &no-effects)))
      (($ <application> _
          ($ <primitive-ref> _ (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.
      (($ <application> _ ($ <lambda> _ _ body) args)
       (logior (compute-effects body)
               (accumulate-effects args)
               (cause &type-check)))
        
      ;; Bailout primitives.
      (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
          args)
       (logior (accumulate-effects args)
               (cause &definite-bailout)
               (cause &possible-bailout)))

      ;; A call to an unknown procedure can do anything.
      (($ <application> _ 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)))

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

      (($ <prompt> _ 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)
Commit	Line	Data
da9b2b71 AW	1	;;; Effects analysis on Tree-IL
	2
	3	;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
	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
65	(define name (ash 1 (* n 2)))
66	...
67	(define all (logior name ...))))))))
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
124	(define &no-effects 0)
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	;;
133	(define &all-effects-but-bailout
134	(logand &all-effects (lognot &definite-bailout)))
135
136	(define (cause effect)
137	(ash effect 1))
138
139	(define (&depends-on a)
140	(logand a &all-effects))
141	(define (&causes a)
142	(logand a (cause &all-effects)))
143
144	(define (exclude-effects effects exclude)
145	(logand effects (lognot (cause exclude))))
146	(define (effect-free? effects)
147	(zero? (&causes effects)))
148	(define (constant? effects)
149	(zero? effects))
150
151	(define (depends-on-effects? x effects)
152	(not (zero? (logand (&depends-on x) effects))))
153	(define (causes-effects? x effects)
154	(not (zero? (logand (&causes x) (cause effects)))))
155
156	(define (effects-commute? a b)
157	(and (not (causes-effects? a (&depends-on b)))
158	(not (causes-effects? b (&depends-on a)))))
159
160	(define (make-effects-analyzer assigned-lexical?)
161	"Returns a procedure of type EXP -> EFFECTS that analyzes the effects
162	of an expression."
163
164	(define compute-effects
165	(let ((cache (make-hash-table)))
166	(lambda (exp)
167	(or (hashq-ref cache exp)
168	(let ((effects (visit exp)))
169	(hashq-set! cache exp effects)
170	effects)))))
171
172	(define (accumulate-effects exps)
173	(let lp ((exps exps) (out &no-effects))
174	(if (null? exps)
175	out
176	(lp (cdr exps) (logior out (compute-effects (car exps)))))))
177
178	(define (visit exp)
179	(match exp
180	(($ <const>)
181	&no-effects)
182	(($ <void>)
183	&no-effects)
184	(($ <lexical-ref> _ _ gensym)
185	(if (assigned-lexical? gensym)
186	&mutable-lexical
187	&no-effects))
188	(($ <lexical-set> _ name gensym exp)
189	(logior (cause &mutable-lexical)
190	(compute-effects exp)))
191	(($ <let> _ names gensyms vals body)
192	(logior (if (or-map assigned-lexical? gensyms)
193	(cause &allocation)
194	&no-effects)
195	(accumulate-effects vals)
196	(compute-effects body)))
197	(($ <letrec> _ in-order? names gensyms vals body)
198	(logior (if (or-map assigned-lexical? gensyms)
199	(cause &allocation)
200	&no-effects)
201	(accumulate-effects vals)
202	(compute-effects body)))
203	(($ <fix> _ names gensyms vals body)
204	(logior (if (or-map assigned-lexical? gensyms)
205	(cause &allocation)
206	&no-effects)
207	(accumulate-effects vals)
208	(compute-effects body)))
209	(($ <let-values> _ producer consumer)
210	(logior (compute-effects producer)
211	(compute-effects consumer)
212	(cause &type-check)))
213	(($ <dynwind> _ winder body unwinder)
214	(logior (compute-effects winder)
215	(compute-effects body)
216	(compute-effects unwinder)))
217	(($ <dynlet> _ fluids vals body)
218	(logior (accumulate-effects fluids)
219	(accumulate-effects vals)
220	(cause &type-check)
221	(cause &fluid)
222	(compute-effects body)))
223	(($ <dynref> _ fluid)
224	(logior (compute-effects fluid)
225	(cause &type-check)
226	&fluid))
227	(($ <dynset> _ fluid exp)
228	(logior (compute-effects fluid)
229	(compute-effects exp)
230	(cause &type-check)
231	(cause &fluid)))
232	(($ <toplevel-ref>)
233	(logior &toplevel
234	(cause &type-check)))
235	(($ <module-ref>)
236	(logior &toplevel
237	(cause &type-check)))
238	(($ <module-set> _ mod name public? exp)
239	(logior (cause &toplevel)
240	(cause &type-check)
241	(compute-effects exp)))
242	(($ <toplevel-define> _ name exp)
243	(logior (cause &toplevel)
244	(compute-effects exp)))
245	(($ <toplevel-set> _ name exp)
246	(logior (cause &toplevel)
247	(compute-effects exp)))
248	(($ <primitive-ref>)
249	&no-effects)
250	(($ <conditional> _ test consequent alternate)
251	(let ((tfx (compute-effects test))
252	(cfx (compute-effects consequent))
253	(afx (compute-effects alternate)))
254	(if (causes-effects? (logior tfx (logand afx cfx))
255	&definite-bailout)
256	(logior tfx cfx afx)
257	(exclude-effects (logior tfx cfx afx)
258	&definite-bailout))))
259
260	;; Zero values.
261	(($ <application> _ ($ <primitive-ref> _ 'values) ())
262	(cause &zero-values))
263
264	;; Effect-free primitives.
265	(($ <application> _
266	($ <primitive-ref> _ (and name
267	(? effect+exception-free-primitive?)))
268	args)
269	(logior (accumulate-effects args)
270	(if (constructor-primitive? name)
271	(cause &allocation)
272	&no-effects)))
273	(($ <application> _
274	($ <primitive-ref> _ (and name
275	(? effect-free-primitive?)))
276	args)
277	(logior (accumulate-effects args)
278	(cause &type-check)
279	(if (constructor-primitive? name)
280	(cause &allocation)
281	(if (accessor-primitive? name)
282	&mutable-data
283	&no-effects))))
284
285	;; Lambda applications might throw wrong-number-of-args.
286	(($ <application> _ ($ <lambda> _ _ body) args)
287	(logior (compute-effects body)
288	(accumulate-effects args)
289	(cause &type-check)))
290
291	;; Bailout primitives.
292	(($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
293	args)
294	(logior (accumulate-effects args)
295	(cause &definite-bailout)
296	(cause &possible-bailout)))
297
298	;; A call to an unknown procedure can do anything.
299	(($ <application> _ proc args)
300	(logior &all-effects-but-bailout
301	(cause &all-effects-but-bailout)))
302
303	(($ <lambda> _ meta body)
304	&no-effects)
305	(($ <lambda-case> _ req opt rest kw inits gensyms body alt)
306	(logior (exclude-effects (accumulate-effects inits)
307	&definite-bailout)
308	(if (or-map assigned-lexical? gensyms)
309	(cause &allocation)
310	&no-effects)
311	(compute-effects body)
312	(if alt (compute-effects alt) &no-effects)))
313
314	(($ <sequence> _ exps)
315	(let lp ((exps exps) (effects &no-effects))
316	(match exps
317	((tail)
318	(logior (compute-effects tail)
319	;; Returning zero values to a for-effect continuation is
320	;; not observable.
321	(exclude-effects effects (cause &zero-values))))
322	((head . tail)
323	(lp tail (logior (compute-effects head) effects))))))
324
325	(($ <prompt> _ tag body handler)
326	(logior (compute-effects tag)
327	(compute-effects body)
328	(compute-effects handler)))
329
330	(($ <abort> _ tag args tail)
331	(logior &all-effects-but-bailout
332	(cause &all-effects-but-bailout)))))
333
334	compute-effects)