[bpt/guile.git] / module / language / cps / effects-analysis.scm

;;; 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 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))
  ((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 ($ $void) ($ $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))))))
Commit	Line	Data
d20b4a1c AW	1	;;; Effects analysis on CPS
d20b4a1c AW	2
36527695	3	;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
d20b4a1c 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	;;; Commentary:
	20	;;;
146c8e72 AW	21	;;; A helper module to compute the set of effects caused by an
	22	;;; expression. This information is useful when writing algorithms that
	23	;;; move code around, while preserving the semantics of an input
	24	;;; program.
d20b4a1c	25	;;;
146c8e72 AW	26	;;; The effects set is represented as an integer with three parts. The
	27	;;; low 4 bits indicate effects caused by an expression, as a bitfield.
	28	;;; The next 4 bits indicate the kind of memory accessed by the
	29	;;; expression, if it accesses mutable memory. Finally the rest of the
	30	;;; bits indicate the field in the object being accessed, if known, or
	31	;;; -1 for unknown.
d20b4a1c	32	;;;
146c8e72 AW	33	;;; In this way we embed a coarse type-based alias analysis in the
	34	;;; effects analysis. For example, a "car" call is modelled as causing
	35	;;; a read to field 0 on a &pair, and causing a &type-check effect. If
	36	;;; any intervening code sets the car of any pair, that will block
	37	;;; motion of the "car" call, because any write to field 0 of a pair is
	38	;;; seen by effects analysis as being a write to field 0 of all pairs.
d20b4a1c AW	39	;;;
	40	;;; Code:
	41
	42	(define-module (language cps effects-analysis)
	43	#:use-module (language cps)
	44	#:use-module (language cps dfg)
	45	#:use-module (ice-9 match)
	46	#:export (expression-effects
	47	compute-effects
6119a905	48	synthesize-definition-effects!
d20b4a1c	49
5d25fdae AW	50	&allocation
	51	&type-check
	52	&read
	53	&write
	54
d20b4a1c AW	55	&fluid
d20b4a1c AW	56	&prompt
d20b4a1c AW	57	&car
	58	&cdr
	59	&vector
	60	&box
	61	&module
	62	&struct
	63	&string
	64	&bytevector
5d25fdae AW	65
	66	&object
	67	&field
	68
	69	&allocate
	70	&read-object
	71	&read-field
	72	&write-object
	73	&write-field
d20b4a1c AW	74
	75	&no-effects
	76	&all-effects
d20b4a1c	77
d20b4a1c AW	78	exclude-effects
	79	effect-free?
	80	constant?
5d25fdae AW	81	causes-effect?
	82	causes-all-effects?
	83	effect-clobbers?))
