summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-05-14 12:25:23 +0200
committerAndy Wingo <wingo@pobox.com>2018-05-14 14:04:59 +0200
commit667d808f5841dd99341f220b88f15ab5ed26390a (patch)
treea67d2be82cdbe83ad4c1e3be64c8f65aa032dce8
parent3edf02cbe539d5c53dc93b81aeb17103ac677ce0 (diff)
downloadguile-667d808f5841dd99341f220b88f15ab5ed26390a.tar.gz
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.
-rw-r--r--module/language/cps/reify-primitives.scm59
1 files changed, 41 insertions, 18 deletions
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 29b1585f9..551e1b4c5 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