diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/cps/effects-analysis.scm | 100 |
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)) |