summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-05-14 11:54:29 +0200
committerAndy Wingo <wingo@pobox.com>2018-05-14 14:04:59 +0200
commit3edf02cbe539d5c53dc93b81aeb17103ac677ce0 (patch)
tree0868c3c3d9be0239b04c29f970ee291699e3c621
parentf6de1b062041dd61a79157e48eb5376e85b42484 (diff)
downloadguile-3edf02cbe539d5c53dc93b81aeb17103ac677ce0.tar.gz
Instruction explosion for cached-module-box
* module/language/cps/reify-primitives.scm (reify-lookup): (reify-resolve-module): New helpers. (cached-module-box): Explode.
-rw-r--r--module/language/cps/reify-primitives.scm67
1 files changed, 67 insertions, 0 deletions
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 0426ccd95..29b1585f9 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -208,6 +208,73 @@
(define-ephemeral (slsh/immediate cps k src param a)
(wrap-unary cps k src 's64->u64 'u64->s64 'ulsh/immediate param a))
+(define (reify-lookup cps src mod-var name assert-bound? have-var)
+ (define (%lookup cps kbad k src mod-var name-var var assert-bound?)
+ (if assert-bound?
+ (with-cps cps
+ (letv val)
+ (letk kcheck
+ ($kargs ('val) (val)
+ ($branch k kbad src 'undefined? #f (val))))
+ (letk kref
+ ($kargs () ()
+ ($continue kcheck src
+ ($primcall 'scm-ref/immediate '(box . 1) (var)))))
+ ($ (%lookup kbad kref src mod-var name-var var #f)))
+ (with-cps cps
+ (letk kres
+ ($kargs ('var) (var)
+ ($branch kbad k src 'heap-object? #f (var))))
+ (build-term
+ ($continue kres src
+ ($primcall 'lookup #f (mod-var name-var)))))))
+ (define %unbound
+ #(unbound-variable #f "Unbound variable: ~S"))
+ (with-cps cps
+ (letv name-var var)
+ (let$ good (have-var var))
+ (letk kgood ($kargs () () ,good))
+ (letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var))))
+ (let$ body (%lookup kbad kgood src mod-var name-var var assert-bound?))
+ (letk klookup ($kargs ('name) (name-var) ,body))
+ (build-term ($continue klookup src ($const name)))))
+
+(define (reify-resolve-module cps k src module public?)
+ (with-cps cps
+ (letv mod-name)
+ (letk kresolve
+ ($kargs ('mod-name) (mod-name)
+ ($continue k src
+ ($primcall 'resolve-module public? (mod-name)))))
+ (build-term
+ ($continue kresolve src ($const module)))))
+
+(define-ephemeral (cached-module-box cps k src param)
+ (match param
+ ((module name public? bound?)
+ (let ((cache-key (cons module 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))
+ (let$ module (reify-resolve-module kmod src module public?))
+ (letk kinit ($kargs () () ,module))
+ (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)