wingo pushed a commit to branch main
in repository guile.
commit 48548df91e9eb5d4a46391da0ad0a8cdd3387857
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Mar 20 11:32:51 2024 +0100
Fix effects analysis: field writes clobber object reads
* module/language/cps/effects-analysis.scm (compute-clobber-map):
Previously a whole-object read would not be clobbered by a specific
field write. This crops up for the &read introduced at the site of
`cons` for the synthetic car and cdr definitions. This error was there
before but didn't cause bugs before 3.0.10 because cons got eagerly
lowered to separate allocation and initialization instructions.
---
module/language/cps/effects-analysis.scm | 100 +++++++++++++++++++++----------
1 file 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))
