[Guile-commits] 04/16: free-ref, free-set take immediate parameters

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 2f45cfcb9c7ff7561b2b12f4f042af950cb0ac68
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 1 14:29:20 2017 +0100

    free-ref, free-set take immediate parameters
    
    * module/language/cps/closure-conversion.scm (convert-one):
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/effects-analysis.scm (define-primitive-effects*)
      (expression-effects, primitive-effects): Only fall back to passing
      constant table if the immediate parameter is false.  Adapt closure
      effects analysis.
    * module/language/cps/slot-allocation.scm (compute-needs-slot): Remove
      special cases for free-ref/free-set!.
---
 module/language/cps/closure-conversion.scm | 15 ++++++---------
 module/language/cps/compile-bytecode.scm   |  9 ++++-----
 module/language/cps/effects-analysis.scm   | 26 +++++++++++---------------
 module/language/cps/slot-allocation.scm    |  4 ----
 4 files changed, 21 insertions(+), 33 deletions(-)

diff --git a/module/language/cps/closure-conversion.scm 
b/module/language/cps/closure-conversion.scm
index bb15908..298784d 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -503,10 +503,9 @@ Otherwise @var{var} is bound, so @var{k} is called with 
@var{var}."
                  (letv var*)
                  (let$ body (k var*))
                  (letk k* ($kargs (#f) (var*) ,body))
-                 ($ (with-cps-constants ((idx idx))
-                      (build-term
-                        ($continue k* #f
-                          ($primcall 'free-ref #f (self idx)))))))))))))
+                 (build-term
+                   ($continue k* #f
+                     ($primcall 'free-ref idx (self)))))))))))
        (else
         (with-cps cps
           ($ (k var))))))
@@ -609,11 +608,9 @@ bound to @var{var}, and continue to @var{k}."
                                       ($primcall 'scm->u64 #f (idx))))))))
                           (else
                            (with-cps cps
-                             ($ (with-cps-constants ((idx idx))
-                                  (build-term
-                                    ($continue k src
-                                      ($primcall 'free-set! #f
-                                                 (var idx v)))))))))))))))))))
+                             (build-term
+                               ($continue k src
+                                 ($primcall 'free-set! idx (var 
v)))))))))))))))))
 
     (define (make-single-closure cps k src kfun)
       (let ((free (intmap-ref free-vars kfun)))
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 57a570f..78de187 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -151,9 +151,8 @@
          (emit-define! asm (from-sp dst) (from-sp (slot sym))))
         (($ $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)))
+        (($ $primcall 'free-ref idx (closure))
+         (emit-free-ref asm (from-sp dst) (from-sp (slot closure)) idx))
         (($ $primcall 'vector-ref #f (vector index))
          (emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
                           (from-sp (slot index))))
@@ -302,9 +301,9 @@
               (emit-j asm (forward-label khandler-body))))))
         (($ $primcall 'cache-current-module! (scope) (mod))
          (emit-cache-current-module! asm (from-sp (slot mod)) scope))
-        (($ $primcall 'free-set! #f (closure idx value))
+        (($ $primcall 'free-set! idx (closure value))
          (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
-                         (constant idx)))
+                         idx))
         (($ $primcall 'box-set! #f (box value))
          (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
         (($ $primcall 'struct-set! #f (struct index value))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 266ef5a..fc5d198 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -244,18 +244,18 @@ is or might be a read or a write to the same location as 
A."
 
 (define *primitive-effects* (make-hash-table))
 
-(define-syntax-rule (define-primitive-effects* constants
+(define-syntax-rule (define-primitive-effects* param
                       ((name . args) effects ...)
                       ...)
   (begin
     (hashq-set! *primitive-effects* 'name
                 (case-lambda*
-                 ((constants . args) (logior effects ...))
+                 ((param . args) (logior effects ...))
                  (_ &all-effects)))
     ...))
 
 (define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
-  (define-primitive-effects* constants ((name . args) effects ...) ...))
+  (define-primitive-effects* param ((name . args) effects ...) ...))
 
 ;; Miscellaneous.
 (define-primitive-effects
@@ -415,15 +415,9 @@ is or might be a read or a write to the same location as 
A."
   ((bv-f64-set! bv n x)            (&write-object &bytevector) &type-check))
 
 ;; Closures.
-(define (closure-field n constants)
-  (indexed-field &closure n constants))
-(define (read-closure-field n constants)
-  (logior &read (closure-field n constants)))
-(define (write-closure-field n constants)
-  (logior &write (closure-field n constants)))
-(define-primitive-effects* constants
-  ((free-ref closure idx)          (read-closure-field idx constants))
-  ((free-set! closure idx val)     (write-closure-field idx constants)))
+(define-primitive-effects* param
+  ((free-ref closure)              (&read-field &closure param))
+  ((free-set! closure val)         (&write-field &closure param)))
 
 ;; Modules.
 (define-primitive-effects
@@ -515,10 +509,10 @@ is or might be a read or a write to the same location as 
A."
 ;; so no need to have a case for them here.  (Though, see
 ;; https://jfbastien.github.io/no-sane-compiler/.)
 
-(define (primitive-effects constants name args)
+(define (primitive-effects name param args)
   (let ((proc (hashq-ref *primitive-effects* name)))
     (if proc
-        (apply proc constants args)
+        (apply proc param args)
         &all-effects)))
 
 (define (expression-effects exp constants)
@@ -539,7 +533,9 @@ is or might be a read or a write to the same location as A."
     (($ $branch k exp)
      (expression-effects exp constants))
     (($ $primcall name param args)
-     (primitive-effects constants name args))))
+     ;; FIXME: hack to still support constants table while migrating
+     ;; to immediate parameters.
+     (primitive-effects (or param constants) name args))))
 
 (define (compute-effects conts)
   (let ((constants (compute-constant-values conts)))
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 624ddf7..6a51cca 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -335,10 +335,6 @@ the definitions that are live before and after LABEL, as 
intsets."
               empty-intset)
              ;; FIXME: Move all of these instructions to use $primcall
              ;; params.
-             (($ $primcall 'free-ref #f (closure slot))
-              (defs+ closure))
-             (($ $primcall 'free-set! #f (closure slot value))
-              (defs+* (intset closure value)))
              (($ $primcall 'make-vector/immediate #f (len init))
               (defs+ init))
              (($ $primcall 'vector-ref/immediate #f (v i))