X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/cc620af7ca9bb7c2c841f9612fbdf97b68aaf277..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps/effects-analysis.scm

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
dissimilarity index 81%
index 66e659583..3c0da24d7 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -1,480 +1,499 @@
-;;; Effects analysis on CPS
-
-;; Copyright (C) 2011, 2012, 2013, 2014 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
-
-;;; Commentary:
-;;;
-;;; A helper module to compute 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
-;;; "car" call modelled as depending on the &car effect, and causing a
-;;; &type-check effect.  If any intervening code sets the car of any
-;;; pair, that will block motion of the "car" call.
-;;;
-;;; 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.
-;;;
-;;; Since we have more bits in a fixnum on 64-bit systems, we can be
-;;; more precise without losing efficiency.  On a 32-bit system, some of
-;;; the more precise effects map to fewer bits.
-;;;
-;;; Code:
-
-(define-module (language cps effects-analysis)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (ice-9 match)
-  #:export (expression-effects
-            compute-effects
-
-            &fluid
-            &prompt
-            &definite-bailout
-            &possible-bailout
-            &allocation
-            &car
-            &cdr
-            &vector
-            &box
-            &module
-            &struct
-            &string
-            &bytevector
-            &type-check
-
-            &no-effects
-            &all-effects
-            &all-effects-but-bailout
-
-            effects-commute?
-            exclude-effects
-            effect-free?
-            constant?
-            depends-on-effects?
-            causes-effects?))
-
-(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 ...)))))))))
-
-(define-syntax compile-time-cond
-  (lambda (x)
-    (syntax-case x (else)
-      ((_ (else body ...))
-       #'(begin body ...))
-      ((_ (exp body ...) clause ...)
-       (if (eval (syntax->datum #'exp) (current-module))
-           #'(begin body ...)
-           #'(compile-time-cond clause ...))))))
-
-;; 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.
-;;
-(compile-time-cond
- ((>= (logcount most-positive-fixnum) 60)
-  (define-effects &all-effects
-    ;; Indicates that an expression depends on the value of a fluid
-    ;; variable.
-    &fluid
-
-    ;; Indicates that an expression depends on the current prompt
-    ;; stack.
-    &prompt
-
-    ;; 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 that an expression may return a fresh object -- a
-    ;; "causes" effect.
-    &allocation
-
-    ;; Indicates that an expression depends on the value of the car of a
-    ;; pair.
-    &car
-
-    ;; Indicates that an expression depends on the value of the cdr of a
-    ;; pair.
-    &cdr
-
-    ;; Indicates that an expression depends on the value of a vector
-    ;; field.  We cannot be more precise, as vectors may alias other
-    ;; vectors.
-    &vector
-
-    ;; Indicates that an expression depends on the value of a variable
-    ;; cell.
-    &box
-
-    ;; Indicates that an expression depends on the current module.
-    &module
-
-    ;; Indicates that an expression depends on the value of a particular
-    ;; struct field.
-    &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+
-
-    ;; Indicates that an expression depends on the contents of a string.
-    &string
-
-    ;; Indicates that an expression depends on the contents of a
-    ;; bytevector.  We cannot be more precise, as bytevectors may alias
-    ;; other bytevectors.
-    &bytevector
-
-    ;; 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)
-
-  ;; Indicates that an expression depends on the contents of an unknown
-  ;; struct field.
-  (define-syntax &struct
-    (identifier-syntax
-     (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))
-
- (else
-  ;; For systems with smaller fixnums, be less precise regarding struct
-  ;; fields.
-  (define-effects &all-effects
-    &fluid
-    &prompt
-    &definite-bailout
-    &possible-bailout
-    &allocation
-    &car
-    &cdr
-    &vector
-    &box
-    &module
-    &struct
-    &string
-    &bytevector
-    &type-check)
-  (define-syntax &struct-0 (identifier-syntax &struct))
-  (define-syntax &struct-1 (identifier-syntax &struct))
-  (define-syntax &struct-2 (identifier-syntax &struct))
-  (define-syntax &struct-3 (identifier-syntax &struct))
-  (define-syntax &struct-4 (identifier-syntax &struct))
-  (define-syntax &struct-5 (identifier-syntax &struct))
-  (define-syntax &struct-6+ (identifier-syntax &struct))))
-
-(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 (lookup-constant-index sym dfg)
-  (call-with-values (lambda () (find-constant-value sym dfg))
-    (lambda (has-const? val)
-      (and has-const? (integer? val) (exact? val) (<= 0 val) val))))
-
-(define *primitive-effects* (make-hash-table))
-
-(define-syntax-rule (define-primitive-effects* dfg ((name . args) effects) ...)
-  (begin
-    (hashq-set! *primitive-effects* 'name
-                (case-lambda* ((dfg . args) effects)
-                              (_ (logior (cause &possible-bailout)
-                                         (cause &definite-bailout)))))
-    ...))
-
-(define-syntax-rule (define-primitive-effects ((name . args) effects) ...)
-  (define-primitive-effects* dfg ((name . args) effects) ...))
-
-;; Miscellaneous.
-(define-primitive-effects
-  ((values . _) &no-effects)
-  ((not arg) &no-effects))
-
-;; Generic predicates.
-(define-primitive-effects
-  ((eq? . _) &no-effects)
-  ((eqv? . _) &no-effects)
-  ((equal? . _) &no-effects)
-  ((pair? arg) &no-effects)
-  ((null? arg) &no-effects)
-  ((nil? arg ) &no-effects)
-  ((list? arg) &no-effects)
-  ((symbol? arg) &no-effects)
-  ((variable? arg) &no-effects)
-  ((vector? arg) &no-effects)
-  ((struct? arg) &no-effects)
-  ((string? arg) &no-effects)
-  ((number? arg) &no-effects)
-  ((char? arg) &no-effects)
-  ((procedure? arg) &no-effects)
-  ((thunk? arg) &no-effects))
-
-;; Fluids.
-(define-primitive-effects
-  ((fluid-ref f) (logior (cause &type-check) &fluid))
-  ((fluid-set! f v) (logior (cause &type-check) (cause &fluid)))
-  ((push-fluid f v) (logior (cause &type-check) (cause &fluid)))
-  ((pop-fluid) (logior (cause &fluid))))
-
-;; Prompts.
-(define-primitive-effects
-  ((make-prompt-tag #:optional arg) (cause &allocation)))
-
-;; Bailout.
-(define-primitive-effects
-  ((error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
-  ((scm-error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
-  ((throw . _) (logior (cause &definite-bailout) (cause &possible-bailout))))
-
-;; Pairs.
-(define-primitive-effects
-  ((cons a b) (cause &allocation))
-  ((list . _) (cause &allocation))
-  ((car x) (logior (cause &type-check) &car))
-  ((set-car! x y) (logior (cause &type-check) (cause &car)))
-  ((cdr x) (logior (cause &type-check) &cdr))
-  ((set-cdr! x y) (logior (cause &type-check) (cause &cdr)))
-  ((memq x y) (logior (cause &type-check) &car &cdr))
-  ((memv x y) (logior (cause &type-check) &car &cdr))
-  ((length l) (logior (cause &type-check) &car &cdr)))
-
-;; Vectors.
-(define-primitive-effects
-  ((vector . _) (cause &allocation))
-  ((vector-ref v n) (logior (cause &type-check) &vector))
-  ((vector-set! v n x) (logior (cause &type-check) (cause &vector)))
-  ((vector-length v) (cause &type-check)))
-
-;; Variables.
-(define-primitive-effects
-  ((box v) (cause &allocation))
-  ((box-ref v) (logior (cause &type-check) &box))
-  ((box-set! v x) (logior (cause &type-check) (cause &box))))
-
-;; Structs.
-(define-primitive-effects* dfg
-  ((allocate-struct vtable nfields) (logior (cause &type-check)
-                                            (cause &allocation)))
-  ((make-struct vtable ntail . args) (logior (cause &type-check)
-                                             (cause &allocation)))
-  ((make-struct/no-tail vtable . args) (logior (cause &type-check)
-                                               (cause &allocation)))
-  ((struct-ref s n)
-   (logior (cause &type-check)
-           (match (lookup-constant-index n dfg)
-             (#f &struct)
-             (0 &struct-0)
-             (1 &struct-1)
-             (2 &struct-2)
-             (3 &struct-3)
-             (4 &struct-4)
-             (5 &struct-5)
-             (_ &struct-6+))))
-  ((struct-set! s n x)
-   (logior (cause &type-check)
-           (match (lookup-constant-index n dfg)
-             (#f (cause &struct))
-             (0 (cause &struct-0))
-             (1 (cause &struct-1))
-             (2 (cause &struct-2))
-             (3 (cause &struct-3))
-             (4 (cause &struct-4))
-             (5 (cause &struct-5))
-             (_ (cause &struct-6+)))))
-  ((struct-vtable s) (cause &type-check)))
-
-;; Strings.
-(define-primitive-effects
-  ((string-ref s n) (logior (cause &type-check) &string))
-  ((string-set! s n c) (logior (cause &type-check) (cause &string)))
-  ((number->string _) (cause &type-check))
-  ((string->number _) (logior (cause &type-check) &string))
-  ((string-length s) (cause &type-check)))
-
-;; Bytevectors.
-(define-primitive-effects
-  ((bv-u8-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-s8-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-u16-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-s16-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-u32-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-s32-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-u64-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-s64-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-f32-ref bv n) (logior (cause &type-check) &bytevector))
-  ((bv-f64-ref bv n) (logior (cause &type-check) &bytevector))
-  
-  ((bv-u8-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-s8-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-u16-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-s16-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-u32-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-s32-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-u64-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-s64-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-f32-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
-  ((bv-f64-set! bv n x) (logior (cause &type-check) (cause &bytevector))))
-
-;; Numbers.
-(define-primitive-effects
-  ((= . _) (cause &type-check))
-  ((< . _) (cause &type-check))
-  ((> . _) (cause &type-check))
-  ((<= . _) (cause &type-check))
-  ((>= . _) (cause &type-check))
-  ((zero? . _) (cause &type-check))
-  ((add . _) (cause &type-check))
-  ((mul . _) (cause &type-check))
-  ((sub . _) (cause &type-check))
-  ((div . _) (cause &type-check))
-  ((sub1 . _) (cause &type-check))
-  ((add1 . _) (cause &type-check))
-  ((quo . _) (cause &type-check))
-  ((rem . _) (cause &type-check))
-  ((mod . _) (cause &type-check))
-  ((complex? _) (cause &type-check))
-  ((real? _) (cause &type-check))
-  ((rational? _) (cause &type-check))
-  ((inf? _) (cause &type-check))
-  ((nan? _) (cause &type-check))
-  ((integer? _) (cause &type-check))
-  ((exact? _) (cause &type-check))
-  ((inexact? _) (cause &type-check))
-  ((even? _) (cause &type-check))
-  ((odd? _) (cause &type-check))
-  ((ash n m) (cause &type-check))
-  ((logand . _) (cause &type-check))
-  ((logior . _) (cause &type-check))
-  ((logior . _) (cause &type-check))
-  ((lognot . _) (cause &type-check)))
-
-;; Characters.
-(define-primitive-effects
-  ((char<? . _) (cause &type-check))
-  ((char<=? . _) (cause &type-check))
-  ((char>=? . _) (cause &type-check))
-  ((char>? . _) (cause &type-check))
-  ((integer->char _) (cause &type-check))
-  ((char->integer _) (cause &type-check)))
-
-;; Modules.
-(define-primitive-effects
-  ((current-module) &module)
-  ((cache-current-module! mod scope) (cause &box))
-  ((resolve name bound?) (logior &box &module (cause &type-check)))
-  ((cached-toplevel-box scope name bound?) (logior &box (cause &type-check)))
-  ((cached-module-box scope name bound?) (logior &box (cause &type-check)))
-  ((define! name val) (logior &module (cause &box))))
-
-(define (primitive-effects dfg name args)
-  (let ((proc (hashq-ref *primitive-effects* name)))
-    (if proc
-        (apply proc dfg args)
-        (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))))
-
-(define (expression-effects exp dfg)
-  (match exp
-    ((or ($ $void) ($ $const) ($ $prim) ($ $values))
-     &no-effects)
-    (($ $fun)
-     (cause &allocation))
-    (($ $prompt)
-     (cause &prompt))
-    ((or ($ $call) ($ $callk))
-     (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
-    (($ $primcall name args)
-     (primitive-effects dfg name args))))
-
-(define (compute-effects cfa dfg)
-  (let ((effects (make-vector (cfa-k-count cfa) &no-effects)))
-    (let lp ((n 0))
-      (when (< n (vector-length effects))
-        (vector-set!
-         effects
-         n
-         (match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
-           (($ $kargs names syms body)
-            (expression-effects (find-expression body) dfg))
-           (($ $kreceive arity kargs)
-            (match arity
-              (($ $arity _ () #f () #f) (cause &type-check))
-              (($ $arity () () _ () #f) (cause &allocation))
-              (($ $arity _ () _ () #f) (logior (cause &allocation)
-                                               (cause &type-check)))))
-           (($ $kif) &no-effects)
-           (($ $kentry) &type-check)
-           (($ $kclause) &type-check)
-           (($ $ktail) &no-effects)))
-        (lp (1+ n))))
-    effects))
+;;; Effects analysis on CPS
+
+;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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
+
+;;; Commentary:
+;;;
+;;; A helper module to compute the set of effects caused by an
+;;; expression.  This information is useful when writing algorithms that
+;;; move code around, while preserving the semantics of an input
+;;; program.
+;;;
+;;; The effects set is represented as an integer with three parts.  The
+;;; low 4 bits indicate effects caused by an expression, as a bitfield.
+;;; The next 4 bits indicate the kind of memory accessed by the
+;;; expression, if it accesses mutable memory.  Finally the rest of the
+;;; bits indicate the field in the object being accessed, if known, or
+;;; -1 for unknown.
+;;;
+;;; In this way we embed a coarse type-based alias analysis in the
+;;; effects analysis.  For example, a "car" call is modelled as causing
+;;; a read to field 0 on a &pair, and causing a &type-check effect.  If
+;;; any intervening code sets the car of any pair, that will block
+;;; motion of the "car" call, because any write to field 0 of a pair is
+;;; seen by effects analysis as being a write to field 0 of all pairs.
+;;;
+;;; Code:
+
+(define-module (language cps effects-analysis)
+  #:use-module (language cps)
+  #:use-module (language cps dfg)
+  #:use-module (ice-9 match)
+  #:export (expression-effects
+            compute-effects
+            synthesize-definition-effects!
+
+            &allocation
+            &type-check
+            &read
+            &write
+
+            &fluid
+            &prompt
+            &car
+            &cdr
+            &vector
+            &box
+            &module
+            &struct
+            &string
+            &bytevector
+
+            &object
+            &field
+
+            &allocate
+            &read-object
+            &read-field
+            &write-object
+            &write-field
+
+            &no-effects
+            &all-effects
+
+            exclude-effects
+            effect-free?
+            constant?
+            causes-effect?
+            causes-all-effects?
+            effect-clobbers?))
+
+(define-syntax define-flags
+  (lambda (x)
+    (syntax-case x ()
+      ((_ all shift name ...)
+       (let ((count (length #'(name ...))))
+         (with-syntax (((n ...) (iota count))
+                       (count count))
+           #'(begin
+               (define-syntax name (identifier-syntax (ash 1 n)))
+               ...
+               (define-syntax all (identifier-syntax (1- (ash 1 count))))
+               (define-syntax shift (identifier-syntax count)))))))))
+
+(define-syntax define-enumeration
+  (lambda (x)
+    (define (count-bits n)
+      (let lp ((out 1))
+        (if (< n (ash 1 (1- out)))
+            out
+            (lp (1+ out)))))
+    (syntax-case x ()
+      ((_ mask shift name ...)
+       (let* ((len (length #'(name ...)))
+              (bits (count-bits len)))
+         (with-syntax (((n ...) (iota len))
+                       (bits bits))
+           #'(begin
+               (define-syntax name (identifier-syntax n))
+               ...
+               (define-syntax mask (identifier-syntax (1- (ash 1 bits))))
+               (define-syntax shift (identifier-syntax bits)))))))))
+
+(define-flags &all-effect-kinds &effect-kind-bits
+  ;; 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
+
+  ;; Indicates that an expression may return a fresh object.  The kind
+  ;; of object is indicated in the object kind field.
+  &allocation
+
+  ;; Indicates that an expression may cause a read from memory.  The
+  ;; kind of memory is given in the object kind field.  Some object
+  ;; kinds have finer-grained fields; those are expressed in the "field"
+  ;; part of the effects value.  -1 indicates "the whole object".
+  &read
+
+  ;; Indicates that an expression may cause a write to memory.
+  &write)
+
+(define-enumeration &memory-kind-mask &memory-kind-bits
+  ;; Indicates than an expression may access unknown kinds of memory.
+  &unknown-memory-kinds
+
+  ;; Indicates that an expression depends on the value of a fluid
+  ;; variable, or on the current fluid environment.
+  &fluid
+
+  ;; Indicates that an expression depends on the current prompt
+  ;; stack.
+  &prompt
+
+  ;; Indicates that an expression depends on the value of the car or cdr
+  ;; of a pair.
+  &pair
+
+  ;; Indicates that an expression depends on the value of a vector
+  ;; field.  The effect field indicates the specific field, or zero for
+  ;; an unknown field.
+  &vector
+
+  ;; Indicates that an expression depends on the value of a variable
+  ;; cell.
+  &box
+
+  ;; Indicates that an expression depends on the current module.
+  &module
+
+  ;; Indicates that an expression depends on the value of a struct
+  ;; field.  The effect field indicates the specific field, or zero for
+  ;; an unknown field.
+  &struct
+
+  ;; Indicates that an expression depends on the contents of a string.
+  &string
+
+  ;; Indicates that an expression depends on the contents of a
+  ;; bytevector.  We cannot be more precise, as bytevectors may alias
+  ;; other bytevectors.
+  &bytevector)
+
+(define-inlinable (&field kind field)
+  (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
+(define-inlinable (&object kind)
+  (&field kind -1))
+
+(define-inlinable (&allocate kind)
+  (logior &allocation (&object kind)))
+(define-inlinable (&read-field kind field)
+  (logior &read (&field kind field)))
+(define-inlinable (&read-object kind)
+  (logior &read (&object kind)))
+(define-inlinable (&write-field kind field)
+  (logior &write (&field kind field)))
+(define-inlinable (&write-object kind)
+  (logior &write (&object kind)))
+
+(define-syntax &no-effects (identifier-syntax 0))
+(define-syntax &all-effects
+  (identifier-syntax
+   (logior &all-effect-kinds (&object &unknown-memory-kinds))))
+
+(define-inlinable (constant? effects)
+  (zero? effects))
+
+(define-inlinable (causes-effect? x effects)
+  (not (zero? (logand x effects))))
+
+(define-inlinable (causes-all-effects? x)
+  (eqv? x &all-effects))
+
+(define (effect-clobbers? a b)
+  "Return true if A clobbers B.  This is the case if A is a write, and B
+is or might be a read or a write to the same location as A."
+  (define (locations-same?)
+    (let ((a (ash a (- &effect-kind-bits)))
+          (b (ash b (- &effect-kind-bits))))
+      (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
+          (eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
+          (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
+               ;; A negative field indicates "the whole object".
+               ;; Non-negative fields indicate only part of the object.
+               (or (< a 0) (< b 0) (= a b))))))
+  (and (not (zero? (logand a &write)))
+       (not (zero? (logand b (logior &read &write))))
+       (locations-same?)))
+
+(define (lookup-constant-index sym dfg)
+  (call-with-values (lambda () (find-constant-value sym dfg))
+    (lambda (has-const? val)
+      (and has-const? (integer? val) (exact? val) (<= 0 val) val))))
+
+(define-inlinable (indexed-field kind n dfg)
+  (cond
+   ((lookup-constant-index n dfg)
+    => (lambda (idx)
+         (&field kind idx)))
+   (else (&object kind))))
+
+(define *primitive-effects* (make-hash-table))
+
+(define-syntax-rule (define-primitive-effects* dfg
+                      ((name . args) effects ...)
+                      ...)
+  (begin
+    (hashq-set! *primitive-effects* 'name
+                (case-lambda*
+                 ((dfg . args) (logior effects ...))
+                 (_ &all-effects)))
+    ...))
+
+(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
+  (define-primitive-effects* dfg ((name . args) effects ...) ...))
+
+;; Miscellaneous.
+(define-primitive-effects
+  ((values . _)))
+
+;; Generic effect-free predicates.
+(define-primitive-effects
+  ((eq? . _))
+  ((eqv? . _))
+  ((equal? . _))
+  ((pair? arg))
+  ((null? arg))
+  ((nil? arg ))
+  ((symbol? arg))
+  ((variable? arg))
+  ((vector? arg))
+  ((struct? arg))
+  ((string? arg))
+  ((number? arg))
+  ((char? arg))
+  ((bytevector? arg))
+  ((keyword? arg))
+  ((bitvector? arg))
+  ((procedure? arg))
+  ((thunk? arg)))
+
+;; Fluids.
+(define-primitive-effects
+  ((fluid-ref f)                   (&read-object &fluid)       &type-check)
+  ((fluid-set! f v)                (&write-object &fluid)      &type-check)
+  ((push-fluid f v)                (&write-object &fluid)      &type-check)
+  ((pop-fluid)                     (&write-object &fluid)      &type-check))
+
+;; Prompts.
+(define-primitive-effects
+  ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
+
+;; Pairs.
+(define-primitive-effects
+  ((cons a b)                      (&allocate &pair))
+  ((list . _)                      (&allocate &pair))
+  ((car x)                         (&read-field &pair 0)       &type-check)
+  ((set-car! x y)                  (&write-field &pair 0)      &type-check)
+  ((cdr x)                         (&read-field &pair 1)       &type-check)
+  ((set-cdr! x y)                  (&write-field &pair 1)      &type-check)
+  ((memq x y)                      (&read-object &pair)        &type-check)
+  ((memv x y)                      (&read-object &pair)        &type-check)
+  ((list? arg)                     (&read-field &pair 1))
+  ((length l)                      (&read-field &pair 1)       &type-check))
+
+;; Variables.
+(define-primitive-effects
+  ((box v)                         (&allocate &box))
+  ((box-ref v)                     (&read-object &box)         &type-check)
+  ((box-set! v x)                  (&write-object &box)        &type-check))
+
+;; Vectors.
+(define (vector-field n dfg)
+  (indexed-field &vector n dfg))
+(define (read-vector-field n dfg)
+  (logior &read (vector-field n dfg)))
+(define (write-vector-field n dfg)
+  (logior &write (vector-field n dfg)))
+(define-primitive-effects* dfg
+  ((vector . _)                    (&allocate &vector))
+  ((make-vector n init)            (&allocate &vector)         &type-check)
+  ((make-vector/immediate n init)  (&allocate &vector))
+  ((vector-ref v n)                (read-vector-field n dfg)   &type-check)
+  ((vector-ref/immediate v n)      (read-vector-field n dfg)   &type-check)
+  ((vector-set! v n x)             (write-vector-field n dfg)  &type-check)
+  ((vector-set!/immediate v n x)   (write-vector-field n dfg)  &type-check)
+  ((vector-length v)                                           &type-check))
+
+;; Structs.
+(define (struct-field n dfg)
+  (indexed-field &struct n dfg))
+(define (read-struct-field n dfg)
+  (logior &read (struct-field n dfg)))
+(define (write-struct-field n dfg)
+  (logior &write (struct-field n dfg)))
+(define-primitive-effects* dfg
+  ((allocate-struct vt n)          (&allocate &struct)         &type-check)
+  ((allocate-struct/immediate v n) (&allocate &struct)         &type-check)
+  ((make-struct vt ntail . _)      (&allocate &struct)         &type-check)
+  ((make-struct/no-tail vt . _)    (&allocate &struct)         &type-check)
+  ((struct-ref s n)                (read-struct-field n dfg)   &type-check)
+  ((struct-ref/immediate s n)      (read-struct-field n dfg)   &type-check)
+  ((struct-set! s n x)             (write-struct-field n dfg)  &type-check)
+  ((struct-set!/immediate s n x)   (write-struct-field n dfg)  &type-check)
+  ((struct-vtable s)                                           &type-check))
+
+;; Strings.
+(define-primitive-effects
+  ((string-ref s n)                (&read-object &string)      &type-check)
+  ((string-set! s n c)             (&write-object &string)     &type-check)
+  ((number->string _)              (&allocate &string)         &type-check)
+  ((string->number _)              (&read-object &string)      &type-check)
+  ((string-length s)                                           &type-check))
+
+;; Bytevectors.
+(define-primitive-effects
+  ((bytevector-length _)                                       &type-check)
+
+  ((bv-u8-ref bv n)                (&read-object &bytevector)  &type-check)
+  ((bv-s8-ref bv n)                (&read-object &bytevector)  &type-check)
+  ((bv-u16-ref bv n)               (&read-object &bytevector)  &type-check)
+  ((bv-s16-ref bv n)               (&read-object &bytevector)  &type-check)
+  ((bv-u32-ref bv n)               (&read-object &bytevector)  &type-check)
+  ((bv-s32-ref bv n)               (&read-object &bytevector)  &type-check)
+  ((bv-u64-ref bv n)               (&read-object &bytevector)  &type-check)
+  ((bv-s64-ref bv n)               (&read-object &bytevector)  &type-check)
+  ((bv-f32-ref bv n)               (&read-object &bytevector)  &type-check)
+  ((bv-f64-ref bv n)               (&read-object &bytevector)  &type-check)
+
+  ((bv-u8-set! bv n x)             (&write-object &bytevector) &type-check)
+  ((bv-s8-set! bv n x)             (&write-object &bytevector) &type-check)
+  ((bv-u16-set! bv n x)            (&write-object &bytevector) &type-check)
+  ((bv-s16-set! bv n x)            (&write-object &bytevector) &type-check)
+  ((bv-u32-set! bv n x)            (&write-object &bytevector) &type-check)
+  ((bv-s32-set! bv n x)            (&write-object &bytevector) &type-check)
+  ((bv-u64-set! bv n x)            (&write-object &bytevector) &type-check)
+  ((bv-s64-set! bv n x)            (&write-object &bytevector) &type-check)
+  ((bv-f32-set! bv n x)            (&write-object &bytevector) &type-check)
+  ((bv-f64-set! bv n x)            (&write-object &bytevector) &type-check))
+
+;; Modules.
+(define-primitive-effects
+  ((current-module)                (&read-object &module))
+  ((cache-current-module! m scope) (&write-object &box))
+  ((resolve name bound?)           (&read-object &module)      &type-check)
+  ((cached-toplevel-box scope name bound?)                     &type-check)
+  ((cached-module-box mod name public? bound?)                 &type-check)
+  ((define! name val)              (&read-object &module) (&write-object &box)))
+
+;; Numbers.
+(define-primitive-effects
+  ((= . _)                         &type-check)
+  ((< . _)                         &type-check)
+  ((> . _)                         &type-check)
+  ((<= . _)                        &type-check)
+  ((>= . _)                        &type-check)
+  ((zero? . _)                     &type-check)
+  ((add . _)                       &type-check)
+  ((mul . _)                       &type-check)
+  ((sub . _)                       &type-check)
+  ((div . _)                       &type-check)
+  ((sub1 . _)                      &type-check)
+  ((add1 . _)                      &type-check)
+  ((quo . _)                       &type-check)
+  ((rem . _)                       &type-check)
+  ((mod . _)                       &type-check)
+  ((complex? _)                    &type-check)
+  ((real? _)                       &type-check)
+  ((rational? _)                   &type-check)
+  ((inf? _)                        &type-check)
+  ((nan? _)                        &type-check)
+  ((integer? _)                    &type-check)
+  ((exact? _)                      &type-check)
+  ((inexact? _)                    &type-check)
+  ((even? _)                       &type-check)
+  ((odd? _)                        &type-check)
+  ((ash n m)                       &type-check)
+  ((logand . _)                    &type-check)
+  ((logior . _)                    &type-check)
+  ((logxor . _)                    &type-check)
+  ((lognot . _)                    &type-check)
+  ((logtest a b)                   &type-check)
+  ((logbit? a b)                   &type-check)
+  ((sqrt _)                        &type-check)
+  ((abs _)                         &type-check))
+
+;; Characters.
+(define-primitive-effects
+  ((char<? . _)                    &type-check)
+  ((char<=? . _)                   &type-check)
+  ((char>=? . _)                   &type-check)
+  ((char>? . _)                    &type-check)
+  ((integer->char _)               &type-check)
+  ((char->integer _)               &type-check))
+
+(define (primitive-effects dfg name args)
+  (let ((proc (hashq-ref *primitive-effects* name)))
+    (if proc
+        (apply proc dfg args)
+        &all-effects)))
+
+(define (expression-effects exp dfg)
+  (match exp
+    ((or ($ $const) ($ $prim) ($ $values))
+     &no-effects)
+    (($ $fun)
+     (&allocate &unknown-memory-kinds))
+    (($ $prompt)
+     (&write-object &prompt))
+    ((or ($ $call) ($ $callk))
+     &all-effects)
+    (($ $branch k exp)
+     (expression-effects exp dfg))
+    (($ $primcall name args)
+     (primitive-effects dfg name args))))
+
+(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
+                          (label-count (dfg-label-count dfg)))
+  (let ((effects (make-vector label-count &no-effects)))
+    (define (idx->label idx) (+ idx min-label))
+    (let lp ((n 0))
+      (when (< n label-count)
+        (vector-set!
+         effects
+         n
+         (match (lookup-cont (idx->label n) dfg)
+           (($ $kargs names syms body)
+            (expression-effects (find-expression body) dfg))
+           (($ $kreceive arity kargs)
+            (match arity
+              (($ $arity _ () #f () #f) &type-check)
+              (($ $arity () () _ () #f) (&allocate &pair))
+              (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
+           (($ $kfun) &type-check)
+           (($ $kclause) &type-check)
+           (($ $ktail) &no-effects)))
+        (lp (1+ n))))
+    effects))
+
+;; There is a way to abuse effects analysis in CSE to also do scalar
+;; replacement, effectively adding `car' and `cdr' expressions to `cons'
+;; expressions, and likewise with other constructors and setters.  This
+;; routine adds appropriate effects to `cons' and `set-car!' and the
+;; like.
+;;
+;; This doesn't affect CSE's ability to eliminate expressions, given
+;; that allocations aren't eliminated anyway, and the new effects will
+;; just cause the allocations not to commute with e.g. set-car!  which
+;; is what we want anyway.
+(define* (synthesize-definition-effects! effects dfg min-label #:optional
+                                         (label-count (vector-length effects)))
+  (define (label->idx label) (- label min-label))
+  (let lp ((label min-label))
+    (when (< label (+ min-label label-count))
+      (let* ((lidx (label->idx label))
+             (fx (vector-ref effects lidx)))
+        (unless (zero? (logand (logior &write &allocation) fx))
+          (vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
+        (lp (1+ label))))))