[Guile-commits] 02/16: cache-current-module, etc use immediate primcall parameters

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 4fb538e90eca77ca38b7c25b672a22bcd6075a6d
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 1 13:47:32 2017 +0100

    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 ++--
 module/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 e25e8c9..8372feb 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 8d95884..d206d26 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 50531f3..3f3d8b7 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 8d07e0d..3b0eb08 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 ae33426..56f05c6 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 d2b173e..580f803 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 278210d..9c70a8b 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 670d72f..be7fe64 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 ())))))