mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

cache-current-module, etc use immediate primcall parameters

Browse source 
* 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 2017-11-01 13:47:32 +01:00
parent c54c151eb6
commit 4fb538e90e
8 changed files with 48 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

6
module/language/bytecode.scm
View file

@ -77,9 +77,9 @@
args)))) args))))
(define *macro-instruction-arities* (define *macro-instruction-arities*
'((cache-current-module! . (0 . 2)) '((cache-current-module! . (0 . 1))
(cached-toplevel-box . (1 . 3)) (cached-toplevel-box . (1 . 0))
(cached-module-box . (1 . 4)))) (cached-module-box . (1 . 0))))
(define (compute-instruction-arities) (define (compute-instruction-arities)
(let ((table (make-hash-table))) (let ((table (make-hash-table)))

21
module/language/cps/compile-bytecode.scm
View file

@ -143,19 +143,14 @@
(emit-current-module asm (from-sp dst))) (emit-current-module asm (from-sp dst)))
(($ $primcall 'current-thread) (($ $primcall 'current-thread)
(emit-current-thread asm (from-sp dst))) (emit-current-thread asm (from-sp dst)))
(($ $primcall 'cached-toplevel-box #f (scope name bound?)) (($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-cached-toplevel-box asm (from-sp dst) (emit-cached-toplevel-box asm (from-sp dst) scope name bound?))
(constant scope) (constant name) (($ $primcall 'cached-module-box (mod name public? bound?) ())
(constant bound?))) (emit-cached-module-box asm (from-sp dst) mod name public? 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 'define! #f (sym)) (($ $primcall 'define! #f (sym))
(emit-define! asm (from-sp dst) (from-sp (slot sym)))) (emit-define! asm (from-sp dst) (from-sp (slot sym))))
(($ $primcall 'resolve #f (name bound?)) (($ $primcall 'resolve (bound?) (name))
(emit-resolve asm (from-sp dst) (constant bound?) (emit-resolve asm (from-sp dst) bound? (from-sp (slot name))))
(from-sp (slot name))))
(($ $primcall 'free-ref #f (closure idx)) (($ $primcall 'free-ref #f (closure idx))
(emit-free-ref asm (from-sp dst) (from-sp (slot closure)) (emit-free-ref asm (from-sp dst) (from-sp (slot closure))
(constant idx))) (constant idx)))
@ -305,8 +300,8 @@
(lookup-parallel-moves handler allocation)) (lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size) (emit-reset-frame asm frame-size)
(emit-j asm (forward-label khandler-body)))))) (emit-j asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! #f (sym scope)) (($ $primcall 'cache-current-module! (scope) (mod))
(emit-cache-current-module! asm (from-sp (slot sym)) (constant scope))) (emit-cache-current-module! asm (from-sp (slot mod)) scope))
(($ $primcall 'free-set! #f (closure idx value)) (($ $primcall 'free-set! #f (closure idx value))
(emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value)) (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
(constant idx))) (constant idx)))

8
module/language/cps/effects-analysis.scm
View file

@ -428,10 +428,10 @@ is or might be a read or a write to the same location as A."
;; Modules. ;; Modules.
(define-primitive-effects (define-primitive-effects
((current-module) (&read-object &module)) ((current-module) (&read-object &module))
((cache-current-module! m scope) (&write-object &box)) ((cache-current-module! m) (&write-object &box))
((resolve name bound?) (&read-object &module) &type-check) ((resolve name) (&read-object &module) &type-check)
((cached-toplevel-box scope name bound?) &type-check) ((cached-toplevel-box) &type-check)
((cached-module-box mod name public? bound?) &type-check) ((cached-module-box) &type-check)
((define! name) (&read-object &module))) ((define! name) (&read-object &module)))
;; Numbers. ;; Numbers.

6
module/language/cps/primitives.scm
View file

@ -68,9 +68,9 @@
(define *macro-instruction-arities* (define *macro-instruction-arities*
'((u64->scm/unlikely . (1 . 1)) '((u64->scm/unlikely . (1 . 1))
(s64->scm/unlikely . (1 . 1)) (s64->scm/unlikely . (1 . 1))
(cache-current-module! . (0 . 2)) (cache-current-module! . (0 . 1))
(cached-toplevel-box . (1 . 3)) (cached-toplevel-box . (1 . 0))
(cached-module-box . (1 . 4)))) (cached-module-box . (1 . 0))))
(define *immediate-predicates* (define *immediate-predicates*
'(fixnum? '(fixnum?

18
module/language/cps/prune-top-level-scopes.scm
View file

@ -30,34 +30,32 @@
#:use-module (language cps intset) #:use-module (language cps intset)
#:export (prune-top-level-scopes)) #:export (prune-top-level-scopes))
(define (compute-used-scopes conts constants) (define (compute-used-scopes conts)
(persistent-intset (persistent-intset
(intmap-fold (intmap-fold
(lambda (label cont used-scopes) (lambda (label cont used-scopes)
(match cont (match cont
(($ $kargs _ _ (($ $kargs _ _
($ $continue k src ($ $continue k src
($ $primcall 'cached-toplevel-box #f (scope name bound?)))) ($ $primcall 'cached-toplevel-box (scope name bound?))))
(intset-add! used-scopes (intmap-ref constants scope))) (intset-add! used-scopes scope))
(_ (_
used-scopes))) used-scopes)))
conts conts
empty-intset))) empty-intset)))
(define (prune-top-level-scopes conts) (define (prune-top-level-scopes conts)
(let* ((constants (compute-constant-values conts)) (let* ((used-scopes (compute-used-scopes conts)))
(used-scopes (compute-used-scopes conts constants)))
(intmap-map (intmap-map
(lambda (label cont) (lambda (label cont)
(match cont (match cont
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $continue k src
($ $primcall 'cache-current-module! #f ($ $primcall 'cache-current-module! (scope-id) (module))))
(module (? (lambda (scope) (if (intset-ref used-scopes scope-id)
(let ((val (intmap-ref constants scope))) cont
(not (intset-ref used-scopes val)))))))))
(build-cont ($kargs names vars (build-cont ($kargs names vars
($continue k src ($values ()))))) ($continue k src ($values ()))))))
(_ (_
cont))) cont)))
conts))) conts)))

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

