[Guile-commits] 12/16: Instruction explosion for cache-current-module, cached-toplevel-box

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 667d808f5841dd99341f220b88f15ab5ed26390a
Author: Andy Wingo <address@hidden>
Date:   Mon May 14 12:25:23 2018 +0200

    Instruction explosion for cache-current-module, cached-toplevel-box
    
    * module/language/cps/reify-primitives.scm (primitive-ref): When
      reifying xoprimitives, explode cached-module-box references.
      (cache-current-module!, cached-toplevel-box): Do instruction
      explosion.
---
 module/language/cps/reify-primitives.scm | 59 ++++++++++++++++++++++----------
 1 file changed, 41 insertions(+), 18 deletions(-)

diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 29b1585..551e1b4 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -35,15 +35,6 @@
   #:use-module (system base types internal)
   #:export (reify-primitives))
 
-(define (module-box cps src module name public? bound? val-proc)
-  (with-cps cps
-    (letv box)
-    (let$ body (val-proc box))
-    (letk kbox ($kargs ('box) (box) ,body))
-    (build-term ($continue kbox src
-                  ($primcall 'cached-module-box
-                             (list module name public? bound?) ())))))
-
 (define (primitive-module name)
   (case name
     ((bytevector?
@@ -88,12 +79,13 @@
     (else '(guile))))
 
 (define (primitive-ref cps name k src)
-  (module-box cps src (primitive-module name) name #f #t
-              (lambda (cps box)
-                (with-cps cps
-                  (build-term
-                    ($continue k src
-                      ($primcall 'scm-ref/immediate '(box . 1) (box))))))))
+  (with-cps cps
+    (letv box)
+    (letk kbox ($kargs ('box) (box)
+                 ($continue k src
+                   ($primcall 'scm-ref/immediate '(box . 1) (box)))))
+    ($ ((hashq-ref *ephemeral-reifiers* 'cached-module-box)
+        kbox src (list (primitive-module name) name #f #t) '()))))
 
 (define (builtin-ref cps idx k src)
   (with-cps cps
@@ -275,6 +267,40 @@
            ($continue ktest src
              ($primcall 'cache-ref cache-key ()))))))))
 
+(define-ephemeral (cache-current-module! cps k src param mod)
+  (match param
+    ((scope)
+     (with-cps cps
+       (build-term
+         ($continue k src
+           ($primcall 'cache-set! scope (mod))))))))
+
+(define-ephemeral (cached-toplevel-box cps k src param)
+  (match param
+    ((scope name bound?)
+     (let ((cache-key (cons scope name)))
+       (with-cps cps
+         (letv mod cached)
+         (let$ lookup
+               (reify-lookup
+                src mod name bound?
+                (lambda (cps var)
+                  (with-cps cps
+                    (letk k* ($kargs () () ($continue k src ($values (var)))))
+                    (build-term
+                      ($continue k* src
+                        ($primcall 'cache-set! cache-key (var))))))))
+         (letk kmod ($kargs ('mod) (mod) ,lookup))
+         (letk kinit ($kargs () ()
+                       ($continue kmod src ($primcall 'cache-ref scope ()))))
+         (letk kok ($kargs () () ($continue k src ($values (cached)))))
+         (letk ktest
+               ($kargs ('cached) (cached)
+                 ($branch kinit kok src 'heap-object? #f (cached))))
+         (build-term
+           ($continue ktest src
+             ($primcall 'cache-ref cache-key ()))))))))
+
 ;; FIXME: Instead of having to check this, instead every primcall that's
 ;; not ephemeral should be handled by compile-bytecode.
 (define (compute-known-primitives)
@@ -300,9 +326,6 @@
       scm->f64
       s64->u64 s64->scm scm->s64
       u64->s64 u64->scm scm->u64 scm->u64/truncate
-      cache-current-module!
-      cached-toplevel-box
-      cached-module-box
       wind unwind
       push-fluid pop-fluid fluid-ref fluid-set!
       push-dynamic-state pop-dynamic-state