d20b4a1c	84
5d25fdae	85	(define-syntax define-flags
d20b4a1c AW	86	(lambda (x)
d20b4a1c AW	87	(syntax-case x ()
5d25fdae AW	88	((_ all shift name ...)
	89	(let ((count (length #'(name ...))))
	90	(with-syntax (((n ...) (iota count))
	91	(count count))
	92	#'(begin
	93	(define-syntax name (identifier-syntax (ash 1 n)))
	94	...
	95	(define-syntax all (identifier-syntax (1- (ash 1 count))))
	96	(define-syntax shift (identifier-syntax count)))))))))
	97
e7f2fe1b AW	98	(define-syntax define-enumeration
	99	(lambda (x)
	100	(define (count-bits n)
	101	(let lp ((out 1))
	102	(if (< n (ash 1 (1- out)))
	103	out
	104	(lp (1+ out)))))
	105	(syntax-case x ()
	106	((_ mask shift name ...)
	107	(let* ((len (length #'(name ...)))
	108	(bits (count-bits len)))
	109	(with-syntax (((n ...) (iota len))
	110	(bits bits))
	111	#'(begin
	112	(define-syntax name (identifier-syntax n))
	113	...
	114	(define-syntax mask (identifier-syntax (1- (ash 1 bits))))
	115	(define-syntax shift (identifier-syntax bits)))))))))
	116
5d25fdae AW	117	(define-flags &all-effect-kinds &effect-kind-bits
	118	;; Indicates that an expression may cause a type check. A type check,
	119	;; for the purposes of this analysis, is the possibility of throwing
	120	;; an exception the first time an expression is evaluated. If the
	121	;; expression did not cause an exception to be thrown, users can
	122	;; assume that evaluating the expression again will not cause an
	123	;; exception to be thrown.
	124	;;
	125	;; For example, (+ x y) might throw if X or Y are not numbers. But if
	126	;; it doesn't throw, it should be safe to elide a dominated, common
	127	;; subexpression (+ x y).
	128	&type-check
	129
	130	;; Indicates that an expression may return a fresh object. The kind
	131	;; of object is indicated in the object kind field.
	132	&allocation
	133
	134	;; Indicates that an expression may cause a read from memory. The
	135	;; kind of memory is given in the object kind field. Some object
	136	;; kinds have finer-grained fields; those are expressed in the "field"
	137	;; part of the effects value. -1 indicates "the whole object".
	138	&read
	139
	140	;; Indicates that an expression may cause a write to memory.
	141	&write)
	142
e7f2fe1b AW	143	(define-enumeration &memory-kind-mask &memory-kind-bits
	144	;; Indicates than an expression may access unknown kinds of memory.
	145	&unknown-memory-kinds
	146
5d25fdae AW	147	;; Indicates that an expression depends on the value of a fluid
	148	;; variable, or on the current fluid environment.
	149	&fluid
	150
	151	;; Indicates that an expression depends on the current prompt
	152	;; stack.
	153	&prompt
	154
	155	;; Indicates that an expression depends on the value of the car or cdr
	156	;; of a pair.
	157	&pair
	158
	159	;; Indicates that an expression depends on the value of a vector
	160	;; field. The effect field indicates the specific field, or zero for
	161	;; an unknown field.
	162	&vector
	163
	164	;; Indicates that an expression depends on the value of a variable
	165	;; cell.
	166	&box
	167
	168	;; Indicates that an expression depends on the current module.
	169	&module
	170
	171	;; Indicates that an expression depends on the value of a struct
	172	;; field. The effect field indicates the specific field, or zero for
	173	;; an unknown field.
	174	&struct
	175
	176	;; Indicates that an expression depends on the contents of a string.
	177	&string
	178
	179	;; Indicates that an expression depends on the contents of a
	180	;; bytevector. We cannot be more precise, as bytevectors may alias
	181	;; other bytevectors.
	182	&bytevector)
	183
	184	(define-inlinable (&field kind field)
	185	(ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
	186	(define-inlinable (&object kind)
	187	(&field kind -1))
	188
	189	(define-inlinable (&allocate kind)
	190	(logior &allocation (&object kind)))
	191	(define-inlinable (&read-field kind field)
	192	(logior &read (&field kind field)))
	193	(define-inlinable (&read-object kind)
	194	(logior &read (&object kind)))
	195	(define-inlinable (&write-field kind field)
	196	(logior &write (&field kind field)))
	197	(define-inlinable (&write-object kind)
	198	(logior &write (&object kind)))
d20b4a1c AW	199
d20b4a1c AW	200	(define-syntax &no-effects (identifier-syntax 0))
5d25fdae AW	201	(define-syntax &all-effects
5d25fdae AW	202	(identifier-syntax
e7f2fe1b	203	(logior &all-effect-kinds (&object &unknown-memory-kinds))))
d20b4a1c	204
cfb42b4c	205	(define-inlinable (constant? effects)
d20b4a1c	206	(zero? effects))
d20b4a1c	207
5d25fdae AW	208	(define-inlinable (causes-effect? x effects)
	209	(not (zero? (logand x effects))))
	210
	211	(define-inlinable (causes-all-effects? x)
	212	(eqv? x &all-effects))
	213
	214	(define (effect-clobbers? a b)
	215	"Return true if A clobbers B. This is the case if A is a write, and B
	216	is or might be a read or a write to the same location as A."
	217	(define (locations-same?)
e7f2fe1b AW	218	(let ((a (ash a (- &effect-kind-bits)))
	219	(b (ash b (- &effect-kind-bits))))
	220	(or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
	221	(eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
	222	(and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
	223	;; A negative field indicates "the whole object".
	224	;; Non-negative fields indicate only part of the object.
	225	(or (< a 0) (< b 0) (= a b))))))
5d25fdae AW	226	(and (not (zero? (logand a &write)))
	227	(not (zero? (logand b (logior &read &write))))
	228	(locations-same?)))
d20b4a1c AW	229
	230	(define (lookup-constant-index sym dfg)
	231	(call-with-values (lambda () (find-constant-value sym dfg))
	232	(lambda (has-const? val)
	233	(and has-const? (integer? val) (exact? val) (<= 0 val) val))))
	234
5d25fdae AW	235	(define-inlinable (indexed-field kind n dfg)
	236	(cond
	237	((lookup-constant-index n dfg)
	238	=> (lambda (idx)
	239	(&field kind idx)))
	240	(else (&object kind))))
	241
d20b4a1c AW	242	(define primitive-effects (make-hash-table))
d20b4a1c AW	243
5d25fdae AW	244	(define-syntax-rule (define-primitive-effects* dfg
	245	((name . args) effects ...)
	246	...)
d20b4a1c AW	247	(begin
d20b4a1c AW	248	(hashq-set! primitive-effects 'name
5d25fdae AW	249	(case-lambda*
	250	((dfg . args) (logior effects ...))
	251	(_ &all-effects)))
d20b4a1c AW	252	...))
d20b4a1c AW	253
5d25fdae AW	254	(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
5d25fdae AW	255	(define-primitive-effects* dfg ((name . args) effects ...) ...))
d20b4a1c AW	256
	257	;; Miscellaneous.
	258	(define-primitive-effects
ae67b159	259	((values . _)))
d20b4a1c	260
5d25fdae	261	;; Generic effect-free predicates.
d20b4a1c	262	(define-primitive-effects
5d25fdae AW	263	((eq? . _))
	264	((eqv? . _))
	265	((equal? . _))
	266	((pair? arg))
	267	((null? arg))
	268	((nil? arg ))
	269	((symbol? arg))
	270	((variable? arg))
	271	((vector? arg))
	272	((struct? arg))
	273	((string? arg))
	274	((number? arg))
	275	((char? arg))
	276	((procedure? arg))
	277	((thunk? arg)))
d20b4a1c AW	278
	279	;; Fluids.
	280	(define-primitive-effects
5d25fdae AW	281	((fluid-ref f) (&read-object &fluid) &type-check)
	282	((fluid-set! f v) (&write-object &fluid) &type-check)
	283	((push-fluid f v) (&write-object &fluid) &type-check)
	284	((pop-fluid) (&write-object &fluid) &type-check))
d20b4a1c AW	285
	286	;; Prompts.
	287	(define-primitive-effects
e7f2fe1b	288	((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
d20b4a1c	289
d20b4a1c AW	290	;; Pairs.
d20b4a1c AW	291	(define-primitive-effects
5d25fdae AW	292	((cons a b) (&allocate &pair))
	293	((list . _) (&allocate &pair))
	294	((car x) (&read-field &pair 0) &type-check)
	295	((set-car! x y) (&write-field &pair 0) &type-check)
	296	((cdr x) (&read-field &pair 1) &type-check)
	297	((set-cdr! x y) (&write-field &pair 1) &type-check)
	298	((memq x y) (&read-object &pair) &type-check)
	299	((memv x y) (&read-object &pair) &type-check)
	300	((list? arg) (&read-field &pair 1))
	301	((length l) (&read-field &pair 1) &type-check))
d20b4a1c AW	302
	303	;; Variables.
	304	(define-primitive-effects
5d25fdae AW	305	((box v) (&allocate &box))
	306	((box-ref v) (&read-object &box) &type-check)
	307	((box-set! v x) (&write-object &box) &type-check))
	308
	309	;; Vectors.
	310	(define (vector-field n dfg)
	311	(indexed-field &vector n dfg))
	312	(define (read-vector-field n dfg)
	313	(logior &read (vector-field n dfg)))
	314	(define (write-vector-field n dfg)
	315	(logior &write (vector-field n dfg)))
	316	(define-primitive-effects* dfg
	317	((vector . _) (&allocate &vector))
	318	((make-vector n init) (&allocate &vector) &type-check)
	319	((make-vector/immediate n init) (&allocate &vector))
	320	((vector-ref v n) (read-vector-field n dfg) &type-check)
	321	((vector-ref/immediate v n) (read-vector-field n dfg) &type-check)
	322	((vector-set! v n x) (write-vector-field n dfg) &type-check)
	323	((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check)
	324	((vector-length v) &type-check))
d20b4a1c AW	325
d20b4a1c AW	326	;; Structs.
5d25fdae AW	327	(define (struct-field n dfg)
	328	(indexed-field &struct n dfg))
	329	(define (read-struct-field n dfg)
	330	(logior &read (struct-field n dfg)))
	331	(define (write-struct-field n dfg)
	332	(logior &write (struct-field n dfg)))
d20b4a1c	333	(define-primitive-effects* dfg
5d25fdae AW	334	((allocate-struct vt n) (&allocate &struct) &type-check)
	335	((allocate-struct/immediate v n) (&allocate &struct) &type-check)
	336	((make-struct vt ntail . _) (&allocate &struct) &type-check)
	337	((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
	338	((struct-ref s n) (read-struct-field n dfg) &type-check)
	339	((struct-ref/immediate s n) (read-struct-field n dfg) &type-check)
	340	((struct-set! s n x) (write-struct-field n dfg) &type-check)
	341	((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check)
	342	((struct-vtable s) &type-check))
d20b4a1c AW	343
	344	;; Strings.
	345	(define-primitive-effects
5d25fdae AW	346	((string-ref s n) (&read-object &string) &type-check)
	347	((string-set! s n c) (&write-object &string) &type-check)
	348	((number->string _) (&allocate &string) &type-check)
	349	((string->number _) (&read-object &string) &type-check)
	350	((string-length s) &type-check))
d20b4a1c AW	351
	352	;; Bytevectors.
	353	(define-primitive-effects
5d25fdae AW	354	((bytevector-length _) &type-check)
	355
	356	((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
	357	((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
	358	((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
	359	((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
	360	((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
	361	((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
	362	((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
	363	((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
	364	((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
	365	((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
	366
	367	((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
	368	((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
	369	((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
	370	((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
	371	((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
	372	((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
	373	((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
	374	((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
	375	((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
	376	((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
d20b4a1c	377
5d25fdae	378	;; Modules.
d20b4a1c	379	(define-primitive-effects
5d25fdae AW	380	((current-module) (&read-object &module))
	381	((cache-current-module! m scope) (&write-object &box))
	382	((resolve name bound?) (&read-object &module) &type-check)
	383	((cached-toplevel-box scope name bound?) &type-check)
	384	((cached-module-box mod name public? bound?) &type-check)
	385	((define! name val) (&read-object &module) (&write-object &box)))
d20b4a1c	386
5d25fdae	387	;; Numbers.
d20b4a1c	388	(define-primitive-effects
5d25fdae AW	389	((= . _) &type-check)
	390	((< . _) &type-check)
	391	((> . _) &type-check)
	392	((<= . _) &type-check)
	393	((>= . _) &type-check)
	394	((zero? . _) &type-check)
	395	((add . _) &type-check)
	396	((mul . _) &type-check)
	397	((sub . _) &type-check)
	398	((div . _) &type-check)
	399	((sub1 . _) &type-check)
	400	((add1 . _) &type-check)
	401	((quo . _) &type-check)
	402	((rem . _) &type-check)
	403	((mod . _) &type-check)
	404	((complex? _) &type-check)
	405	((real? _) &type-check)
	406	((rational? _) &type-check)
	407	((inf? _) &type-check)
	408	((nan? _) &type-check)
	409	((integer? _) &type-check)
	410	((exact? _) &type-check)
	411	((inexact? _) &type-check)
	412	((even? _) &type-check)
	413	((odd? _) &type-check)
	414	((ash n m) &type-check)
	415	((logand . _) &type-check)
	416	((logior . _) &type-check)
	417	((logxor . _) &type-check)
	418	((lognot . _) &type-check)
8006d2d6 AW	419	((logtest a b) &type-check)
8006d2d6 AW	420	((logbit? a b) &type-check)
5d25fdae AW	421	((sqrt _) &type-check)
5d25fdae AW	422	((abs _) &type-check))
d20b4a1c	423
5d25fdae	424	;; Characters.
d20b4a1c	425	(define-primitive-effects
5d25fdae AW	426	((char<? . _) &type-check)
	427	((char<=? . _) &type-check)
	428	((char>=? . _) &type-check)
	429	((char>? . _) &type-check)
	430	((integer->char _) &type-check)
	431	((char->integer _) &type-check))
d20b4a1c AW	432
	433	(define (primitive-effects dfg name args)
	434	(let ((proc (hashq-ref primitive-effects name)))
	435	(if proc
	436	(apply proc dfg args)
5d25fdae	437	&all-effects)))
d20b4a1c AW	438
	439	(define (expression-effects exp dfg)
	440	(match exp
	441	((or ($ $void) ($ $const) ($ $prim) ($ $values))
	442	&no-effects)
	443	(($ $fun)
e7f2fe1b	444	(&allocate &unknown-memory-kinds))
d20b4a1c	445	(($ $prompt)
e7f2fe1b	446	(&write-object &prompt))
b3ae2b50	447	((or ($ $call) ($ $callk))
5d25fdae	448	&all-effects)
92805e21 AW	449	(($ $branch k exp)
92805e21 AW	450	(expression-effects exp dfg))
d20b4a1c AW	451	(($ $primcall name args)
	452	(primitive-effects dfg name args))))
	453
3269e1b6 AW	454	(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
	455	(label-count (dfg-label-count dfg)))
	456	(let ((effects (make-vector label-count &no-effects)))
	457	(define (idx->label idx) (+ idx min-label))
d20b4a1c	458	(let lp ((n 0))
3269e1b6	459	(when (< n label-count)
d20b4a1c AW	460	(vector-set!
	461	effects
	462	n
3269e1b6	463	(match (lookup-cont (idx->label n) dfg)
d20b4a1c AW	464	(($ $kargs names syms body)
d20b4a1c AW	465	(expression-effects (find-expression body) dfg))
36527695	466	(($ $kreceive arity kargs)
d20b4a1c	467	(match arity
5d25fdae AW	468	(($ $arity _ () #f () #f) &type-check)
	469	(($ $arity () () _ () #f) (&allocate &pair))
	470	(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
5d25fdae AW	471	(($ $kfun) &type-check)
5d25fdae AW	472	(($ $kclause) &type-check)
d20b4a1c AW	473	(($ $ktail) &no-effects)))
	474	(lp (1+ n))))
	475	effects))
6119a905 AW	476
	477	;; There is a way to abuse effects analysis in CSE to also do scalar
	478	;; replacement, effectively adding `car' and `cdr' expressions to `cons'
	479	;; expressions, and likewise with other constructors and setters. This
	480	;; routine adds appropriate effects to `cons' and `set-car!' and the
	481	;; like.
	482	;;
	483	;; This doesn't affect CSE's ability to eliminate expressions, given
	484	;; that allocations aren't eliminated anyway, and the new effects will
	485	;; just cause the allocations not to commute with e.g. set-car! which
	486	;; is what we want anyway.
	487	(define* (synthesize-definition-effects! effects dfg min-label #:optional
	488	(label-count (vector-length effects)))
	489	(define (label->idx label) (- label min-label))
	490	(let lp ((label min-label))
	491	(when (< label (+ min-label label-count))
	492	(let* ((lidx (label->idx label))
	493	(fx (vector-ref effects lidx)))
5d25fdae AW	494	(unless (zero? (logand (logior &write &allocation) fx))
5d25fdae AW	495	(vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
6119a905	496	(lp (1+ label))))))