@ -39,13 +39,9 @@
(letv box) (letv box)
(let$ body (val-proc box)) (let$ body (val-proc box))
(letk kbox ($kargs ('box) (box) ,body)) (letk kbox ($kargs ('box) (box) ,body))
($ (with-cps-constants ((module module)
(name name)
(public? public?)
(bound? bound?))
(build-term ($continue kbox src (build-term ($continue kbox src
($primcall 'cached-module-box #f ($primcall 'cached-module-box
(module name public? bound?)))))))) (list module name public? bound?) ())))))
(define (primitive-module name) (define (primitive-module name)
(case name (case name

8
module/language/cps/slot-allocation.scm
View file

@ -341,14 +341,6 @@ the definitions that are live before and after LABEL, as intsets."
(defs+ closure)) (defs+ closure))
(($ $primcall 'free-set! #f (closure slot value)) (($ $primcall 'free-set! #f (closure slot value))
(defs+* (intset closure 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)) (($ $primcall 'make-vector/immediate #f (len init))
(defs+ init)) (defs+ init))
(($ $primcall 'vector-ref/immediate #f (v i)) (($ $primcall 'vector-ref/immediate #f (v i))

31
module/language/tree-il/compile-cps.scm
View file

@ -86,47 +86,42 @@
scope-id)) scope-id))
(define (toplevel-box cps src name bound? val-proc) (define (toplevel-box cps src name bound? val-proc)
(define (lookup cps name bound? k) (define (lookup cps k)
(match (current-topbox-scope) (match (current-topbox-scope)
(#f (#f
(with-cps cps (with-cps cps
;; FIXME: Resolve should take name as immediate.
($ (with-cps-constants ((name name))
(build-term ($continue k src (build-term ($continue k src
($primcall 'resolve #f (name bound?)))))) ($primcall 'resolve (list bound?) (name))))))))
(scope-id (scope
(with-cps cps (with-cps cps
($ (with-cps-constants ((scope scope-id))
(build-term (build-term
($continue k src ($continue k src
($primcall 'cached-toplevel-box #f (scope name bound?)))))))))) ($primcall 'cached-toplevel-box (list scope name bound?)
())))))))
(with-cps cps (with-cps cps
(letv box) (letv box)
(let$ body (val-proc box)) (let$ body (val-proc box))
(letk kbox ($kargs ('box) (box) ,body)) (letk kbox ($kargs ('box) (box) ,body))
($ (with-cps-constants ((name name) ($ (lookup kbox))))
(bound? bound?))
($ (lookup name bound? kbox))))))
(define (module-box cps src module name public? bound? val-proc) (define (module-box cps src module name public? bound? val-proc)
(with-cps cps (with-cps cps
(letv box) (letv box)
(let$ body (val-proc box)) (let$ body (val-proc box))
(letk kbox ($kargs ('box) (box) ,body)) (letk kbox ($kargs ('box) (box) ,body))
($ (with-cps-constants ((module module)
(name name)
(public? public?)
(bound? bound?))
(build-term ($continue kbox src (build-term ($continue kbox src
($primcall 'cached-module-box #f ($primcall 'cached-module-box
(module name public? bound?)))))))) (list module name public? bound?) ())))))
(define (capture-toplevel-scope cps src scope-id k) (define (capture-toplevel-scope cps src scope-id k)
(with-cps cps (with-cps cps
(letv module) (letv module)
(let$ body (with-cps-constants ((scope scope-id)) (letk kmodule
(build-term ($kargs ('module) (module)
($continue k src ($continue k src
($primcall 'cache-current-module! #f (module scope)))))) ($primcall 'cache-current-module! (list scope-id) (module)))))
(letk kmodule ($kargs ('module) (module) ,body))
(build-term ($continue kmodule src (build-term ($continue kmodule src
($primcall 'current-module #f ()))))) ($primcall 'current-module #f ())))))