[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-29-g5d25fda
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-29-g5d25fda |
|
Date: |
Thu, 08 May 2014 08:40:07 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=5d25fdae37ea39fe8ad657fab16e69b658c53a0e
The branch, master has been updated
via 5d25fdae37ea39fe8ad657fab16e69b658c53a0e (commit)
via 466bdf7ee3a4df1606c1406a3f36cd060defbe0c (commit)
from fb512cac6ebebc1c31fdb3447fba0ac4b496237a (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 5d25fdae37ea39fe8ad657fab16e69b658c53a0e
Author: Andy Wingo <address@hidden>
Date: Thu May 8 10:39:49 2014 +0200
Rewrite effects analysis to be precise for fields.
* 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.
commit 466bdf7ee3a4df1606c1406a3f36cd060defbe0c
Author: Andy Wingo <address@hidden>
Date: Wed May 7 17:10:15 2014 +0200
CSE effects analysis cleanup
* module/language/cps/cse.scm (compute-always-available-expressions):
Use constant? instead of zero?, to avoid punching through the effects
abstraction.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/cse.scm | 22 +-
module/language/cps/dce.scm | 45 +--
module/language/cps/effects-analysis.scm | 665 +++++++++++++----------------
3 files changed, 328 insertions(+), 404 deletions(-)
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index e3b5ff2..5251622 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -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 (zero? (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))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 9e393bf..d0e5751 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -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)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 6b72ec1..6089dc0 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -47,10 +47,13 @@
compute-effects
synthesize-definition-effects!
+ &allocation
+ &type-check
+ &read
+ &write
+
&fluid
- &fluid-environment
&prompt
- &allocation
&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 ...)))))))))
-
-(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 ...))))))
-
-;; 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 depends on the current fluid environment.
- &fluid-environment
-
- ;; Indicates that an expression depends on the current prompt
- ;; stack.
- &prompt
-
- ;; Indicates that an expression may return a fresh object -- a
- ;; "causes" effect.
- &allocation
-
- ;; Indicates that an expression depends on the value of the car of a
- ;; pair.
- &car
-
- ;; Indicates that an expression depends on the value of the cdr of a
- ;; pair.
- &cdr
-
- ;; 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 variable
- ;; cell.
- &box
-
- ;; 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 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 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 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))))
+ ((_ 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-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-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 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 (&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 (effects-commute? a b)
- (and (not (causes-effects? a (&depends-on b)))
- (not (causes-effects? b (&depends-on a)))))
+(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?)
+ (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))
-
- ((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))))
+ ((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))
-;; Numbers.
+;; Modules.
(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)))
+ ((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)))
-;; Characters.
+;; Numbers.
(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)))
+ ((= . _) &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))
-;; Modules.
+;; Characters.
(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))))
+ ((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))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-29-g5d25fda,
Andy Wingo <=