[Guile-commits] 03/30: Better support for unboxed signed arithmetic

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 5fbd4b8f9ea6af69085c4a6ffe784845b10b6315
Author: Andy Wingo <address@hidden>
Date:   Mon Nov 20 15:18:02 2017 +0100

    Better support for unboxed signed arithmetic
    
    * module/language/cps/primitives.scm (*macro-instruction-arities*):
      Declare new u64->s64, s64->u64, sadd, ssub, smul, sadd/immediate,
      ssub/immediate, smul/immediate, slsh, and slsh/immediate primcalls
      that don't have corresponding VM instructions.
    * module/language/cps/effects-analysis.scm: The new instructions are
      effect-free.
    * module/language/cps/reify-primitives.scm (wrap-unary, wrap-binary):
      (wrap-binary/exp, reify-primitives): Add horrible code that turns
      e.g. sadd into a series of s64->u64, uadd, and then u64->s64.  This
      way we keep our ability to do range inference on unboxed signed
      arithmetic, but we still bottom out to the same instructions for both
      unboxed signed and unboxed unsigned arithmetic.
    * module/language/cps/types.scm: Add type inferrers for new
      instructions.  Remove type checkers for some effect-free primitives.
    * module/language/cps/compile-bytecode.scm (compile-function): Add
      pseudo-emitter for u64->s64 and s64->u64 no-ops.
---
 module/language/cps/compile-bytecode.scm |  2 +
 module/language/cps/effects-analysis.scm | 10 ++++
 module/language/cps/primitives.scm       | 12 ++++-
 module/language/cps/reify-primitives.scm | 86 +++++++++++++++++++++++++++++++-
 module/language/cps/slot-allocation.scm  |  4 +-
 module/language/cps/types.scm            | 62 +++++++++++++++++++++--
 6 files changed, 168 insertions(+), 8 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 6391a67..dfd8129 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -133,6 +133,8 @@
       (match exp
         (($ $values (arg))
          (maybe-mov dst (slot arg)))
+        (($ $primcall (or 's64->u64 'u64->s64) #f (arg))
+         (maybe-mov dst (slot arg)))
         (($ $const exp)
          (emit-load-constant asm (from-sp dst) exp))
         (($ $primcall 'load-const/unlikely exp ())
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 5ef22c2..52f0d5b 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -375,6 +375,8 @@ is or might be a read or a write to the same location as A."
   ((load-s64))
   ((s64->scm _))
   ((s64->scm/unlikely _))
+  ((u64->s64 _))
+  ((s64->u64 _))
   ((untag-fixnum _))
   ((tag-fixnum _))
   ((tag-fixnum/unlikely _)))
@@ -453,6 +455,12 @@ is or might be a read or a write to the same location as 
A."
   ((uadd/immediate . _))
   ((usub/immediate . _))
   ((umul/immediate . _))
+  ((sadd . _))
+  ((ssub . _))
+  ((smul . _))
+  ((sadd/immediate . _))
+  ((ssub/immediate . _))
+  ((smul/immediate . _))
   ((quo . _)                       &type-check)
   ((rem . _)                       &type-check)
   ((mod . _)                       &type-check)
@@ -482,9 +490,11 @@ is or might be a read or a write to the same location as 
A."
   ((ursh . _))
   ((srsh . _))
   ((ulsh . _))
+  ((slsh . _))
   ((ursh/immediate . _))
   ((srsh/immediate . _))
   ((ulsh/immediate . _))
+  ((slsh/immediate . _))
   ((logtest a b)                   &type-check)
   ((logbit? a b)                   &type-check)
   ((sqrt _)                        &type-check)
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
index c9688d1..5e102d8 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -66,7 +66,17 @@
     (bytevector-ieee-double-native-set! . bv-f64-set!)))
 
 (define *macro-instruction-arities*
-  '((u64->scm/unlikely . (1 . 1))
+  '((u64->s64 . (1 . 1))
+    (s64->u64 . (1 . 1))
+    (sadd . (2 . 1))
+    (ssub . (2 . 1))
+    (smul . (2 . 1))
+    (sadd/immediate . (1 . 1))
+    (ssub/immediate . (1 . 1))
+    (smul/immediate . (1 . 1))
+    (slsh . (2 . 1))
+    (slsh/immediate . (1 . 1))
+    (u64->scm/unlikely . (1 . 1))
     (s64->scm/unlikely . (1 . 1))
     (tag-fixnum/unlikely . (1 . 1))
     (load-const/unlikely . (0 . 1))
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index bac85ad..71e1ba9 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -121,6 +121,50 @@
     (_
      (with-cps cps k))))
 
