mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 20:40:29 +02:00
Code Activity

Rewrite effects analysis to be precise for fields.

Browse source 
* module/language/cps/effects-analysis.scm: Rewrite so that instead of
  the depends/causes effects, there is just &type-check, &allocation,
  &read, and &write.  The object kind is a separate part of the
  bitfield, and the field in the object (if appropriate) is another
  field.  Effects are still a fixnum.  This enables precise effects for
  vectors and structs on all architectures.

  This kind of effects analysis was not possible in Tree-IL because
  Tree-IL relied on logior-ing effects of subexpressions, whereas with
  CPS we have no sub-expressions and we do flow analysis instead.

  (effect-clobbers?): Replace effects-commute? with this inherently
  directional and precise predicate.

* module/language/cps/cse.scm (compute-always-available-expressions):
  (compute-equivalent-subexpressions): Adapt to effects analysis
  change.
* module/language/cps/dce.scm (compute-live-code): Likewise.
This commit is contained in:
Andy Wingo 2014-05-08 10:39:49 +02:00
parent 466bdf7ee3
commit 5d25fdae37
3 changed files with 314 additions and 390 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/language/cps/cse.scm
View file

@ -33,13 +33,14 @@
(define (compute-always-available-expressions effects) (define (compute-always-available-expressions effects)
"Return the set of continuations whose values are always available "Return the set of continuations whose values are always available
within their dominance frontier. This is the case for effects that have within their dominance frontier. This is the case for effects that do
no dependencies and which cause no effects besides &type-check." not allocate, read, or write mutable memory."
(let ((out (make-bitvector (vector-length effects) #f))) (let ((out (make-bitvector (vector-length effects) #f)))
(let lp ((n 0)) (let lp ((n 0))
(cond (cond
((< n (vector-length effects)) ((< n (vector-length effects))
(when (constant? (exclude-effects (vector-ref effects n) &type-check)) (unless (causes-effect? (vector-ref effects n)
(logior &allocation &read &write))
(bitvector-set! out n #t)) (bitvector-set! out n #t))
(lp (1+ n))) (lp (1+ n)))
(else out))))) (else out)))))
@ -104,10 +105,10 @@ index corresponds to MIN-LABEL, and so on."
(bitvector-copy! out in) (bitvector-copy! out in)
;; Kill expressions that don't commute. ;; Kill expressions that don't commute.
(cond (cond
((causes-all-effects? fx &all-effects) ((causes-all-effects? fx)
;; Fast-path if this expression clobbers the world. ;; Fast-path if this expression clobbers the world.
(intersect! out always-avail)) (intersect! out always-avail))
((effect-free? (exclude-effects fx &type-check)) ((not (causes-effect? fx &write))
;; Fast-path if this expression clobbers nothing. ;; Fast-path if this expression clobbers nothing.
#t) #t)
(else (else
@ -117,7 +118,7 @@ index corresponds to MIN-LABEL, and so on."
(let lp ((i 0)) (let lp ((i 0))
(let ((i (bit-position #t tmp i))) (let ((i (bit-position #t tmp i)))
(when i (when i
(unless (effects-commute? (vector-ref effects i) fx) (when (effect-clobbers? fx (vector-ref effects i))
(bitvector-set! out i #f)) (bitvector-set! out i #f))
(lp (1+ i)))))))) (lp (1+ i))))))))
(bitvector-set! out n #t) (bitvector-set! out n #t)
@ -412,6 +413,7 @@ be that both true and false proofs are available."
(let* ((exp-key (compute-exp-key exp)) (let* ((exp-key (compute-exp-key exp))
(equiv (hash-ref equiv-set exp-key '())) (equiv (hash-ref equiv-set exp-key '()))
(lidx (label->idx label)) (lidx (label->idx label))
(fx (vector-ref effects lidx))
(avail (vector-ref avail lidx))) (avail (vector-ref avail lidx)))
(let lp ((candidates equiv)) (let lp ((candidates equiv))
(match candidates (match candidates
@ -424,10 +426,10 @@ be that both true and false proofs are available."
;; if the value proves to be unused, in the ;; if the value proves to be unused, in the
;; allocation case). ;; allocation case).
(when (and exp-key (when (and exp-key
(not (causes-effects? (not (causes-effect? fx &allocation))
(vector-ref effects lidx) (not (effect-clobbers?
(logior &fluid-environment fx
&allocation)))) (&read-object &fluid))))
(hash-set! equiv-set exp-key (hash-set! equiv-set exp-key
(acons label (vector-ref defs lidx) (acons label (vector-ref defs lidx)
equiv)))) equiv))))

45
module/language/cps/dce.scm
View file

@ -210,36 +210,27 @@
(not defs) (not defs)
;; Do we have a live def? ;; Do we have a live def?
(or-map value-live? defs) (or-map value-live? defs)
;; Does this expression cause any effects we don't know ;; Does this expression cause all effects? If so, it's
;; how to elide? ;; definitely live.
(not (effect-free? (causes-all-effects? fx)
(exclude-effects fx
(logior &allocation &type-check
&car &cdr &vector &struct &box))))
;; Does it cause a type check, but we can't prove that the ;; Does it cause a type check, but we can't prove that the
;; types check? ;; types check?
(and (causes-effects? fx &type-check) (and (causes-effect? fx &type-check)
(not (types-check? exp))) (not (types-check? exp)))
(cond ;; We might have a setter. If the object being assigned
((effect-free? ;; to is live, then this expression is live. Otherwise
(exclude-effects fx (logior &type-check &allocation))) ;; the value is still dead.
;; We've already handled type checks. If allocation is (and (causes-effect? fx &write)
;; the only remaining effect, this expression is still (match exp
;; dead. (($ $primcall 'vector-set!/immediate (vec idx val))
#f) (value-live? vec))
(else (($ $primcall 'set-car! (pair car))
;; We might have a setter. If the object being assigned (value-live? pair))
;; to is live, then this expression is live. (($ $primcall 'set-cdr! (pair cdr))
(match exp (value-live? pair))
(($ $primcall 'vector-set!/immediate (vec idx val)) (($ $primcall 'box-set! (box val))
(value-live? vec)) (value-live? box))
(($ $primcall 'set-car! (pair car)) (_ #t))))))
(value-live? pair))
(($ $primcall 'set-cdr! (pair cdr))
(value-live? pair))
(($ $primcall 'box-set! (box val))
(value-live? box))
(_ #t)))))))
(define (idx->label idx) (+ idx min-label)) (define (idx->label idx) (+ idx min-label))
(let lp ((n (1- (vector-length effects)))) (let lp ((n (1- (vector-length effects))))
(unless (< n 0) (unless (< n 0)

637
module/language/cps/effects-analysis.scm
View file

@ -47,10 +47,13 @@
compute-effects compute-effects
synthesize-definition-effects! synthesize-definition-effects!
&fluid
&fluid-environment
&prompt
&allocation &allocation
&type-check
&read
&write
&fluid
&prompt
&car &car
&cdr &cdr
&vector &vector
@ -59,417 +62,365 @@
&struct &struct
&string &string
&bytevector &bytevector
&type-check
&object
&field
&allocate
&read-object
&read-field
&write-object
&write-field
&no-effects &no-effects
&all-effects &all-effects
effects-commute?
exclude-effects exclude-effects
effect-free? effect-free?
constant? constant?
depends-on-effects? causes-effect?
causes-effects? causes-all-effects?
causes-all-effects?)) effect-clobbers?))
(define-syntax define-effects (define-syntax define-flags
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ all name ...) ((_ all shift name ...)
(with-syntax (((n ...) (iota (length #'(name ...))))) (let ((count (length #'(name ...))))
#'(begin (with-syntax (((n ...) (iota count))
(define-syntax name (identifier-syntax (ash 1 (* n 2)))) (count count))
... #'(begin
(define-syntax all (identifier-syntax (logior name ...))))))))) (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 compile-time-cond (define-flags &all-effect-kinds &effect-kind-bits
(lambda (x) ;; Indicates that an expression may cause a type check. A type check,
(syntax-case x (else) ;; for the purposes of this analysis, is the possibility of throwing
((_ (else body ...)) ;; an exception the first time an expression is evaluated. If the
#'(begin body ...)) ;; expression did not cause an exception to be thrown, users can
((_ (exp body ...) clause ...) ;; assume that evaluating the expression again will not cause an
(if (eval (syntax->datum #'exp) (current-module)) ;; exception to be thrown.
#'(begin body ...) ;;
#'(compile-time-cond clause ...)))))) ;; 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
;; Here we define the effects, indicating the meaning of the effect. ;; Indicates that an expression may return a fresh object. The kind
;; ;; of object is indicated in the object kind field.
;; Effects that are described in a "depends on" sense can also be used &allocation
;; in the "causes" sense.
;;
;; Effects that are described as causing an effect are not usually used
;; in a "depends-on" sense. Although the "depends-on" sense is used
;; when checking for the existence of the "causes" effect, the effects
;; analyzer will not associate the "depends-on" sense of these effects
;; with any expression.
;;
(compile-time-cond
((>= (logcount most-positive-fixnum) 60)
(define-effects &all-effects
;; Indicates that an expression depends on the value of a fluid
;; variable.
&fluid
;; Indicates that an expression depends on the current fluid environment. ;; Indicates that an expression may cause a read from memory. The
&fluid-environment ;; 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 depends on the current prompt ;; Indicates that an expression may cause a write to memory.
;; stack. &write)
&prompt
;; Indicates that an expression may return a fresh object -- a (define-flags &all-memory-kinds &memory-kind-bits
;; "causes" effect. ;; Indicates that an expression depends on the value of a fluid
&allocation ;; variable, or on the current fluid environment.
&fluid
;; Indicates that an expression depends on the value of the car of a ;; Indicates that an expression depends on the current prompt
;; pair. ;; stack.
&car &prompt
;; Indicates that an expression depends on the value of the cdr of a ;; Indicates that an expression depends on the value of the car or cdr
;; pair. ;; of a pair.
&cdr &pair
;; Indicates that an expression depends on the value of a vector ;; Indicates that an expression depends on the value of a vector
;; field. We cannot be more precise, as vectors may alias other ;; field. The effect field indicates the specific field, or zero for
;; vectors. ;; an unknown field.
&vector &vector
;; Indicates that an expression depends on the value of a variable ;; Indicates that an expression depends on the value of a variable
;; cell. ;; cell.
&box &box
;; Indicates that an expression depends on the current module. ;; Indicates that an expression depends on the current module.
&module &module
;; Indicates that an expression depends on the value of a particular ;; Indicates that an expression depends on the value of a struct
;; struct field. ;; field. The effect field indicates the specific field, or zero for
&struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+ ;; an unknown field.
&struct
;; Indicates that an expression depends on the contents of a string. ;; Indicates that an expression depends on the contents of a string.
&string &string
;; Indicates that an expression depends on the contents of a ;; Indicates that an expression depends on the contents of a
;; bytevector. We cannot be more precise, as bytevectors may alias ;; bytevector. We cannot be more precise, as bytevectors may alias
;; other bytevectors. ;; other bytevectors.
&bytevector &bytevector)
;; Indicates that an expression may cause a type check. A type check, (define-inlinable (&field kind field)
;; for the purposes of this analysis, is the possibility of throwing (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
;; an exception the first time an expression is evaluated. If the (define-inlinable (&object kind)
;; expression did not cause an exception to be thrown, users can (&field kind -1))
;; assume that evaluating the expression again will not cause an
;; exception to be thrown.
;;
;; For example, (+ x y) might throw if X or Y are not numbers. But if
;; it doesn't throw, it should be safe to elide a dominated, common
;; subexpression (+ x y).
&type-check)
;; Indicates that an expression depends on the contents of an unknown (define-inlinable (&allocate kind)
;; struct field. (logior &allocation (&object kind)))
(define-syntax &struct (define-inlinable (&read-field kind field)
(identifier-syntax (logior &read (&field kind field)))
(logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+)))) (define-inlinable (&read-object kind)
(logior &read (&object kind)))
(else (define-inlinable (&write-field kind field)
;; For systems with smaller fixnums, be less precise regarding struct (logior &write (&field kind field)))
;; fields. (define-inlinable (&write-object kind)
(define-effects &all-effects (logior &write (&object kind)))
&fluid
&prompt
&allocation
&car
&cdr
&vector
&box
&module
&struct
&string
&bytevector
&type-check)
(define-syntax &fluid-environment (identifier-syntax &fluid))
(define-syntax &struct-0 (identifier-syntax &struct))
(define-syntax &struct-1 (identifier-syntax &struct))
(define-syntax &struct-2 (identifier-syntax &struct))
(define-syntax &struct-3 (identifier-syntax &struct))
(define-syntax &struct-4 (identifier-syntax &struct))
(define-syntax &struct-5 (identifier-syntax &struct))
(define-syntax &struct-6+ (identifier-syntax &struct))))
(define-syntax &no-effects (identifier-syntax 0)) (define-syntax &no-effects (identifier-syntax 0))
(define-syntax &all-effects
(identifier-syntax
(logior &all-effect-kinds (&field &all-memory-kinds -1))))
(define-inlinable (cause effect)
(ash effect 1))
(define-inlinable (&depends-on a)
(logand a &all-effects))
(define-inlinable (&causes a)
(logand a (cause &all-effects)))
(define-inlinable (exclude-effects effects exclude)
(logand effects (lognot (cause exclude))))
(define-inlinable (effect-free? effects)
(zero? (&causes effects)))
(define-inlinable (constant? effects) (define-inlinable (constant? effects)
(zero? effects)) (zero? effects))
(define-inlinable (effects-clobber effects)
(ash (&causes effects) -1))
(define-inlinable (depends-on-effects? x effects) (define-inlinable (causes-effect? x effects)
(not (zero? (logand (&depends-on x) effects)))) (not (zero? (logand x effects))))
(define-inlinable (causes-effects? x effects)
(not (zero? (logand (&causes x) (cause effects)))))
(define-inlinable (causes-all-effects? x effects)
(= (logand (&causes x) (cause effects)) (cause effects)))
(define-inlinable (effects-commute? a b) (define-inlinable (causes-all-effects? x)
(and (not (causes-effects? a (&depends-on b))) (eqv? x &all-effects))
(not (causes-effects? b (&depends-on a)))))
(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?)
(and (not (zero? (logand a b (ash &all-memory-kinds &effect-kind-bits))))
;; A negative field indicates "the whole object". Non-negative
;; fields indicate only part of the object.
(or (< a 0) (< b 0)
(= (ash a (- (+ &effect-kind-bits &memory-kind-bits)))
(ash b (- (+ &effect-kind-bits &memory-kind-bits)))))))
(and (not (zero? (logand a &write)))
(not (zero? (logand b (logior &read &write))))
(locations-same?)))
(define (lookup-constant-index sym dfg) (define (lookup-constant-index sym dfg)
(call-with-values (lambda () (find-constant-value sym dfg)) (call-with-values (lambda () (find-constant-value sym dfg))
(lambda (has-const? val) (lambda (has-const? val)
(and has-const? (integer? val) (exact? val) (<= 0 val) 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 *primitive-effects* (make-hash-table))
(define-syntax-rule (define-primitive-effects* dfg ((name . args) effects) ...) (define-syntax-rule (define-primitive-effects* dfg
((name . args) effects ...)
...)
(begin (begin
(hashq-set! *primitive-effects* 'name (hashq-set! *primitive-effects* 'name
(case-lambda* ((dfg . args) effects) (case-lambda*
(_ (logior &all-effects (cause &all-effects))))) ((dfg . args) (logior effects ...))
(_ &all-effects)))
...)) ...))
(define-syntax-rule (define-primitive-effects ((name . args) effects) ...) (define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
(define-primitive-effects* dfg ((name . args) effects) ...)) (define-primitive-effects* dfg ((name . args) effects ...) ...))
;; Miscellaneous. ;; Miscellaneous.
(define-primitive-effects (define-primitive-effects
((values . _) &no-effects) ((values . _))
((not arg) &no-effects)) ((not arg)))
;; Generic predicates. ;; Generic effect-free predicates.
(define-primitive-effects (define-primitive-effects
((eq? . _) &no-effects) ((eq? . _))
((eqv? . _) &no-effects) ((eqv? . _))
((equal? . _) &no-effects) ((equal? . _))
((pair? arg) &no-effects) ((pair? arg))
((null? arg) &no-effects) ((null? arg))
((nil? arg ) &no-effects) ((nil? arg ))
((symbol? arg) &no-effects) ((symbol? arg))
((variable? arg) &no-effects) ((variable? arg))
((vector? arg) &no-effects) ((vector? arg))
((struct? arg) &no-effects) ((struct? arg))
((string? arg) &no-effects) ((string? arg))
((number? arg) &no-effects) ((number? arg))
((char? arg) &no-effects) ((char? arg))
((procedure? arg) &no-effects) ((procedure? arg))
((thunk? arg) &no-effects)) ((thunk? arg)))
;; Fluids. ;; Fluids.
(define-primitive-effects (define-primitive-effects
((fluid-ref f) ((fluid-ref f) (&read-object &fluid) &type-check)
(logior (cause &type-check) &fluid &fluid-environment)) ((fluid-set! f v) (&write-object &fluid) &type-check)
((fluid-set! f v) ((push-fluid f v) (&write-object &fluid) &type-check)
(logior (cause &type-check) (cause &fluid) &fluid-environment)) ((pop-fluid) (&write-object &fluid) &type-check))
((push-fluid f v)
(logior (cause &type-check) (cause &fluid-environment)))
((pop-fluid)
(logior (cause &fluid-environment))))
;; Prompts. ;; Prompts.
(define-primitive-effects (define-primitive-effects
((make-prompt-tag #:optional arg) (cause &allocation))) ((make-prompt-tag #:optional arg) (&allocate &all-memory-kinds)))
;; Pairs. ;; Pairs.
(define-primitive-effects (define-primitive-effects
((cons a b) (cause &allocation)) ((cons a b) (&allocate &pair))
((list . _) (cause &allocation)) ((list . _) (&allocate &pair))
((car x) (logior (cause &type-check) &car)) ((car x) (&read-field &pair 0) &type-check)
((set-car! x y) (logior (cause &type-check) (cause &car))) ((set-car! x y) (&write-field &pair 0) &type-check)
((cdr x) (logior (cause &type-check) &cdr)) ((cdr x) (&read-field &pair 1) &type-check)
((set-cdr! x y) (logior (cause &type-check) (cause &cdr))) ((set-cdr! x y) (&write-field &pair 1) &type-check)
((memq x y) (logior (cause &type-check) &car &cdr)) ((memq x y) (&read-object &pair) &type-check)
((memv x y) (logior (cause &type-check) &car &cdr)) ((memv x y) (&read-object &pair) &type-check)
((list? arg) &cdr) ((list? arg) (&read-field &pair 1))
((length l) (logior (cause &type-check) &cdr))) ((length l) (&read-field &pair 1) &type-check))
;; Vectors.
(define-primitive-effects
((vector . _) (cause &allocation))
((make-vector n init) (logior (cause &type-check) (cause &allocation)))
((make-vector/immediate n init) (cause &allocation))
((vector-ref v n) (logior (cause &type-check) &vector))
((vector-ref/immediate v n) (logior (cause &type-check) &vector))
((vector-set! v n x) (logior (cause &type-check) (cause &vector)))
((vector-set!/immediate v n x) (logior (cause &type-check) (cause &vector)))
((vector-length v) (cause &type-check)))
;; Variables. ;; Variables.
(define-primitive-effects (define-primitive-effects
((box v) (cause &allocation)) ((box v) (&allocate &box))
((box-ref v) (logior (cause &type-check) &box)) ((box-ref v) (&read-object &box) &type-check)
((box-set! v x) (logior (cause &type-check) (cause &box)))) ((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. ;; 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 (define-primitive-effects* dfg
((allocate-struct vtable nfields) ((allocate-struct vt n) (&allocate &struct) &type-check)
(logior (cause &type-check) (cause &allocation))) ((allocate-struct/immediate v n) (&allocate &struct) &type-check)
((allocate-struct/immediate vtable nfields) ((make-struct vt ntail . _) (&allocate &struct) &type-check)
(logior (cause &type-check) (cause &allocation))) ((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
((make-struct vtable ntail . args) ((struct-ref s n) (read-struct-field n dfg) &type-check)
(logior (cause &type-check) (cause &allocation))) ((struct-ref/immediate s n) (read-struct-field n dfg) &type-check)
((make-struct/no-tail vtable . args) ((struct-set! s n x) (write-struct-field n dfg) &type-check)
(logior (cause &type-check) (cause &allocation))) ((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check)
((struct-ref s n) ((struct-vtable s) &type-check))
(logior (cause &type-check)
(match (lookup-constant-index n dfg)
(#f &struct)
(0 &struct-0)
(1 &struct-1)
(2 &struct-2)
(3 &struct-3)
(4 &struct-4)
(5 &struct-5)
(_ &struct-6+))))
((struct-ref/immediate s n)
(logior (cause &type-check)
(match (lookup-constant-index n dfg)
(#f &struct)
(0 &struct-0)
(1 &struct-1)
(2 &struct-2)
(3 &struct-3)
(4 &struct-4)
(5 &struct-5)
(_ &struct-6+))))
((struct-set! s n x)
(logior (cause &type-check)
(match (lookup-constant-index n dfg)
(#f (cause &struct))
(0 (cause &struct-0))
(1 (cause &struct-1))
(2 (cause &struct-2))
(3 (cause &struct-3))
(4 (cause &struct-4))
(5 (cause &struct-5))
(_ (cause &struct-6+)))))
((struct-set!/immediate s n x)
(logior (cause &type-check)
(match (lookup-constant-index n dfg)
(#f (cause &struct))
(0 (cause &struct-0))
(1 (cause &struct-1))
(2 (cause &struct-2))
(3 (cause &struct-3))
(4 (cause &struct-4))
(5 (cause &struct-5))
(_ (cause &struct-6+)))))
((struct-vtable s) (cause &type-check)))
;; Strings. ;; Strings.
(define-primitive-effects (define-primitive-effects
((string-ref s n) (logior (cause &type-check) &string)) ((string-ref s n) (&read-object &string) &type-check)
((string-set! s n c) (logior (cause &type-check) (cause &string))) ((string-set! s n c) (&write-object &string) &type-check)
((number->string _) (cause &type-check)) ((number->string _) (&allocate &string) &type-check)
((string->number _) (logior (cause &type-check) &string)) ((string->number _) (&read-object &string) &type-check)
((string-length s) (cause &type-check))) ((string-length s) &type-check))
;; Bytevectors. ;; Bytevectors.
(define-primitive-effects (define-primitive-effects
((bytevector-length _) (cause &type-check)) ((bytevector-length _) &type-check)
((bv-u8-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
((bv-s8-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
((bv-u16-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
((bv-s16-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
((bv-u32-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
((bv-s32-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
((bv-u64-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
((bv-s64-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
((bv-f32-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
((bv-f64-ref bv n) (logior (cause &type-check) &bytevector)) ((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
((bv-u8-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s8-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u16-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s16-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u32-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s32-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u64-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s64-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f32-set! bv n x) (logior (cause &type-check) (cause &bytevector))) ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f64-set! bv n x) (logior (cause &type-check) (cause &bytevector)))) ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
;; Numbers.
(define-primitive-effects
((= . _) (cause &type-check))
((< . _) (cause &type-check))
((> . _) (cause &type-check))
((<= . _) (cause &type-check))
((>= . _) (cause &type-check))
((zero? . _) (cause &type-check))
((add . _) (cause &type-check))
((mul . _) (cause &type-check))
((sub . _) (cause &type-check))
((div . _) (cause &type-check))
((sub1 . _) (cause &type-check))
((add1 . _) (cause &type-check))
((quo . _) (cause &type-check))
((rem . _) (cause &type-check))
((mod . _) (cause &type-check))
((complex? _) (cause &type-check))
((real? _) (cause &type-check))
((rational? _) (cause &type-check))
((inf? _) (cause &type-check))
((nan? _) (cause &type-check))
((integer? _) (cause &type-check))
((exact? _) (cause &type-check))
((inexact? _) (cause &type-check))
((even? _) (cause &type-check))
((odd? _) (cause &type-check))
((ash n m) (cause &type-check))
((logand . _) (cause &type-check))
((logior . _) (cause &type-check))
((logior . _) (cause &type-check))
((lognot . _) (cause &type-check))
((sqrt _) (cause &type-check))
((abs _) (cause &type-check)))
;; Characters.
(define-primitive-effects
((char<? . _) (cause &type-check))
((char<=? . _) (cause &type-check))
((char>=? . _) (cause &type-check))
((char>? . _) (cause &type-check))
((integer->char _) (cause &type-check))
((char->integer _) (cause &type-check)))
;; Modules. ;; Modules.
(define-primitive-effects (define-primitive-effects
((current-module) &module) ((current-module) (&read-object &module))
((cache-current-module! mod scope) (cause &box)) ((cache-current-module! m scope) (&write-object &box))
((resolve name bound?) (logior &module (cause &type-check))) ((resolve name bound?) (&read-object &module) &type-check)
((cached-toplevel-box scope name bound?) (cause &type-check)) ((cached-toplevel-box scope name bound?) &type-check)
((cached-module-box mod name public? bound?) (cause &type-check)) ((cached-module-box mod name public? bound?) &type-check)
((define! name val) (logior &module (cause &box)))) ((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)
((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) (define (primitive-effects dfg name args)
(let ((proc (hashq-ref *primitive-effects* name))) (let ((proc (hashq-ref *primitive-effects* name)))
(if proc (if proc
(apply proc dfg args) (apply proc dfg args)
(logior &all-effects (cause &all-effects))))) &all-effects)))
(define (expression-effects exp dfg) (define (expression-effects exp dfg)
(match exp (match exp
((or ($ $void) ($ $const) ($ $prim) ($ $values)) ((or ($ $void) ($ $const) ($ $prim) ($ $values))
&no-effects) &no-effects)
(($ $fun) (($ $fun)
(cause &allocation)) (&allocate &all-memory-kinds))
(($ $prompt) (($ $prompt)
(cause &prompt)) (logior (&write-object &prompt)))
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
(logior &all-effects (cause &all-effects))) &all-effects)
(($ $primcall name args) (($ $primcall name args)
(primitive-effects dfg name args)))) (primitive-effects dfg name args))))
@ -487,13 +438,12 @@
(expression-effects (find-expression body) dfg)) (expression-effects (find-expression body) dfg))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
(match arity (match arity
(($ $arity _ () #f () #f) (cause &type-check)) (($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (cause &allocation)) (($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (cause &allocation) (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(cause &type-check)))))
(($ $kif) &no-effects) (($ $kif) &no-effects)
(($ $kfun) (cause &type-check)) (($ $kfun) &type-check)
(($ $kclause) (cause &type-check)) (($ $kclause) &type-check)
(($ $ktail) &no-effects))) (($ $ktail) &no-effects)))
(lp (1+ n)))) (lp (1+ n))))
effects)) effects))
@ -515,25 +465,6 @@
(when (< label (+ min-label label-count)) (when (< label (+ min-label label-count))
(let* ((lidx (label->idx label)) (let* ((lidx (label->idx label))
(fx (vector-ref effects lidx))) (fx (vector-ref effects lidx)))
(define (add-deps! deps) (unless (zero? (logand (logior &write &allocation) fx))
(vector-set! effects lidx (logior fx deps))) (vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
(match (lookup-cont label dfg)
(($ $kargs _ _ term)
(match (find-expression term)
(($ $primcall 'cons)
(add-deps! (logior &car &cdr)))
(($ $primcall (or 'make-vector 'make-vector/immediate))
(add-deps! &vector))
(($ $primcall (or 'allocate-struct 'allocate-struct/immediate
'make-struct/no-tail 'make-struct))
(add-deps! &struct))
(($ $primcall 'box)
(add-deps! &box))
(_
(add-deps! (effects-clobber
(logand
fx
(cause (logior &car &cdr &vector &struct &box)))))
#t)))
(_ #t))
(lp (1+ label)))))) (lp (1+ label))))))