summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2024-03-20 11:32:51 +0100
committerAndy Wingo <wingo@pobox.com>2024-03-20 11:50:53 +0100
commit48548df91e9eb5d4a46391da0ad0a8cdd3387857 (patch)
tree7eb37c942ca17631478cb2075f61ab3d44dabdbe /module/language
parentb012c80875f6ac5235bf518b594513a6031304ad (diff)
downloadguile-48548df91e9eb5d4a46391da0ad0a8cdd3387857.tar.gz
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.
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))