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

;;; 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))))))
Commit	Line	Data
d20b4a1c AW	1	;;; Effects analysis on CPS
d20b4a1c AW	2
e2fafeb9	3	;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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))
e2fafeb9 AW	276	((bytevector? arg))
	277	((keyword? arg))
	278	((bitvector? arg))
5d25fdae AW	279	((procedure? arg))
5d25fdae AW	280	((thunk? arg)))
d20b4a1c AW	281
	282	;; Fluids.
	283	(define-primitive-effects
5d25fdae AW	284	((fluid-ref f) (&read-object &fluid) &type-check)
	285	((fluid-set! f v) (&write-object &fluid) &type-check)
	286	((push-fluid f v) (&write-object &fluid) &type-check)
	287	((pop-fluid) (&write-object &fluid) &type-check))
d20b4a1c AW	288
	289	;; Prompts.
	290	(define-primitive-effects
e7f2fe1b	291	((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
d20b4a1c	292
d20b4a1c AW	293	;; Pairs.
d20b4a1c AW	294	(define-primitive-effects
5d25fdae AW	295	((cons a b) (&allocate &pair))
	296	((list . _) (&allocate &pair))
	297	((car x) (&read-field &pair 0) &type-check)
	298	((set-car! x y) (&write-field &pair 0) &type-check)
	299	((cdr x) (&read-field &pair 1) &type-check)
	300	((set-cdr! x y) (&write-field &pair 1) &type-check)
	301	((memq x y) (&read-object &pair) &type-check)
	302	((memv x y) (&read-object &pair) &type-check)
	303	((list? arg) (&read-field &pair 1))
	304	((length l) (&read-field &pair 1) &type-check))
d20b4a1c AW	305
	306	;; Variables.
	307	(define-primitive-effects
5d25fdae AW	308	((box v) (&allocate &box))
	309	((box-ref v) (&read-object &box) &type-check)
	310	((box-set! v x) (&write-object &box) &type-check))
	311
	312	;; Vectors.
	313	(define (vector-field n dfg)
	314	(indexed-field &vector n dfg))
	315	(define (read-vector-field n dfg)
	316	(logior &read (vector-field n dfg)))
	317	(define (write-vector-field n dfg)
	318	(logior &write (vector-field n dfg)))
	319	(define-primitive-effects* dfg
	320	((vector . _) (&allocate &vector))
	321	((make-vector n init) (&allocate &vector) &type-check)
	322	((make-vector/immediate n init) (&allocate &vector))
	323	((vector-ref v n) (read-vector-field n dfg) &type-check)
	324	((vector-ref/immediate v n) (read-vector-field n dfg) &type-check)
	325	((vector-set! v n x) (write-vector-field n dfg) &type-check)
	326	((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check)
	327	((vector-length v) &type-check))
d20b4a1c AW	328
d20b4a1c AW	329	;; Structs.
5d25fdae AW	330	(define (struct-field n dfg)
	331	(indexed-field &struct n dfg))
	332	(define (read-struct-field n dfg)
	333	(logior &read (struct-field n dfg)))
	334	(define (write-struct-field n dfg)
	335	(logior &write (struct-field n dfg)))
d20b4a1c	336	(define-primitive-effects* dfg
5d25fdae AW	337	((allocate-struct vt n) (&allocate &struct) &type-check)
	338	((allocate-struct/immediate v n) (&allocate &struct) &type-check)
	339	((make-struct vt ntail . _) (&allocate &struct) &type-check)
	340	((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
	341	((struct-ref s n) (read-struct-field n dfg) &type-check)
	342	((struct-ref/immediate s n) (read-struct-field n dfg) &type-check)
	343	((struct-set! s n x) (write-struct-field n dfg) &type-check)
	344	((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check)
	345	((struct-vtable s) &type-check))
d20b4a1c AW	346
	347	;; Strings.
	348	(define-primitive-effects
5d25fdae AW	349	((string-ref s n) (&read-object &string) &type-check)
	350	((string-set! s n c) (&write-object &string) &type-check)
	351	((number->string _) (&allocate &string) &type-check)
	352	((string->number _) (&read-object &string) &type-check)
	353	((string-length s) &type-check))
d20b4a1c AW	354
	355	;; Bytevectors.
	356	(define-primitive-effects
5d25fdae AW	357	((bytevector-length _) &type-check)
	358
	359	((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
	360	((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
	361	((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
	362	((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
	363	((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
	364	((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
	365	((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
	366	((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
	367	((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
	368	((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
	369
	370	((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
	371	((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
	372	((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
	373	((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
	374	((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
	375	((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
	376	((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
	377	((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
	378	((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
	379	((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
d20b4a1c	380
5d25fdae	381	;; Modules.
d20b4a1c	382	(define-primitive-effects
5d25fdae AW	383	((current-module) (&read-object &module))
	384	((cache-current-module! m scope) (&write-object &box))
	385	((resolve name bound?) (&read-object &module) &type-check)
	386	((cached-toplevel-box scope name bound?) &type-check)
	387	((cached-module-box mod name public? bound?) &type-check)
	388	((define! name val) (&read-object &module) (&write-object &box)))
d20b4a1c	389
5d25fdae	390	;; Numbers.
d20b4a1c	391	(define-primitive-effects
5d25fdae AW	392	((= . _) &type-check)
	393	((< . _) &type-check)
	394	((> . _) &type-check)
	395	((<= . _) &type-check)
	396	((>= . _) &type-check)
	397	((zero? . _) &type-check)
	398	((add . _) &type-check)
	399	((mul . _) &type-check)
	400	((sub . _) &type-check)
	401	((div . _) &type-check)
	402	((sub1 . _) &type-check)
	403	((add1 . _) &type-check)
	404	((quo . _) &type-check)
	405	((rem . _) &type-check)
	406	((mod . _) &type-check)
	407	((complex? _) &type-check)
	408	((real? _) &type-check)
	409	((rational? _) &type-check)
	410	((inf? _) &type-check)
	411	((nan? _) &type-check)
	412	((integer? _) &type-check)
	413	((exact? _) &type-check)
	414	((inexact? _) &type-check)
	415	((even? _) &type-check)
	416	((odd? _) &type-check)
	417	((ash n m) &type-check)
	418	((logand . _) &type-check)
	419	((logior . _) &type-check)
	420	((logxor . _) &type-check)
	421	((lognot . _) &type-check)
8006d2d6 AW	422	((logtest a b) &type-check)
8006d2d6 AW	423	((logbit? a b) &type-check)
5d25fdae AW	424	((sqrt _) &type-check)
5d25fdae AW	425	((abs _) &type-check))
d20b4a1c	426
5d25fdae	427	;; Characters.
d20b4a1c	428	(define-primitive-effects
5d25fdae AW	429	((char<? . _) &type-check)
	430	((char<=? . _) &type-check)
	431	((char>=? . _) &type-check)
	432	((char>? . _) &type-check)
	433	((integer->char _) &type-check)
	434	((char->integer _) &type-check))
d20b4a1c AW	435
	436	(define (primitive-effects dfg name args)
	437	(let ((proc (hashq-ref primitive-effects name)))
	438	(if proc
	439	(apply proc dfg args)
5d25fdae	440	&all-effects)))
d20b4a1c AW	441
	442	(define (expression-effects exp dfg)
	443	(match exp
a9ec16f9	444	((or ($ $const) ($ $prim) ($ $values))
d20b4a1c AW	445	&no-effects)
d20b4a1c AW	446	(($ $fun)
e7f2fe1b	447	(&allocate &unknown-memory-kinds))
d20b4a1c	448	(($ $prompt)
e7f2fe1b	449	(&write-object &prompt))
b3ae2b50	450	((or ($ $call) ($ $callk))
5d25fdae	451	&all-effects)
92805e21 AW	452	(($ $branch k exp)
92805e21 AW	453	(expression-effects exp dfg))
d20b4a1c AW	454	(($ $primcall name args)
	455	(primitive-effects dfg name args))))
	456
3269e1b6 AW	457	(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
	458	(label-count (dfg-label-count dfg)))
	459	(let ((effects (make-vector label-count &no-effects)))
	460	(define (idx->label idx) (+ idx min-label))
d20b4a1c	461	(let lp ((n 0))
3269e1b6	462	(when (< n label-count)
d20b4a1c AW	463	(vector-set!
	464	effects
	465	n
3269e1b6	466	(match (lookup-cont (idx->label n) dfg)
d20b4a1c AW	467	(($ $kargs names syms body)
d20b4a1c AW	468	(expression-effects (find-expression body) dfg))
36527695	469	(($ $kreceive arity kargs)
d20b4a1c	470	(match arity
5d25fdae AW	471	(($ $arity _ () #f () #f) &type-check)
	472	(($ $arity () () _ () #f) (&allocate &pair))
	473	(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
5d25fdae AW	474	(($ $kfun) &type-check)
5d25fdae AW	475	(($ $kclause) &type-check)
d20b4a1c AW	476	(($ $ktail) &no-effects)))
	477	(lp (1+ n))))
	478	effects))
6119a905 AW	479
	480	;; There is a way to abuse effects analysis in CSE to also do scalar
	481	;; replacement, effectively adding `car' and `cdr' expressions to `cons'
	482	;; expressions, and likewise with other constructors and setters. This
	483	;; routine adds appropriate effects to `cons' and `set-car!' and the
	484	;; like.
	485	;;
	486	;; This doesn't affect CSE's ability to eliminate expressions, given
	487	;; that allocations aren't eliminated anyway, and the new effects will
	488	;; just cause the allocations not to commute with e.g. set-car! which
	489	;; is what we want anyway.
	490	(define* (synthesize-definition-effects! effects dfg min-label #:optional
	491	(label-count (vector-length effects)))
	492	(define (label->idx label) (- label min-label))
	493	(let lp ((label min-label))
	494	(when (< label (+ min-label label-count))
	495	(let* ((lidx (label->idx label))
	496	(fx (vector-ref effects lidx)))
5d25fdae AW	497	(unless (zero? (logand (logior &write &allocation) fx))
5d25fdae AW	498	(vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
6119a905	499	(lp (1+ label))))))