[Guile-commits] 03/13: Add optimizer and backend support for gc-pointer-ref

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit d355b42a3e7d1e314f2bd83d12d9d45e748e19e7
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 10 21:56:30 2018 +0100

    Add optimizer and backend support for gc-pointer-ref
    
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/cse.scm (compute-equivalent-subexpressions):
    * module/language/cps/effects-analysis.scm:
    * module/language/cps/reify-primitives.scm (reify-primitives):
    * module/language/cps/slot-allocation.scm (compute-var-representations):
    * module/language/cps/specialize-primcalls.scm (specialize-primcalls):
    * module/language/cps/types.scm (gc-pointer-ref/immediate):
      (gc-pointer-set!/immediate):
    * module/system/vm/assembler.scm: Add support for pointer-ref.
---
 module/language/cps/compile-bytecode.scm     |  5 +++++
 module/language/cps/cse.scm                  |  1 +
 module/language/cps/effects-analysis.scm     |  9 +++++++++
 module/language/cps/reify-primitives.scm     |  1 +
 module/language/cps/slot-allocation.scm      |  2 ++
 module/language/cps/specialize-primcalls.scm |  2 ++
 module/language/cps/types.scm                | 11 +++++++++++
 module/system/vm/assembler.scm               |  3 +++
 8 files changed, 34 insertions(+)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index ce40973..dceab60 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -170,6 +170,8 @@
                        (from-sp (slot idx))))
         (($ $primcall 'word-ref/immediate (annotation . idx) (obj))
          (emit-word-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
+        (($ $primcall 'gc-pointer-ref/immediate (annotation . idx) (obj))
+         (emit-gc-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj)) 
idx))
         (($ $primcall 'struct-ref/immediate idx (struct))
          (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
                                     idx))
@@ -313,6 +315,9 @@
         (($ $primcall 'word-set!/immediate (annotation . idx) (obj val))
          (emit-word-set!/immediate asm (from-sp (slot obj)) idx
                                    (from-sp (slot val))))
+        (($ $primcall 'gc-pointer-set!/immediate (annotation . idx) (obj val))
+         (emit-gc-pointer-set!/immediate asm (from-sp (slot obj)) idx
+                                         (from-sp (slot val))))
         (($ $primcall 'free-set! idx (closure value))
          (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
                          idx))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index a7de7a6..5d97e56 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -256,6 +256,7 @@ false.  It could be that both true and false proofs are 
available."
            ((scm-set!/immediate p s x)       (x <- scm-ref/immediate p s))
            ((word-set! p s i x)              (x <- word-ref p s i))
            ((word-set!/immediate p s x)      (x <- word-ref/immediate p s))
+           ((gc-pointer-set!/immediate p s x) (x <- gc-pointer-ref/immediate p 
s))
 
            ((s <- allocate-struct #f v n)    (v <- struct-vtable #f s))
            ((s <- allocate-struct/immediate n v) (v <- struct-vtable #f s))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 829db47..b3344ff 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -380,6 +380,15 @@ the LABELS that are clobbered by the effects of LABEL."
   ((word-set!/immediate obj val)   (match param
                                      ((ann . idx)
                                       (&write-field
+                                       (annotation->memory-kind ann) idx))))
+  ((gc-pointer-ref/immediate obj)  (match param
+                                     ((ann . idx)
+                                      (&read-field
+                                       (annotation->memory-kind ann) idx))))
+  ((gc-pointer-set!/immediate obj val)
+                                   (match param
+                                     ((ann . idx)
+                                      (&write-field
                                        (annotation->memory-kind ann) idx)))))
 
 ;; Structs.
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 4580f83..5cf16c1 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -337,6 +337,7 @@
                            (setk label ($kargs names vars
                                          ($continue kop src
                                            ($primcall 'load-u64 n ())))))))))
+                 ;; Assume gc-pointer-ref/immediate is within u8 range.
                  (((or 'word-ref/immediate 'scm-ref/immediate) obj)
                   (match param
                     ((ann . idx)
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 3f73a20..bb6ed53 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -765,6 +765,8 @@ are comparable with eqv?.  A tmp slot may be used."
                                'srsh 'srsh/immediate
                                'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref))
               (intmap-add representations var 's64))
+             (($ $primcall (or 'gc-pointer-ref/immediate))
+              (intmap-add representations var 'gcptr))
              (_
               (intmap-add representations var 'scm))))
           (vars
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index 5d57805..e6c9f32 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -127,6 +127,8 @@
         (('allocate-words (? uint? n)) (allocate-words/immediate n ()))
         (('scm-ref o (? uint? i)) (scm-ref/immediate i (o)))
         (('scm-set! o (? uint? i) x) (scm-set!/immediate i (o x)))
+        ;; Assume gc-pointer-ref/immediate can always be emitted
+        ;; directly.
         (('word-ref o (? uint? i)) (word-ref/immediate i (o)))
         (('word-set! o (? uint? i) x) (word-set!/immediate i (o x)))
         (('add x (? num? y)) (add/immediate y (x)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 810ad15..88b2b42 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -783,6 +783,17 @@ minimum, and maximum."
     ((annotation . idx)
      (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
 
+(define-type-inferrer/param (gc-pointer-ref/immediate param obj result)
+  (match param
+    ((annotation . idx)
+     (restrict! obj (annotation->type annotation) (1+ idx) +inf.0)
+     (define! result &other-heap-object -inf.0 +inf.0))))
+
+(define-type-inferrer/param (gc-pointer-set!/immediate param obj word)
+  (match param
+    ((annotation . idx)
+     (restrict! obj (annotation->type annotation) (1+ idx) +inf.0))))
+
 
 
 ;;;
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 9be3fcf..0eb96cd 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -155,6 +155,9 @@
             emit-word-ref/immediate
             emit-word-set!/immediate
 
+            emit-gc-pointer-ref/immediate
+            emit-gc-pointer-set!/immediate
+
             emit-call
             emit-call-label
             emit-tail-call