[Guile-commits] 02/02: Effects analysis treats the fixed parts of objects specially

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 6c6867d570ec3f4550d5ef894e990fab2e9b9800
Author: Andy Wingo <address@hidden>
Date:   Fri Dec 6 10:19:44 2019 +0100

    Effects analysis treats the fixed parts of objects specially
    
    * module/language/cps/effects-analysis.scm (&header): New memory kind,
      for the fixed parts of objects.  Distinguishing init-only memory
      allows us to determine that vector-set! doesn't stomple
      vector-length.
      (annotation->memory-kind*): New helper, mapping references to fixed
      offsets to &header.  Use for scm-ref/immediate et al.
---
 module/language/cps/effects-analysis.scm | 36 ++++++++++++++++++++++++--------
 1 file changed, 27 insertions(+), 9 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 080c798..5073924 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -64,6 +64,7 @@
             &thread
             &bytevector
             &closure
+            &header
 
             &object
             &field
@@ -191,7 +192,12 @@
   &bitmask
 
   ;; Indicates a dependency on the value of a cache cell.
-  &cache)
+  &cache
+
+  ;; Indicates that an expression depends on a value extracted from the
+  ;; fixed, unchanging part of an object -- for example the length of a
+  ;; vector or the vtable of a struct.
+  &header)
 
 (define-inlinable (&field kind field)
   (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
@@ -344,6 +350,18 @@ the LABELS that are clobbered by the effects of LABEL."
   ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
 
 ;; Generic objects.
+(define (annotation->memory-kind* annotation idx)
+  (match (cons annotation idx)
+    (('vector . 0) &header)
+    (('string . (or 0 1 2 3)) &header)
+    (('stringbuf . (or 0 1)) &header)
+    (('bytevector . (or 0 1 2 3)) &header)
+    (('box . 0) &header)
+    (('closure . (or 0 1)) &header)
+    (('struct . 0) &header)
+    (('atomic-box . 0) &header)
+    (_ (annotation->memory-kind annotation))))
+
 (define (annotation->memory-kind annotation)
   (match annotation
     ('pair &pair)
@@ -373,40 +391,40 @@ the LABELS that are clobbered by the effects of LABEL."
   ((scm-ref obj idx)               (&read-object
                                     (annotation->memory-kind param)))
   ((scm-ref/tag obj)               (&read-field
-                                    (annotation->memory-kind param) 0))
+                                    (annotation->memory-kind* param 0) 0))
   ((scm-ref/immediate obj)         (match param
                                      ((ann . idx)
                                       (&read-field
-                                       (annotation->memory-kind ann) idx))))
+                                       (annotation->memory-kind* ann idx) 
idx))))
   ((scm-set! obj idx val)          (&write-object
                                     (annotation->memory-kind param)))
   ((scm-set/tag! obj val)          (&write-field
-                                    (annotation->memory-kind param) 0))
+                                    (annotation->memory-kind* param 0) 0))
   ((scm-set!/immediate obj val)    (match param
                                      ((ann . idx)
                                       (&write-field
-                                       (annotation->memory-kind ann) idx))))
+                                       (annotation->memory-kind* ann idx) 
idx))))
   ((word-ref obj idx)              (&read-object
                                     (annotation->memory-kind param)))
   ((word-ref/immediate obj)        (match param
                                      ((ann . idx)
                                       (&read-field
-                                       (annotation->memory-kind ann) idx))))
+                                       (annotation->memory-kind* ann idx) 
idx))))
   ((word-set! obj idx val)         (&read-object
                                     (annotation->memory-kind param)))
   ((word-set!/immediate obj val)   (match param
                                      ((ann . idx)
                                       (&write-field
-                                       (annotation->memory-kind ann) idx))))
+                                       (annotation->memory-kind* ann idx) 
idx))))
   ((pointer-ref/immediate obj)     (match param
                                      ((ann . idx)
                                       (&read-field
-                                       (annotation->memory-kind ann) idx))))
+                                       (annotation->memory-kind* ann idx) 
idx))))
   ((pointer-set!/immediate obj val)
                                    (match param
                                      ((ann . idx)
                                       (&write-field
-                                       (annotation->memory-kind ann) idx))))
+                                       (annotation->memory-kind* ann idx) 
idx))))
   ((tail-pointer-ref/immediate obj)))
 
 ;; Strings.