From 4fb538e90eca77ca38b7c25b672a22bcd6075a6d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Nov 2017 13:47:32 +0100 Subject: [PATCH] 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. --- module/language/bytecode.scm | 6 +-- module/language/cps/compile-bytecode.scm | 21 ++++------ module/language/cps/effects-analysis.scm | 8 ++-- module/language/cps/primitives.scm | 6 +-- .../language/cps/prune-top-level-scopes.scm | 20 ++++----- module/language/cps/reify-primitives.scm | 10 ++--- module/language/cps/slot-allocation.scm | 8 ---- module/language/tree-il/compile-cps.scm | 41 ++++++++----------- 8 files changed, 48 insertions(+), 72 deletions(-) diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm index e25e8c923..8372feb02 100644 --- a/module/language/bytecode.scm +++ b/module/language/bytecode.scm @@ -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))) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 8d9588441..d206d2671 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 50531f33e..3f3d8b79f 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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. diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 8d07e0d11..3b0eb08a3 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -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? diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm index ae3342673..56f05c613 100644 --- a/module/language/cps/prune-top-level-scopes.scm +++ b/module/language/cps/prune-top-level-scopes.scm @@ -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))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index d2b173eec..580f80327 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -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 diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 278210dff..9c70a8bb7 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -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)) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 670d72f69..be7fe642a 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -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 ())))))