mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Instruction explosion for cache-current-module, cached-toplevel-box

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2018-05-14 12:25:23 +02:00
parent 3edf02cbe5
commit 667d808f58
1 changed files with 41 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

59
module/language/cps/reify-primitives.scm
View file

@ -35,15 +35,6 @@
#:use-module (system base types internal) #:use-module (system base types internal)
#:export (reify-primitives)) #: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) (define (primitive-module name)
(case name (case name
((bytevector? ((bytevector?
@ -88,12 +79,13 @@
(else '(guile)))) (else '(guile))))
(define (primitive-ref cps name k src) (define (primitive-ref cps name k src)
(module-box cps src (primitive-module name) name #f #t (with-cps cps
(lambda (cps box) (letv box)
(with-cps cps (letk kbox ($kargs ('box) (box)
(build-term ($continue k src
($continue k src ($primcall 'scm-ref/immediate '(box . 1) (box)))))
($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) (define (builtin-ref cps idx k src)
(with-cps cps (with-cps cps
@ -275,6 +267,40 @@
($continue ktest src ($continue ktest src
($primcall 'cache-ref cache-key ())))))))) ($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 ;; FIXME: Instead of having to check this, instead every primcall that's
;; not ephemeral should be handled by compile-bytecode. ;; not ephemeral should be handled by compile-bytecode.
(define (compute-known-primitives) (define (compute-known-primitives)
@ -300,9 +326,6 @@
scm->f64 scm->f64
s64->u64 s64->scm scm->s64 s64->u64 s64->scm scm->s64
u64->s64 u64->scm scm->u64 scm->u64/truncate u64->s64 u64->scm scm->u64 scm->u64/truncate
cache-current-module!
cached-toplevel-box
cached-module-box
wind unwind wind unwind
push-fluid pop-fluid fluid-ref fluid-set! push-fluid pop-fluid fluid-ref fluid-set!
push-dynamic-state pop-dynamic-state push-dynamic-state pop-dynamic-state