[Guile-commits] 03/16: load-f64, etc take immediate parameters

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 6be04684e677ed979d0675568cc2284ef8782327
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 1 14:10:17 2017 +0100

    load-f64, etc take immediate parameters
    
    * module/language/cps/compile-bytecode.scm (compile-function): Make
      load-f64, load-s64, and load-u64 take an immediate parameter instead
      of a CPS value.
    * module/language/cps/effects-analysis.scm: Remove CPS argument from
      immediate load instructions.
    * module/language/cps/slot-allocation.scm (compute-needs-slot): Remove
      special case for load-64 etc.
    * module/language/cps/specialize-numbers.scm
      (specialize-u64-scm-comparison): Adapt.
    * module/language/cps/specialize-primcalls.scm (specialize-primcalls):
      Adapt.
    * module/language/cps/types.scm (define-type-inferrer*): Also take param
      argument.
      (define-type-inferrer, define-predicate-inferrer): Adapt.
      (define-type-inferrer/param): New helper.
      (load-f64, load-s64, load-u64): Adapt inferrers to pass on value from
      param.
    * module/language/cps/utils.scm (compute-constant-values): Adapt.
---
 module/language/cps/compile-bytecode.scm     | 12 ++++++------
 module/language/cps/effects-analysis.scm     |  6 +++---
 module/language/cps/slot-allocation.scm      |  2 --
 module/language/cps/specialize-numbers.scm   |  6 ++----
 module/language/cps/specialize-primcalls.scm | 10 ++++++----
 module/language/cps/types.scm                | 18 ++++++++++++------
 module/language/cps/utils.scm                |  4 ++--
 7 files changed, 31 insertions(+), 27 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index d206d26..57a570f 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -206,22 +206,22 @@
          (emit-builtin-ref asm (from-sp dst) (constant name)))
         (($ $primcall 'scm->f64 #f (src))
          (emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
-        (($ $primcall 'load-f64 #f (src))
-         (emit-load-f64 asm (from-sp dst) (constant src)))
+        (($ $primcall 'load-f64 val ())
+         (emit-load-f64 asm (from-sp dst) val))
         (($ $primcall 'f64->scm #f (src))
          (emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'scm->u64 #f (src))
          (emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'scm->u64/truncate #f (src))
          (emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
-        (($ $primcall 'load-u64 #f (src))
-         (emit-load-u64 asm (from-sp dst) (constant src)))
+        (($ $primcall 'load-u64 val ())
+         (emit-load-u64 asm (from-sp dst) val))
         (($ $primcall (or 'u64->scm 'u64->scm/unlikely) #f (src))
          (emit-u64->scm asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'scm->s64 #f (src))
          (emit-scm->s64 asm (from-sp dst) (from-sp (slot src))))
-        (($ $primcall 'load-s64 #f (src))
-         (emit-load-s64 asm (from-sp dst) (constant src)))
+        (($ $primcall 'load-s64 val ())
+         (emit-load-s64 asm (from-sp dst) val))
         (($ $primcall (or 's64->scm 's64->scm/unlikely) #f (src))
          (emit-s64->scm asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'bv-length #f (bv))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 3f3d8b7..266ef5a 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -375,15 +375,15 @@ is or might be a read or a write to the same location as 
A."
 ;; Unboxed floats and integers.
 (define-primitive-effects
   ((scm->f64 _)                                                &type-check)
-  ((load-f64 _))
+  ((load-f64))
   ((f64->scm _))
   ((scm->u64 _)                                                &type-check)
   ((scm->u64/truncate _)                                       &type-check)
-  ((load-u64 _))
+  ((load-u64))
   ((u64->scm _))
   ((u64->scm/unlikely _))
   ((scm->s64 _)                                                &type-check)
-  ((load-s64 _))
+  ((load-s64))
   ((s64->scm _))
   ((s64->scm/unlikely _))
   ((untag-fixnum _)))
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 9c70a8b..624ddf7 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -335,8 +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 (or 'load-f64 'load-u64 'load-s64) #f (val))
-              empty-intset)
              (($ $primcall 'free-ref #f (closure slot))
               (defs+ closure))
              (($ $primcall 'free-set! #f (closure slot value))
diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index 3551a9c..aa08c8f 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -137,7 +137,7 @@
 (define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm)
   (let ((u64-op (symbol-append 'u64- op)))
     (with-cps cps
-      (letv u64 s64 zero z64 sunk)
+      (letv u64 s64 z64 sunk)
       (letk kheap ($kargs ('sunk) (sunk)
                     ($continue kf src
                       ($branch kt ($primcall op #f (sunk b-scm))))))
@@ -154,10 +154,8 @@
       (letk kz64 ($kargs ('z64) (z64)
                    ($continue (case op ((< <= =) kf) (else kt)) src
                      ($branch kcmp ($primcall 's64-<= #f (z64 s64))))))
-      (letk kzero ($kargs ('zero) (zero)
-                    ($continue kz64 src ($primcall 'load-s64 #f (zero)))))
       (letk ks64 ($kargs ('s64) (s64)
-                   ($continue kzero src ($const 0))))
+                   ($continue kz64 src ($primcall 'load-s64 0 ()))))
       (letk kfix ($kargs () ()
                    ($continue ks64 src
                      ($primcall 'untag-fixnum #f (b-scm)))))
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index 5b3c6df..41629f7 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -69,10 +69,12 @@
         (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate #f (y x))))
         (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate #f (x y))))
         (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate #f (x y))))
-        (('scm->f64 (? f64?)) (rename 'load-f64))
-        (('scm->u64 (? u64?)) (rename 'load-u64))
-        (('scm->u64/truncate (? u64?)) (rename 'load-u64))
-        (('scm->s64 (? s64?)) (rename 'load-s64))
+        (('scm->f64 (? f64? var))
+         (build-exp ($primcall 'load-f64 (intmap-ref constants var) ())))
+        (((or 'scm->u64 'scm->u64/truncate) (? u64? var))
+         (build-exp ($primcall 'load-u64 (intmap-ref constants var) ())))
+        (('scm->s64 (? s64? var))
+         (build-exp ($primcall 'load-s64 (intmap-ref constants var) ())))
         (_ #f)))
     (intmap-map
      (lambda (label cont)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 72570e4..414c378 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -426,7 +426,7 @@ minimum, and maximum."
        (<= min (&min arg))
        (<= (&max arg) max)))
 
-(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...)
+(define-syntax-rule (define-type-inferrer* (name param succ var ...) body ...)
   (hashq-set!
    *type-inferrers*
    'name
@@ -450,10 +450,13 @@ minimum, and maximum."
          out)))))
 
 (define-syntax-rule (define-type-inferrer (name arg ...) body ...)
-  (define-type-inferrer* (name succ arg ...) body ...))
+  (define-type-inferrer* (name param succ arg ...) body ...))
+
+(define-syntax-rule (define-type-inferrer/param (name param arg ...) body ...)
+  (define-type-inferrer* (name param succ arg ...) body ...))
 
 (define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...)
-  (define-type-inferrer* (name succ arg ...)
+  (define-type-inferrer* (name param succ arg ...)
     (let ((true? (not (zero? succ))))
       body ...)))
 
@@ -837,7 +840,8 @@ minimum, and maximum."
 (define-type-inferrer (scm->f64 scm result)
   (restrict! scm &real -inf.0 +inf.0)
   (define! result &f64 (&min scm) (&max scm)))
-(define-type-aliases scm->f64 load-f64)
+(define-type-inferrer/param (load-f64 param result)
+  (define! result &f64 param param))
 
 (define-type-checker (f64->scm f64)
   #t)
@@ -849,7 +853,8 @@ minimum, and maximum."
 (define-type-inferrer (scm->u64 scm result)
   (restrict! scm &exact-integer 0 &u64-max)
   (define! result &u64 (&min/0 scm) (&max/u64 scm)))
-(define-type-aliases scm->u64 load-u64)
+(define-type-inferrer/param (load-u64 param result)
+  (define! result &u64 param param))
 
 (define-type-checker (scm->u64/truncate scm)
   (check-type scm &exact-integer &range-min &range-max))
@@ -868,8 +873,9 @@ minimum, and maximum."
 (define-type-inferrer (scm->s64 scm result)
   (restrict! scm &exact-integer &s64-min &s64-max)
   (define! result &s64 (&min/s64 scm) (&max/s64 scm)))
-(define-type-aliases scm->s64 load-s64)
 (define-type-aliases s64->scm s64->scm/unlikely)
+(define-type-inferrer/param (load-s64 param result)
+  (define! result &s64 param param))
 
 (define-simple-type-checker (untag-fixnum &fixnum))
 (define-type-inferrer (untag-fixnum scm result)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 40445cf..01768e6 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -205,8 +205,8 @@ disjoint, an error will be signalled."
      (intmap-fold
       (lambda (var exp out)
         (match exp
-          (($ $primcall (or 'load-f64 'load-u64 'load-s64) #f (val))
-           (intmap-add! out var (intmap-ref out val)))
+          (($ $primcall (or 'load-f64 'load-u64 'load-s64) val ())
+           (intmap-add! out var val))
           ;; Punch through type conversions to allow uadd to specialize
           ;; to uadd/immediate.
           (($ $primcall 'scm->f64 #f (val))