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

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

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

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

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