mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
cache-current-module, etc use immediate primcall parameters
* module/language/bytecode.scm (*macro-instruction-arities*): * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm (current-module): * module/language/cps/primitives.scm (*macro-instruction-arities*): * module/language/cps/prune-top-level-scopes.scm (compute-used-scopes): (prune-top-level-scopes): * module/language/cps/reify-primitives.scm (module-box): * module/language/cps/slot-allocation.scm (compute-needs-slot): * module/language/tree-il/compile-cps.scm (toplevel-box): (module-box, capture-toplevel-scope): Move the primcalls that deal with top-level references to use immediate parameters.
This commit is contained in:
Andy Wingo
parent
c54c151eb6
commit
4fb538e90e
8 changed files with 48 additions and 72 deletions
|
|
@ -77,9 +77,9 @@
|
|||
args))))
|
||||
|
||||
(define *macro-instruction-arities*
|
||||
'((cache-current-module! . (0 . 2))
|
||||
(cached-toplevel-box . (1 . 3))
|
||||
(cached-module-box . (1 . 4))))
|
||||
'((cache-current-module! . (0 . 1))
|
||||
(cached-toplevel-box . (1 . 0))
|
||||
(cached-module-box . (1 . 0))))
|
||||
|
||||
(define (compute-instruction-arities)
|
||||
(let ((table (make-hash-table)))
|
||||
|
|
|
|||
|
|
@ -143,19 +143,14 @@
|
|||
(emit-current-module asm (from-sp dst)))
|
||||
(($ $primcall 'current-thread)
|
||||
(emit-current-thread asm (from-sp dst)))
|
||||
(($ $primcall 'cached-toplevel-box #f (scope name bound?))
|
||||
(emit-cached-toplevel-box asm (from-sp dst)
|
||||
(constant scope) (constant name)
|
||||
(constant bound?)))
|
||||
(($ $primcall 'cached-module-box #f (mod name public? bound?))
|
||||
(emit-cached-module-box asm (from-sp dst)
|
||||
(constant mod) (constant name)
|
||||
(constant public?) (constant bound?)))
|
||||
(($ $primcall 'cached-toplevel-box (scope name bound?))
|
||||
(emit-cached-toplevel-box asm (from-sp dst) scope name bound?))
|
||||
(($ $primcall 'cached-module-box (mod name public? bound?) ())
|
||||
(emit-cached-module-box asm (from-sp dst) mod name public? bound?))
|
||||
(($ $primcall 'define! #f (sym))
|
||||
(emit-define! asm (from-sp dst) (from-sp (slot sym))))
|
||||
(($ $primcall 'resolve #f (name bound?))
|
||||
(emit-resolve asm (from-sp dst) (constant bound?)
|
||||
(from-sp (slot name))))
|
||||
(($ $primcall 'resolve (bound?) (name))
|
||||
(emit-resolve asm (from-sp dst) bound? (from-sp (slot name))))
|
||||
(($ $primcall 'free-ref #f (closure idx))
|
||||
(emit-free-ref asm (from-sp dst) (from-sp (slot closure))
|
||||
(constant idx)))
|
||||
|
|
@ -305,8 +300,8 @@
|
|||
(lookup-parallel-moves handler allocation))
|
||||
(emit-reset-frame asm frame-size)
|
||||
(emit-j asm (forward-label khandler-body))))))
|
||||
(($ $primcall 'cache-current-module! #f (sym scope))
|
||||
(emit-cache-current-module! asm (from-sp (slot sym)) (constant scope)))
|
||||
(($ $primcall 'cache-current-module! (scope) (mod))
|
||||
(emit-cache-current-module! asm (from-sp (slot mod)) scope))
|
||||
(($ $primcall 'free-set! #f (closure idx value))
|
||||
(emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
|
||||
(constant idx)))
|
||||
|
|
|
|||
|
|
@ -428,10 +428,10 @@ is or might be a read or a write to the same location as A."
|
|||
;; Modules.
|
||||
(define-primitive-effects
|
||||
((current-module) (&read-object &module))
|
||||
((cache-current-module! m scope) (&write-object &box))
|
||||
((resolve name bound?) (&read-object &module) &type-check)
|
||||
((cached-toplevel-box scope name bound?) &type-check)
|
||||
((cached-module-box mod name public? bound?) &type-check)
|
||||
((cache-current-module! m) (&write-object &box))
|
||||
((resolve name) (&read-object &module) &type-check)
|
||||
((cached-toplevel-box) &type-check)
|
||||
((cached-module-box) &type-check)
|
||||
((define! name) (&read-object &module)))
|
||||
|
||||
;; Numbers.
|
||||
|
|
|
|||
|
|
@ -68,9 +68,9 @@
|
|||
(define *macro-instruction-arities*
|
||||
'((u64->scm/unlikely . (1 . 1))
|
||||
(s64->scm/unlikely . (1 . 1))
|
||||
(cache-current-module! . (0 . 2))
|
||||
(cached-toplevel-box . (1 . 3))
|
||||
(cached-module-box . (1 . 4))))
|
||||
(cache-current-module! . (0 . 1))
|
||||
(cached-toplevel-box . (1 . 0))
|
||||
(cached-module-box . (1 . 0))))
|
||||
|
||||
(define *immediate-predicates*
|
||||
'(fixnum?
|
||||
|
|
|
|||
|
|
@ -30,34 +30,32 @@
|
|||
#:use-module (language cps intset)
|
||||
#:export (prune-top-level-scopes))
|
||||
|
||||
(define (compute-used-scopes conts constants)
|
||||
(define (compute-used-scopes conts)
|
||||
(persistent-intset
|
||||
(intmap-fold
|
||||
(lambda (label cont used-scopes)
|
||||
(match cont
|
||||
(($ $kargs _ _
|
||||
($ $continue k src
|
||||
($ $primcall 'cached-toplevel-box #f (scope name bound?))))
|
||||
(intset-add! used-scopes (intmap-ref constants scope)))
|
||||
($ $primcall 'cached-toplevel-box (scope name bound?))))
|
||||
(intset-add! used-scopes scope))
|
||||
(_
|
||||
used-scopes)))
|
||||
conts
|
||||
empty-intset)))
|
||||
|
||||
(define (prune-top-level-scopes conts)
|
||||
(let* ((constants (compute-constant-values conts))
|
||||
(used-scopes (compute-used-scopes conts constants)))
|
||||
(let* ((used-scopes (compute-used-scopes conts)))
|
||||
(intmap-map
|
||||
(lambda (label cont)
|
||||
(match cont
|
||||
(($ $kargs names vars
|
||||
($ $continue k src
|
||||
($ $primcall 'cache-current-module! #f
|
||||
(module (? (lambda (scope)
|
||||
(let ((val (intmap-ref constants scope)))
|
||||
(not (intset-ref used-scopes val)))))))))
|
||||
(build-cont ($kargs names vars
|
||||
($continue k src ($values ())))))
|
||||
($ $primcall 'cache-current-module! (scope-id) (module))))
|
||||
(if (intset-ref used-scopes scope-id)
|
||||
cont
|
||||
(build-cont ($kargs names vars
|
||||
($continue k src ($values ()))))))
|
||||
(_
|
||||
cont)))
|
||||
conts)))
|
||||
|
|
|
|||
|
|
@ -39,13 +39,9 @@
|
|||
(letv box)
|
||||
(let$ body (val-proc box))
|
||||
(letk kbox ($kargs ('box) (box) ,body))
|
||||
($ (with-cps-constants ((module module)
|
||||
(name name)
|
||||
(public? public?)
|
||||
(bound? bound?))
|
||||
(build-term ($continue kbox src
|
||||
($primcall 'cached-module-box #f
|
||||
(module name public? bound?))))))))
|
||||
(build-term ($continue kbox src
|
||||
($primcall 'cached-module-box
|
||||
(list module name public? bound?) ())))))
|
||||
|
||||
(define (primitive-module name)
|
||||
(case name
|
||||
|
|
|
|||
|
|
@ -341,14 +341,6 @@ the definitions that are live before and after LABEL, as intsets."
|
|||
(defs+ closure))
|
||||
(($ $primcall 'free-set! #f (closure slot value))
|
||||
(defs+* (intset closure value)))
|
||||
(($ $primcall 'cache-current-module! #f (mod . _))
|
||||
(defs+ mod))
|
||||
(($ $primcall 'cached-toplevel-box #f _)
|
||||
defs)
|
||||
(($ $primcall 'cached-module-box #f _)
|
||||
defs)
|
||||
(($ $primcall 'resolve #f (name bound?))
|
||||
(defs+ name))
|
||||
(($ $primcall 'make-vector/immediate #f (len init))
|
||||
(defs+ init))
|
||||
(($ $primcall 'vector-ref/immediate #f (v i))
|
||||
|
|
|
|||
|
|
@ -86,47 +86,42 @@
|
|||
scope-id))
|
||||
|
||||
(define (toplevel-box cps src name bound? val-proc)
|
||||
(define (lookup cps name bound? k)
|
||||
(define (lookup cps k)
|
||||
(match (current-topbox-scope)
|
||||
(#f
|
||||
(with-cps cps
|
||||
(build-term ($continue k src
|
||||
($primcall 'resolve #f (name bound?))))))
|
||||
(scope-id
|
||||
;; FIXME: Resolve should take name as immediate.
|
||||
($ (with-cps-constants ((name name))
|
||||
(build-term ($continue k src
|
||||
($primcall 'resolve (list bound?) (name))))))))
|
||||
(scope
|
||||
(with-cps cps
|
||||
($ (with-cps-constants ((scope scope-id))
|
||||
(build-term
|
||||
($continue k src
|
||||
($primcall 'cached-toplevel-box #f (scope name bound?))))))))))
|
||||
(build-term
|
||||
($continue k src
|
||||
($primcall 'cached-toplevel-box (list scope name bound?)
|
||||
())))))))
|
||||
(with-cps cps
|
||||
(letv box)
|
||||
(let$ body (val-proc box))
|
||||
(letk kbox ($kargs ('box) (box) ,body))
|
||||
($ (with-cps-constants ((name name)
|
||||
(bound? bound?))
|
||||
($ (lookup name bound? kbox))))))
|
||||
($ (lookup kbox))))
|
||||
|
||||
(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))
|
||||
($ (with-cps-constants ((module module)
|
||||
(name name)
|
||||
(public? public?)
|
||||
(bound? bound?))
|
||||
(build-term ($continue kbox src
|
||||
($primcall 'cached-module-box #f
|
||||
(module name public? bound?))))))))
|
||||
(build-term ($continue kbox src
|
||||
($primcall 'cached-module-box
|
||||
(list module name public? bound?) ())))))
|
||||
|
||||
(define (capture-toplevel-scope cps src scope-id k)
|
||||
(with-cps cps
|
||||
(letv module)
|
||||
(let$ body (with-cps-constants ((scope scope-id))
|
||||
(build-term
|
||||
($continue k src
|
||||
($primcall 'cache-current-module! #f (module scope))))))
|
||||
(letk kmodule ($kargs ('module) (module) ,body))
|
||||
(letk kmodule
|
||||
($kargs ('module) (module)
|
||||
($continue k src
|
||||
($primcall 'cache-current-module! (list scope-id) (module)))))
|
||||
(build-term ($continue kmodule src
|
||||
($primcall 'current-module #f ())))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue