FM / cps

/usr/share/guile/3.0/language/cps

Name	Size	Mode	Actions
closure-conversion.scm	38159	0644	edit dl rm
compile-bytecode.scm	32866	0644	edit dl rm
contification.scm	23824	0644	edit dl rm
cse.scm	33392	0644	edit dl rm
dce.scm	18456	0644	edit dl rm
devirtualize-integers.scm	11605	0644	edit dl rm
effects-analysis.scm	25138	0644	edit dl rm
elide-arity-checks.scm	4520	0644	edit dl rm
graphs.scm	10401	0644	edit dl rm
intmap.scm	29027	0644	edit dl rm
intset.scm	30298	0644	edit dl rm
licm.scm	15049	0644	edit dl rm
loop-instrumentation.scm	2613	0644	edit dl rm
optimize.scm	5730	0644	edit dl rm
peel-loops.scm	14868	0644	edit dl rm
prune-top-level-scopes.scm	2121	0644	edit dl rm
reify-primitives.scm	25205	0644	edit dl rm
renumber.scm	10457	0644	edit dl rm
rotate-loops.scm	10686	0644	edit dl rm
self-references.scm	3130	0644	edit dl rm
simplify.scm	10773	0644	edit dl rm
slot-allocation.scm	41846	0644	edit dl rm
spec.scm	1875	0644	edit dl rm
specialize-numbers.scm	44495	0644	edit dl rm
specialize-primcalls.scm	6871	0644	edit dl rm
split-rec.scm	7739	0644	edit dl rm
switch.scm	18438	0644	edit dl rm
type-checks.scm	3146	0644	edit dl rm
type-fold.scm	29158	0644	edit dl rm
types.scm	82504	0644	edit dl rm
utils.scm	14004	0644	edit dl rm
verify.scm	12703	0644	edit dl rm
with-cps.scm	5856	0644	edit dl rm

Edit: /usr/share/guile/3.0/language/cps/effects-analysis.scm (25138B)

;;; Effects analysis on CPS

;;;; 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 utils)
  #:use-module (language cps intset)
  #:use-module (language cps intmap)
  #:use-module (ice-9 match)
  #:export (expression-effects
            compute-effects
            synthesize-definition-effects

&allocation
            &type-check
            &read
            &write

&fluid
            &prompt
            &vector
            &box
            &module
            &struct
            &string
            &thread
            &bytevector
            &closure
            &header

&object
            &field

&allocate
            &read-object
            &read-field
            &write-object
            &write-field

&no-effects
            &all-effects

causes-effect?
            causes-all-effects?
            effect-clobbers?
            compute-clobber-map))

(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 current thread.
  &thread

;; 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

;; Indicates a dependency on a free variable of a closure.
  &closure

;; Indicates a dependency on a raw bitmask, measured in 32-bit units.
  &bitmask

;; Indicates a dependency on the value of a cache cell.
  &cache

;; Indicates that an expression depends on a value extracted from the
  ;; fixed, unchanging part of an object -- for example the length of a
  ;; vector or the vtable of a struct.
  &header)

