summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/effects-analysis.scm100
1 files changed, 69 insertions, 31 deletions
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 50c7007e4..c768f2eaa 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -311,37 +311,75 @@ the LABELS that are clobbered by the effects of LABEL."
clobbered-labels
(intset-remove clobbered-labels clobbered-label)))))
clobbered-labels clobbered-labels))))
- (let ((clobbered-by-write (make-hash-table)))
- (intmap-fold
- (lambda (label fx)
- ;; Unless an expression causes a read, it isn't clobbered by
- ;; anything.
- (when (causes-effect? fx &read)
- (let ((me (intset label)))
- (define (add! kind field)
- (let* ((k (logior (ash field &memory-kind-bits) kind))
- (clobber (hashv-ref clobbered-by-write k empty-intset)))
- (hashv-set! clobbered-by-write k (intset-union me clobber))))
- ;; Clobbered by write to specific field of this memory
- ;; kind, write to any field of this memory kind, or
- ;; write to any field of unknown memory kinds.
- (let* ((loc (ash fx (- &effect-kind-bits)))
- (kind (logand loc &memory-kind-mask))
- (field (ash loc (- &memory-kind-bits))))
- (add! kind field)
- (add! kind -1)
- (add! &unknown-memory-kinds -1))))
- (values))
- effects)
- (intmap-map (lambda (label fx)
- (if (causes-effect? fx &write)
- (filter-may-alias
- label
- (hashv-ref clobbered-by-write
- (ash fx (- &effect-kind-bits))
- empty-intset))
- empty-intset))
- effects)))
+
+ (define (make-clobber-vector) (make-vector &memory-kind-mask empty-intset))
+
+ (define clobbered-by-write-to-unknown empty-intset)
+ (define clobbered-by-write-to-any-field (make-clobber-vector))
+ (define clobbered-by-write-to-all-fields (make-clobber-vector))
+ (define clobbered-by-write-to-specific-field (make-hash-table))
+
+ (define (adjoin-to-clobber-vector! v k id)
+ (vector-set! v k (intset-union (vector-ref v k) (intset id))))
+ (define (add-clobbered-by-write-to-any-field! kind label)
+ (adjoin-to-clobber-vector! clobbered-by-write-to-any-field kind label))
+ (define (add-clobbered-by-write-to-all-fields! kind label)
+ (adjoin-to-clobber-vector! clobbered-by-write-to-all-fields kind label))
+ (define (adjoin-to-clobber-hash! h k id)
+ (hashv-set! h k (intset-union (hashv-ref h k empty-intset) (intset id))))
+ (define (add-clobbered-by-write-to-specific-field! kind+field label)
+ (adjoin-to-clobber-hash! clobbered-by-write-to-specific-field
+ kind+field label))
+
+ (intmap-fold
+ (lambda (label fx)
+ ;; Unless an expression causes a read, it isn't clobbered by
+ ;; anything.
+ (when (causes-effect? fx &read)
+ (define kind+field (ash fx (- &effect-kind-bits)))
+ (define kind (logand &memory-kind-mask kind+field))
+ (define field (ash kind+field (- &memory-kind-bits)))
+ (cond
+ ((eqv? field -1)
+ ;; A read of the whole object is clobbered by a write to any
+ ;; field.
+ (add-clobbered-by-write-to-all-fields! kind label)
+ (add-clobbered-by-write-to-any-field! kind label))
+ ((negative? field) (error "unexpected field"))
+ (else
+ ;; A read of a specific field is clobbered by a write to that
+ ;; specific field, or a write to all fields.
+ (add-clobbered-by-write-to-all-fields! kind label)
+ (add-clobbered-by-write-to-specific-field! kind+field label)))
+
+ ;; Also clobbered by write to any field of unknown memory kinds.
+ (add-clobbered-by-write-to-any-field! &unknown-memory-kinds label))
+ (values))
+ effects)
+ (define (lookup-clobbers fx)
+ (define kind+field (ash fx (- &effect-kind-bits)))
+ (define kind (logand &memory-kind-mask kind+field))
+ (define field (ash kind+field (- &memory-kind-bits)))
+ (cond
+ ((eqv? field -1)
+ ;; A write to the whole object.
+ (intset-union
+ (vector-ref clobbered-by-write-to-any-field kind)
+ (vector-ref clobbered-by-write-to-all-fields kind)))
+ ((negative? field) (error "unexpected field"))
+ (else
+ ;; A write to a specific field. In addition to clobbering reads
+ ;; of this specific field, we clobber reads of the whole object,
+ ;; for example the ones that correspond to the synthesized "car"
+ ;; and "cdr" definitions that are associated with a "cons" expr.
+ (intset-union
+ (vector-ref clobbered-by-write-to-any-field kind)
+ (hashv-ref clobbered-by-write-to-specific-field kind+field)))))
+ (intmap-map (lambda (label fx)
+ (if (causes-effect? fx &write)
+ (filter-may-alias label (lookup-clobbers fx))
+ empty-intset))
+ effects))
(define *primitive-effects* (make-hash-table))