+(define (wrap-unary cps k src wrap unwrap op param a)
+  (with-cps cps
+    (letv a* res*)
+    (letk kres ($kargs ('res*) (res*)
+                 ($continue k src
+                   ($primcall 'u64->s64 #f (res*)))))
+    (letk ka ($kargs ('a*) (a*)
+               ($continue kres src
+                 ($primcall op param (a*)))))
+    (build-term
+      ($continue ka src
+        ($primcall 's64->u64 #f (a))))))
+
+(define (wrap-binary cps k src wrap unwrap op param a b)
+  (with-cps cps
+    (letv a* b* res*)
+    (letk kres ($kargs ('res*) (res*)
+                 ($continue k src
+                   ($primcall 'u64->s64 #f (res*)))))
+    (letk kb ($kargs ('b*) (b*)
+               ($continue kres src
+                 ($primcall op param (a* b*)))))
+    (letk ka ($kargs ('a*) (a*)
+               ($continue kb src
+                 ($primcall 's64->u64 #f (b)))))
+    (build-term
+      ($continue ka src
+        ($primcall 's64->u64 #f (a))))))
+
+(define (wrap-binary/exp cps k src wrap unwrap op param a b-exp)
+  (with-cps cps
+    (letv a* b* res*)
+    (letk kres ($kargs ('res*) (res*)
+                 ($continue k src
+                   ($primcall 'u64->s64 #f (res*)))))
+    (letk kb ($kargs ('b*) (b*)
+               ($continue kres src
+                 ($primcall op param (a* b*)))))
+    (letk ka ($kargs ('a*) (a*)
+               ($continue kb src ,b-exp)))
+    (build-term
+      ($continue ka src
+        ($primcall 's64->u64 #f (a))))))
+
 (define (reify-primitives cps)
   (define (visit-cont label cont cps)
     (define (resolve-prim cps name k src)
@@ -203,7 +247,47 @@
               ;; ((ursh/immediate (u6? y) x) (ursh x y))
               ;; ((srsh/immediate (u6? y) x) (srsh x y))
               ;; ((ulsh/immediate (u6? y) x) (ulsh x y))
-              (_ cps))))))
+              (_
+               (match (cons name args)
+                 (((or 'sadd 'ssub 'smul) a b)
+                  (let ((op (match name
+                              ('sadd 'uadd) ('ssub 'usub) ('smul 'umul))))
+                    (with-cps cps
+                      (let$ body
+                            (wrap-binary k src 's64->u64 'u64->s64 op #f a b))
+                      (setk label ($kargs names vars ,body)))))
+                 (((or 'sadd/immediate 'ssub/immediate 'smul/immediate) a)
+                  (if (u8? param)
+                      (let ((op (match name
+                                  ('sadd/immediate 'uadd/immediate)
+                                  ('ssub/immediate 'usub/immediate)
+                                  ('smul/immediate 'umul/immediate))))
+                        (with-cps cps
+                          (let$ body (wrap-unary k src 's64->u64 'u64->s64 op 
param a))
+                          (setk label ($kargs names vars ,body))))
+                      (let* ((op (match name
+                                   ('sadd/immediate 'uadd)
+                                   ('ssub/immediate 'usub)
+                                   ('smul/immediate 'umul)))
+                             (param (logand param (1- (ash 1 64))))
+                             (exp (build-exp ($primcall 'load-u64 param ()))))
+                        (with-cps cps
+                          (let$ body (wrap-binary/exp k src 's64->u64 'u64-s64
+                                                      op #f a exp))
+                          (setk label ($kargs names vars ,body))))))
+                 (('slsh a b)
+                  (let ((op 'ulsh)
+                        (exp (build-exp ($values (b)))))
+                    (with-cps cps
+                      (let$ body (wrap-binary/exp k src 's64->u64 'u64-s64
+                                                  op #f a exp))
+                      (setk label ($kargs names vars ,body)))))
+                 (('slsh/immediate a)
+                  (let ((op 'ulsh/immediate))
+                    (with-cps cps
+                      (let$ body (wrap-unary k src 's64->u64 'u64->s64 op 
param a))
+                      (setk label ($kargs names vars ,body)))))
+                 (_ cps))))))))
         (param (error "unexpected param to reified primcall" name))
         (else
          (with-cps cps
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 17471c6..992639f 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -768,7 +768,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
              (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
-                               'char->integer
+                               'char->integer 's64->u64
                                'bv-length 'vector-length 'string-length
                                'uadd 'usub 'umul
                                'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
@@ -777,7 +777,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref))
               (intmap-add representations var 'u64 meet-s64-u64))
              (($ $primcall (or 'untag-fixnum
-                               'scm->s64 'load-s64
+                               'scm->s64 'load-s64 'u64->s64
                                'srsh 'srsh/immediate
                                'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref))
               (intmap-add representations var 's64 meet-s64-u64))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 3edd9ef..8ff7556 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -676,6 +676,16 @@ minimum, and maximum."
     (define! result (type-entry-type ent)
       (type-entry-min ent) (type-entry-max ent))))
 
+(define-type-inferrer (u64->s64 u64 s64)
+  (if (<= (&max u64) &s64-max)
+      (define! s64 &s64 (&min u64) (&max u64))
+      (define! s64 &s64 &s64-min &s64-max)))
+
+(define-type-inferrer (s64->u64 s64 u64)
+  (if (<= 0 (&min s64))
+      (define! u64 &u64 (&min s64) (&max s64))
+      (define! u64 &u64 0 &u64-max)))
+
 
 
 ;;;
@@ -1094,8 +1104,6 @@ minimum, and maximum."
 
 (define-simple-type-checker (add &number &number))
 (define-simple-type-checker (add/immediate &number))
-(define-type-checker (fadd a b) #t)
-(define-type-checker (uadd a b) #t)
 (define-type-inferrer (add a b result)
   (define-binary-result! (&type a) (&type b) result #t
                          (+ (&min a) (&min b))
@@ -1115,12 +1123,26 @@ minimum, and maximum."
     (if (<= max &u64-max)
         (define! result &u64 (+ (&min/0 a) (&min/0 b)) max)
         (define! result &u64 0 &u64-max))))
+(define-type-inferrer (sadd a b result)
+  ;; Handle wraparound.
+  (let ((min (+ (&min/s64 a) (&min/s64 b)))
+        (max (+ (&max/s64 a) (&max/s64 b))))
+    (if (<= &s64-min min max &s64-max)
+        (define! result &s64 min max)
+        (define! result &s64 &s64-min &s64-max))))
 (define-type-inferrer/param (uadd/immediate param a result)
   ;; Handle wraparound.
   (let ((max (+ (&max/u64 a) param)))
     (if (<= max &u64-max)
         (define! result &u64 (+ (&min/0 a) param) max)
         (define! result &u64 0 &u64-max))))
+(define-type-inferrer/param (sadd/immediate param a result)
+  ;; Handle wraparound.
+  (let ((min (+ (&min/s64 a) param))
+        (max (+ (&max/s64 a) param)))
+    (if (<= &s64-min min max &s64-max)
+        (define! result &s64 min max)
+        (define! result &s64 &s64-min &s64-max))))
 
 (define-simple-type-checker (sub &number &number))
 (define-simple-type-checker (sub/immediate &number))
@@ -1153,8 +1175,6 @@ minimum, and maximum."
         (define! result &u64 min (- (&max/u64 a) param)))))
 
 (define-simple-type-checker (mul &number &number))
-(define-type-checker (fmul a b) #t)
-(define-type-checker (umul a b) #t)
 (define (mul-result-range same? nan-impossible? min-a max-a min-b max-b)
   (define (nan* a b)
     (if (and (or (and (inf? a) (zero? b))
@@ -1203,12 +1223,32 @@ minimum, and maximum."
     (if (<= max &u64-max)
         (define! result &u64 (* (&min/0 a) (&min/0 b)) max)
         (define! result &u64 0 &u64-max))))
+(define-type-inferrer (smul a b result)
+  (call-with-values (lambda ()
+                      (mul-result-range (eqv? a b) #t
+                                        (&min/s64 a) (&max/s64 a)
+                                        (&min/s64 b) (&max/s64 b)))
+    (lambda (min max)
+      ;; Handle wraparound.
+      (if (<= &s64-min min max &s64-max)
+          (define! result &s64 min max)
+          (define! result &s64 &s64-min &s64-max)))))
 (define-type-inferrer/param (umul/immediate param a result)
   ;; Handle wraparound.
   (let ((max (* (&max/u64 a) param)))
     (if (<= max &u64-max)
         (define! result &u64 (* (&min/0 a) param) max)
         (define! result &u64 0 &u64-max))))
+(define-type-inferrer/param (smul/immediate param a result)
+  (call-with-values (lambda ()
+                      (mul-result-range #f #t
+                                        (&min/s64 a) (&max/s64 a)
+                                        param param))
+    (lambda (min max)
+      ;; Handle wraparound.
+      (if (<= &s64-min min max &s64-max)
+          (define! result &s64 min max)
+          (define! result &s64 &s64-min &s64-max)))))
 
 (define-type-checker (div a b)
   (and (check-type a &number -inf.0 +inf.0)
@@ -1422,6 +1462,20 @@ minimum, and maximum."
       ;; Otherwise assume the whole range.
       (define! result &u64 0 &u64-max)))
 
+(define-type-inferrer (slsh a b result)
+  (let-values (((min max) (compute-ash-range (&min a) (&max a)
+                                             (min 63 (&min/0 b))
+                                             (min 63 (&max/u64 b)))))
+    (if (<= &s64-min min max &s64-max)
+        (define! result &s64 min max)
+        (define! result &s64 &s64-min &s64-max))))
+(define-type-inferrer (slsh/immediate param a result)
+  (let-values (((min max) (compute-ash-range (&min a) (&max a)
+                                             param param)))
+    (if (<= &s64-min min max &s64-max)
+        (define! result &s64 min max)
+        (define! result &s64 &s64-min &s64-max))))
+
 (define (next-power-of-two n)
   (let lp ((out 1))
     (if (< n out)