(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 (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 (compute-clobber-map effects)
  "For the map LABEL->EFFECTS, compute a map LABEL->LABELS indicating
the LABELS that are clobbered by the effects of LABEL."
  (let ((clobbered-by-write (make-hash-table)))
    (intmap-fold
     (lambda (label fx)
       ;; Unless an expression causes a read, it isn't clobbered by
       ;; anything.
       (when (causes-effect? fx &read)
         (let ((me (intset label)))
           (define (add! kind field)
             (let* ((k (logior (ash field &memory-kind-bits) kind))
                    (clobber (hashv-ref clobbered-by-write k empty-intset)))
               (hashv-set! clobbered-by-write k (intset-union me clobber))))
           ;; Clobbered by write to specific field of this memory
           ;; kind, write to any field of this memory kind, or
           ;; write to any field of unknown memory kinds.
           (let* ((loc (ash fx (- &effect-kind-bits)))
                  (kind (logand loc &memory-kind-mask))
                  (field (ash loc (- &memory-kind-bits))))
             (add! kind field)
             (add! kind -1)
             (add! &unknown-memory-kinds -1))))
       (values))
     effects)
    (intmap-map (lambda (label fx)
                  (if (causes-effect? fx &write)
                      (hashv-ref clobbered-by-write
                                 (ash fx (- &effect-kind-bits))
                                 empty-intset)
                      empty-intset))
                effects)))

(define *primitive-effects* (make-hash-table))

(define-syntax-rule (define-primitive-effects* param
                      ((name . args) effects ...)
                      ...)
  (begin
    (hashq-set! *primitive-effects* 'name
                (case-lambda*
                 ((param . args) (logior effects ...))
                 (_ &all-effects)))
    ...))

(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
  (define-primitive-effects* param ((name . args) effects ...) ...))

;; Miscellaneous.
(define-primitive-effects
  ((load-const/unlikely))
  ((values . _)))

;; Generic effect-free predicates.
(define-primitive-effects
  ((eq? x y))
  ((equal? x y))
  ((fixnum? arg))
  ((char? arg))
  ((eq-constant? arg))
  ((undefined? arg))
  ((null? arg))
  ((false? arg))
  ((nil? arg))
  ((heap-object? arg))
  ((pair? arg))
  ((symbol? arg))
  ((variable? arg))
  ((vector? arg))
  ((struct? arg))
  ((string? arg))
  ((number? arg))
  ((bytevector? arg))
  ((keyword? arg))
  ((bitvector? arg))
  ((procedure? arg))
  ((thunk? arg))
  ((heap-number? arg))
  ((bignum? arg))
  ((flonum? arg))
  ((compnum? arg))
  ((fracnum? 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))
  ((push-dynamic-state state)      (&write-object &fluid)      &type-check)
  ((pop-dynamic-state)             (&write-object &fluid)))

;; Threads.  Calls cause &all-effects, which reflects the fact that any
;; call can capture a partial continuation and reinstate it on another
;; thread.
(define-primitive-effects
  ((current-thread)                (&read-object &thread)))

;; Prompts.
(define-primitive-effects
  ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))

