[Guile-commits] 10/16: Add cache-ref, cache-set! macro-instructions

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit f6de1b062041dd61a79157e48eb5376e85b42484
Author: Andy Wingo <address@hidden>
Date:   Mon May 14 11:13:58 2018 +0200

    Add cache-ref, cache-set! macro-instructions
    
    * module/system/vm/assembler.scm (<cache-cell>): Remove "scope" member.
      Just be an opaque key comparable with equal?.
      (intern-cache-cell): Remove scope arg.
      (intern-module-cache-cell): Remove; callers use intern-cache-cell now.
      (cache-current-module!, cached-toplevel-box, cached-module-box): Create
      cache keys that by construction won't collide between types.
      (cache-ref, cache-set!): Add new macro assemblers.
    * module/language/cps/reify-primitives.scm:
    * module/language/cps/compile-bytecode.scm: Add cases for new macro
      instructions.
---
 module/language/cps/compile-bytecode.scm |  4 ++++
 module/language/cps/reify-primitives.scm |  3 ++-
 module/system/vm/assembler.scm           | 29 ++++++++++++++++-------------
 3 files changed, 22 insertions(+), 14 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 426942c..fdf9953 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -175,6 +175,8 @@
         (($ $primcall 'tail-pointer-ref/immediate (annotation . idx) (obj))
          (emit-tail-pointer-ref/immediate asm (from-sp dst) (from-sp (slot 
obj))
                                           idx))
+        (($ $primcall 'cache-ref key ())
+         (emit-cache-ref asm (from-sp dst) key))
         (($ $primcall 'resolve-module public? (name))
          (emit-resolve-module asm (from-sp dst) (from-sp (slot name)) public?))
         (($ $primcall 'lookup #f (mod name))
@@ -285,6 +287,8 @@
         (($ $values ()) #f)
         (($ $primcall 'cache-current-module! (scope) (mod))
          (emit-cache-current-module! asm (from-sp (slot mod)) scope))
+        (($ $primcall 'cache-set! key (val))
+         (emit-cache-set! asm key (from-sp (slot val))))
         (($ $primcall 'scm-set! annotation (obj idx val))
          (emit-scm-set! asm (from-sp (slot obj)) (from-sp (slot idx))
                         (from-sp (slot val))))
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index eec757b..0426ccd 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -239,7 +239,8 @@
       wind unwind
       push-fluid pop-fluid fluid-ref fluid-set!
       push-dynamic-state pop-dynamic-state
-      lsh rsh lsh/immediate rsh/immediate))
+      lsh rsh lsh/immediate rsh/immediate
+      cache-ref cache-set!))
   (let ((table (make-hash-table)))
     (for-each
      (match-lambda ((inst . _) (hashq-set! table inst #t)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 56644fd..4c4eec4 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -227,6 +227,9 @@
             emit-resolve-module
             emit-lookup
 
+            emit-cache-ref
+            emit-cache-set!
+
             emit-call
             emit-call-label
             emit-tail-call
@@ -1121,9 +1124,8 @@ immediate, and @code{#f} otherwise."
   (element-size uniform-vector-backing-store-element-size))
 
 (define-record-type <cache-cell>
-  (make-cache-cell scope key)
+  (make-cache-cell key)
   cache-cell?
-  (scope cache-cell-scope)
   (key cache-cell-key))
 
 (define (simple-vector? obj)
@@ -1232,16 +1234,11 @@ label."
     (error "expected a non-immediate" obj))
   (intern-constant asm obj))
 
-(define (intern-cache-cell asm scope key)
+(define (intern-cache-cell asm key)
   "Intern a cache cell into the constant table, and return its label.
 If there is already a cache cell with the given scope and key, it is
 returned instead."
-  (intern-constant asm (make-cache-cell scope key)))
-
-;; Return the label of the cell that holds the module for a scope.
-(define (intern-module-cache-cell asm scope)
-  "Intern a cache cell for a module, and return its label."
-  (intern-cache-cell asm scope #t))
+  (intern-constant asm (make-cache-cell key)))
 
 
 
@@ -1499,20 +1496,26 @@ returned instead."
     (set-arity-definitions! arity (cons def (arity-definitions arity)))))
 
 (define-macro-assembler (cache-current-module! asm module scope)
-  (let ((mod-label (intern-module-cache-cell asm scope)))
+  (let ((mod-label (intern-cache-cell asm scope)))
     (emit-static-set! asm module mod-label 0)))
 
+(define-macro-assembler (cache-ref asm dst key)
+  (emit-static-ref asm dst (intern-cache-cell asm key)))
+
+(define-macro-assembler (cache-set! asm key val)
+  (emit-static-set! asm val (intern-cache-cell asm key) 0))
+
 (define-macro-assembler (cached-toplevel-box asm dst scope sym bound?)
   (let ((sym-label (intern-non-immediate asm sym))
-        (mod-label (intern-module-cache-cell asm scope))
-        (cell-label (intern-cache-cell asm scope sym)))
+        (mod-label (intern-cache-cell asm scope))
+        (cell-label (intern-cache-cell asm (cons scope sym))))
     (emit-toplevel-box asm dst cell-label mod-label sym-label bound?)))
 
 (define-macro-assembler (cached-module-box asm dst module-name sym public? 
bound?)
   (let* ((sym-label (intern-non-immediate asm sym))
          (key (cons public? module-name))
          (mod-name-label (intern-constant asm key))
-         (cell-label (intern-cache-cell asm key sym)))
+         (cell-label (intern-cache-cell asm (acons public? module-name sym))))
     (emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
 
 (define-macro-assembler (slot-map asm proc-slot slot-map)