guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 02/03: Add compute-clobber-map to effect analysis


From: Andy Wingo
Subject: [Guile-commits] 02/03: Add compute-clobber-map to effect analysis
Date: Thu, 30 Nov 2017 07:11:16 -0500 (EST)

wingo pushed a commit to branch stable-2.2
in repository guile.

commit 8e7f857b0282dda6767aec3221fd045be3ca27c3
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 30 11:42:04 2017 +0100

    Add compute-clobber-map to effect analysis
    
    * module/language/cps/effects-analysis.scm (compute-clobber-map): New
      public function.
---
 module/language/cps/effects-analysis.scm | 37 +++++++++++++++++++++++++++++++-
 1 file changed, 36 insertions(+), 1 deletion(-)

diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 1cc03c0..fe89a12 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -42,6 +42,7 @@
 (define-module (language cps effects-analysis)
   #:use-module (language cps)
   #:use-module (language cps utils)
+  #:use-module (language cps intset)
   #:use-module (language cps intmap)
   #:use-module (ice-9 match)
   #:export (expression-effects
@@ -83,7 +84,8 @@
             constant?
             causes-effect?
             causes-all-effects?
-            effect-clobbers?))
+            effect-clobbers?
+            compute-clobber-map))
 
 (define-syntax define-flags
   (lambda (x)
@@ -236,6 +238,39 @@ is or might be a read or a write to the same location as 
A."
        (not (zero? (logand b (logior &read &write))))
        (locations-same?)))
 
+(define (compute-clobber-map effects)
+  "For the map LABEL->EFFECTS, compute a map LABEL->LABELS indicating
+the LABELS that are clobbered by the effects of LABEL."
+  (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)
+                      (hashv-ref clobbered-by-write
+                                 (ash fx (- &effect-kind-bits))
+                                 empty-intset)
+                      empty-intset))
+                effects)))
+
 (define-inlinable (indexed-field kind var constants)
   (let ((val (intmap-ref constants var (lambda (_) #f))))
     (if (and (exact-integer? val) (<= 0 val))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]