;; Generic objects.
(define (annotation->memory-kind* annotation idx)
  (match (cons annotation idx)
    (('vector . 0) &header)
    (('string . (or 0 1 2 3)) &header)
    (('stringbuf . (or 0 1)) &header)
    (('bytevector . (or 0 1 2 3)) &header)
    (('symbol . (or 0 1 2)) &header)
    (('box . 0) &header)
    (('closure . (or 0 1)) &header)
    (('struct . 0) &header)
    (('atomic-box . 0) &header)
    (_ (annotation->memory-kind annotation))))

(define (annotation->memory-kind annotation)
  (match annotation
    ('pair &pair)
    ('vector &vector)
    ('string &string)
    ('stringbuf &string)
    ('symbol &unknown-memory-kinds)
    ('bytevector &bytevector)
    ('bitmask &bitmask)
    ('box &box)
    ('closure &closure)
    ('struct &struct)
    ('atomic-box &unknown-memory-kinds)))

(define-primitive-effects* param
  ((allocate-words size)           (&allocate (annotation->memory-kind param)))
  ((allocate-words/immediate)      (match param
                                     ((ann . size)
                                      (&allocate
                                       (annotation->memory-kind ann)))))
  ((allocate-pointerless-words size)
                                   (&allocate (annotation->memory-kind param)))
  ((allocate-pointerless-words/immediate)
                                   (match param
                                     ((ann . size)
                                      (&allocate
                                       (annotation->memory-kind ann)))))
  ((scm-ref obj idx)               (&read-object
                                    (annotation->memory-kind param)))
  ((scm-ref/tag obj)               (&read-field
                                    (annotation->memory-kind* param 0) 0))
  ((scm-ref/immediate obj)         (match param
                                     ((ann . idx)
                                      (&read-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((scm-set! obj idx val)          (&write-object
                                    (annotation->memory-kind param)))
  ((scm-set/tag! obj val)          (&write-field
                                    (annotation->memory-kind* param 0) 0))
  ((scm-set!/immediate obj val)    (match param
                                     ((ann . idx)
                                      (&write-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((word-ref obj idx)              (&read-object
                                    (annotation->memory-kind param)))
  ((word-ref/immediate obj)        (match param
                                     ((ann . idx)
                                      (&read-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((word-set! obj idx val)         (&read-object
                                    (annotation->memory-kind param)))
  ((word-set!/immediate obj val)   (match param
                                     ((ann . idx)
                                      (&write-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((pointer-ref/immediate obj)     (match param
                                     ((ann . idx)
                                      (&read-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((pointer-set!/immediate obj val)
                                   (match param
                                     ((ann . idx)
                                      (&write-field
                                       (annotation->memory-kind* ann idx) idx))))
  ((tail-pointer-ref/immediate obj)))

;; Strings.
(define-primitive-effects
  ((string-set! s n c)             (&write-object &string)     &type-check)
  ((number->string _)              (&allocate &string)         &type-check)
  ((string->number _)              (&read-object &string)      &type-check))

;; Unboxed floats and integers.
(define-primitive-effects
  ((scm->f64 _)                                                &type-check)
  ((load-f64))
  ((f64->scm _))
  ((scm->u64 _)                                                &type-check)
  ((scm->u64/truncate _)                                       &type-check)
  ((load-u64))
  ((u64->scm _))
  ((u64->scm/unlikely _))
  ((scm->s64 _)                                                &type-check)
  ((load-s64))
  ((s64->scm _))
  ((s64->scm/unlikely _))
  ((u64->s64 _))
  ((s64->u64 _))
  ((assume-u64 _))
  ((assume-s64 _))
  ((untag-fixnum _))
  ((tag-fixnum _))
  ((tag-fixnum/unlikely _)))

;; Pointers.
(define-primitive-effects* param
  ((u8-ref obj bv n)               (&read-object (annotation->memory-kind param)))
  ((s8-ref obj bv n)               (&read-object (annotation->memory-kind param)))
  ((u16-ref obj bv n)              (&read-object (annotation->memory-kind param)))
  ((s16-ref obj bv n)              (&read-object (annotation->memory-kind param)))
  ((u32-ref obj bv n)              (&read-object (annotation->memory-kind param)))
  ((s32-ref obj bv n)              (&read-object (annotation->memory-kind param)))
  ((u64-ref obj bv n)              (&read-object (annotation->memory-kind param)))
  ((s64-ref obj bv n)              (&read-object (annotation->memory-kind param)))
  ((f32-ref obj bv n)              (&read-object (annotation->memory-kind param)))
  ((f64-ref obj bv n)              (&read-object (annotation->memory-kind param)))

((u8-set! obj bv n x)            (&write-object (annotation->memory-kind param)))
  ((s8-set! obj bv n x)            (&write-object (annotation->memory-kind param)))
  ((u16-set! obj bv n x)           (&write-object (annotation->memory-kind param)))
  ((s16-set! obj bv n x)           (&write-object (annotation->memory-kind param)))
  ((u32-set! obj bv n x)           (&write-object (annotation->memory-kind param)))
  ((s32-set! obj bv n x)           (&write-object (annotation->memory-kind param)))
  ((u64-set! obj bv n x)           (&write-object (annotation->memory-kind param)))
  ((s64-set! obj bv n x)           (&write-object (annotation->memory-kind param)))
  ((f32-set! obj bv n x)           (&write-object (annotation->memory-kind param)))
  ((f64-set! obj bv n x)           (&write-object (annotation->memory-kind param))))

;; Modules.
(define-primitive-effects
  ((current-module)                (&read-object &module))
  ((cache-current-module! m)       (&write-object &cache))
  ((resolve name)                  (&read-object &module)      &type-check)
  ((resolve-module mod)            (&read-object &module)      &type-check)
  ((module-variable mod name)      (&read-object &module)      &type-check)
  ((lookup mod name)               (&read-object &module)      &type-check)
  ((lookup-bound mod name)         (&read-object &module)      &type-check)
  ((lookup-bound-public)                                       &type-check)
  ((lookup-bound-private)                                      &type-check)
  ((cached-toplevel-box)                                       &type-check)
  ((cached-module-box)                                         &type-check)
  ((define! mod name)              (&read-object &module)))

;; Cache cells.
(define-primitive-effects
  ((cache-ref)                     (&read-object &cache))
  ((cache-set! x)                  (&write-object &cache)))

;; Numbers.
(define-primitive-effects
  ((heap-numbers-equal? . _))
  ((= . _)                         &type-check)
  ((<= . _)                         &type-check)
  ((< . _)                         &type-check)
  ((u64-= . _))
  ((u64-imm-= . _))
  ((u64-< . _))
  ((u64-imm-< . _))
  ((imm-u64-< . _))
  ((s64-= . _))
  ((s64-imm-= . _))
  ((s64-< . _))
  ((s64-imm-< . _))
  ((imm-s64-< . _))
  ((f64-= . _))
  ((f64-< . _))
  ((f64-<= . _))
  ((zero? . _)                     &type-check)
  ((add . _)                       &type-check)
  ((add/immediate . _)             &type-check)
  ((mul . _)                       &type-check)
  ((sub . _)                       &type-check)
  ((sub/immediate . _)             &type-check)
  ((div . _)                       &type-check)
  ((fadd . _))
  ((fsub . _))
  ((fmul . _))
  ((fdiv . _))
  ((uadd . _))
  ((usub . _))
  ((umul . _))
  ((uadd/immediate . _))
  ((usub/immediate . _))
  ((umul/immediate . _))
  ((sadd . _))
  ((ssub . _))
  ((smul . _))
  ((sadd/immediate . _))
  ((ssub/immediate . _))
  ((smul/immediate . _))
  ((quo . _)                       &type-check)
  ((rem . _)                       &type-check)
  ((mod . _)                       &type-check)
  ((inexact _)                     &type-check)
  ((s64->f64 _))
  ((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)
  ((rsh n m)                       &type-check)
  ((lsh n m)                       &type-check)
  ((rsh/immediate n)               &type-check)
  ((lsh/immediate n)               &type-check)
  ((logand . _)                    &type-check)
  ((logior . _)                    &type-check)
  ((logxor . _)                    &type-check)
  ((logsub . _)                    &type-check)
  ((lognot . _)                    &type-check)
  ((ulogand . _))
  ((ulogior . _))
  ((ulogxor . _))
  ((ulogsub . _))
  ((ursh . _))
  ((srsh . _))
  ((ulsh . _))
  ((slsh . _))
  ((ursh/immediate . _))
  ((srsh/immediate . _))
  ((ulsh/immediate . _))
  ((slsh/immediate . _))
  ((logtest a b)                   &type-check)
  ((logbit? a b)                   &type-check)
  ((sqrt _)                        &type-check)
  ((abs _)                         &type-check)
  ((floor _)                       &type-check)
  ((ceiling _)                     &type-check)
  ((sin _)                         &type-check)
  ((cos _)                         &type-check)
  ((tan _)                         &type-check)
  ((asin _)                        &type-check)
  ((acos _)                        &type-check)
  ((atan _)                        &type-check)
  ((atan2 x y)                     &type-check)
  ((fsqrt _))
  ((fabs _))
  ((ffloor _))
  ((fceiling _))
  ((fsin _))
  ((fcos _))
  ((ftan _))
  ((fasin _))
  ((facos _))
  ((fatan _))
  ((fatan2 x y)))

;; Characters.
(define-primitive-effects
  ((untag-char _))
  ((tag-char _)))

;; Atomics are a memory and a compiler barrier; they cause all effects
;; so no need to have a case for them here.  (Though, see
;; https://jfbastien.github.io/no-sane-compiler/.)

(define (primitive-effects param name args)
  (let ((proc (hashq-ref *primitive-effects* name)))
    (if proc
        (apply proc param args)
        &all-effects)))

(define (expression-effects exp)
  (match exp
    ((or ($ $const) ($ $prim) ($ $values) ($ $code) ($ $const-fun))
     &no-effects)
    ((or ($ $fun) ($ $rec))
     (&allocate &unknown-memory-kinds))
    ((or ($ $call) ($ $callk))
     &all-effects)
    (($ $primcall name param args)
     (primitive-effects param name args))))

(define (compute-effects conts)
  (intmap-map
   (lambda (label cont)
     (match cont
       (($ $kargs names syms ($ $continue k src exp))
        (expression-effects exp))
       (($ $kargs names syms ($ $branch kf kt src op param args))
        (primitive-effects param op args))
       (($ $kargs names syms ($ $switch)) &no-effects)
       (($ $kargs names syms ($ $prompt))
        ;; Although the "main" path just writes &prompt, we don't know
        ;; what nonlocal predecessors of the handler do, so we
        ;; conservatively assume &all-effects.
        &all-effects)
       (($ $kargs names syms ($ $throw))
        ;; A reachable "throw" term can never be elided.
        &all-effects)
       (($ $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)))
   conts))

;; 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)
  (intmap-map (lambda (label fx)
                (if (logtest (logior &write &allocation) fx)
                    (logior fx &read)
                    fx))
              effects))

cmd: