[Guile-commits] 25/41: Add unsigned 64-bit arithmetic operators: uadd, usub, umul

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit d294d5d1e19f589dd910ec269ef360484ad754e5
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 20 10:58:21 2015 +0100

    Add unsigned 64-bit arithmetic operators: uadd, usub, umul
    
    * libguile/vm-engine.c (uadd, usub, umul): New ops.
    * module/language/cps/effects-analysis.scm (uadd, usub, umul): Add
      effects analysis.
    * module/language/cps/slot-allocation.scm (compute-var-representations):
      The new ops define 'u64 values.
    * module/language/cps/types.scm (uadd, usub, umul): Add type checkers
      and inferrers.
    * module/system/vm/assembler.scm (emit-uadd, emit-usub, emit-umul): New
      assemblers.
---
 libguile/vm-engine.c                     |   45 ++++++++++++++++++++++++++++--
 module/language/cps/effects-analysis.scm |    3 ++
 module/language/cps/slot-allocation.scm  |    3 +-
 module/language/cps/types.scm            |   21 ++++++++++++++
 module/system/vm/assembler.scm           |    3 ++
 5 files changed, 71 insertions(+), 4 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e7994cd..d615af1 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3402,9 +3402,48 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       BR_U64_ARITHMETIC (<=, scm_leq_p);
     }
 
-  VM_DEFINE_OP (149, unused_149, NULL, NOP)
-  VM_DEFINE_OP (150, unused_150, NULL, NOP)
-  VM_DEFINE_OP (151, unused_151, NULL, NOP)
+  /* uadd dst:8 a:8 b:8
+   *
+   * Add A to B, and place the result in DST.  The operands and the
+   * result are unboxed unsigned 64-bit integers.  Overflow will wrap
+   * around.
+   */
+  VM_DEFINE_OP (149, uadd, "uadd", OP1 (X8_S8_S8_S8) | OP_DST)
+    {
+      scm_t_uint8 dst, a, b;
+      UNPACK_8_8_8 (op, dst, a, b);
+      SP_SET_U64 (dst, SP_REF_U64 (a) + SP_REF_U64 (b));
+      NEXT (1);
+    }
+
+  /* usub dst:8 a:8 b:8
+   *
+   * Subtract B from A, and place the result in DST.  The operands and
+   * the result are unboxed unsigned 64-bit integers.  Overflow will
+   * wrap around.
+   */
+  VM_DEFINE_OP (150, usub, "usub", OP1 (X8_S8_S8_S8) | OP_DST)
+    {
+      scm_t_uint8 dst, a, b;
+      UNPACK_8_8_8 (op, dst, a, b);
+      SP_SET_U64 (dst, SP_REF_U64 (a) - SP_REF_U64 (b));
+      NEXT (1);
+    }
+
+  /* umul dst:8 a:8 b:8
+   *
+   * Multiply A and B, and place the result in DST.  The operands and
+   * the result are unboxed unsigned 64-bit integers.  Overflow will
+   * wrap around.
+   */
+  VM_DEFINE_OP (151, umul, "umul", OP1 (X8_S8_S8_S8) | OP_DST)
+    {
+      scm_t_uint8 dst, a, b;
+      UNPACK_8_8_8 (op, dst, a, b);
+      SP_SET_U64 (dst, SP_REF_U64 (a) * SP_REF_U64 (b));
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (152, unused_152, NULL, NOP)
   VM_DEFINE_OP (153, unused_153, NULL, NOP)
   VM_DEFINE_OP (154, unused_154, NULL, NOP)
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index fc82293..9112c42 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -425,6 +425,9 @@ is or might be a read or a write to the same location as A."
   ((fsub . _))
   ((fmul . _))
   ((fdiv . _))
+  ((uadd . _))
+  ((usub . _))
+  ((umul . _))
   ((sub1 . _)                      &type-check)
   ((add1 . _)                      &type-check)
   ((quo . _)                       &type-check)
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index e540780..e8519f0 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -793,7 +793,8 @@ are comparable with eqv?.  A tmp slot may be used."
              (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
-             (($ $primcall (or 'scm->u64 'bv-length))
+             (($ $primcall (or 'scm->u64 'bv-length
+                               'uadd 'usub 'umul))
               (intmap-add representations var 'u64))
              (_
               (intmap-add representations var 'scm))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 81d2eb1..41d4f56 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -916,6 +916,7 @@ minimum, and maximum."
 
 (define-simple-type-checker (add &number &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! a b result #t
                          (+ (&min a) (&min b))
@@ -924,9 +925,16 @@ minimum, and maximum."
   (define! result &f64
     (+ (&min a) (&min b))
     (+ (&max a) (&max b))))
+(define-type-inferrer (uadd a b result)
+  ;; Handle wraparound.
+  (let ((max (+ (&max a) (&max b))))
+    (if (<= max #xffffffffffffffff)
+        (define! result &u64 (+ (&min a) (&min b)) max)
+        (define! result &u64 0 #xffffffffffffffff))))
 
 (define-simple-type-checker (sub &number &number))
 (define-type-checker (fsub a b) #t)
+(define-type-checker (usub a b) #t)
 (define-type-inferrer (sub a b result)
   (define-binary-result! a b result #t
                          (- (&min a) (&max b))
@@ -935,9 +943,16 @@ minimum, and maximum."
   (define! result &f64
     (- (&min a) (&max b))
     (- (&max a) (&min b))))
+(define-type-inferrer (usub a b result)
+  ;; Handle wraparound.
+  (let ((min (- (&min a) (&max b))))
+    (if (< min 0)
+        (define! result &u64 0 #xffffffffffffffff)
+        (define! result &u64 min (- (&max a) (&min b))))))
 
 (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))
@@ -980,6 +995,12 @@ minimum, and maximum."
                                           min-a max-a min-b max-b))
       (lambda (min max)
         (define! result &f64 min max)))))
+(define-type-inferrer (umul a b result)
+  ;; Handle wraparound.
+  (let ((max (* (&max a) (&max b))))
+    (if (<= max #xffffffffffffffff)
+        (define! result &u64 (* (&min a) (&min b)) max)
+        (define! result &u64 0 #xffffffffffffffff))))
 
 (define-type-checker (div a b)
   (and (check-type a &number -inf.0 +inf.0)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 0ee3918..76ae892 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -142,6 +142,9 @@
             (emit-fsub* . emit-fsub)
             (emit-fmul* . emit-fmul)
             (emit-fdiv* . emit-fdiv)
+            (emit-uadd* . emit-uadd)
+            (emit-usub* . emit-usub)
+            (emit-umul* . emit-umul)
             (emit-logand* . emit-logand)
             (emit-logior* . emit-logior)
             (emit-logxor* . emit-logxor)