Add tagged and untagged arithmetic ops with immediate operands

* libguile/vm-engine.c (add/immediate, sub/immediate)
  (uadd/immediate, usub/immediate, umul/immediate): New instructions.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/slot-allocation.scm (compute-needs-slot):
* module/language/cps/types.scm:
* module/system/vm/assembler.scm (system):
* module/language/cps/effects-analysis.scm: Support
  for new instructions.

* module/language/cps/optimize.scm (optimize-first-order-cps): Move
  primcall specialization to the last step -- the only benefit of doing
  it earlier was easier reasoning about side effects, and we're already
  doing that in a more general way with (language cps types).
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
  Specialize add and sub to add/immediate and sub/immediate, and
  specialize u64 addition as well.  U64 specialization doesn't work now
  though because computing constant values doesn't work for U64s; oh
  well.

8 files changed, 153 insertions, 19 deletions

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 80ab3afd8..2f3b3fd85 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2382,7 +2382,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       BINARY_INTEGER_OP (+, scm_sum);
     }
 
-  VM_DEFINE_OP (87, unused_87, NULL, NOP)
+  /* add/immediate dst:8 src:8 imm:8
+   *
+   * Add the unsigned 8-bit value IMM to the value from SRC, and place
+   * the result in DST.
+   */
+  VM_DEFINE_OP (87, add_immediate, "add/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, src, imm;
+      SCM x;
+
+      UNPACK_8_8_8 (op, dst, src, imm);
+      x = SP_REF (src);
+
+      if (SCM_LIKELY (SCM_I_INUMP (x)))
+        {
+          scm_t_signed_bits sum = SCM_I_INUM (x) + (scm_t_signed_bits) imm;
+
+          if (SCM_LIKELY (SCM_POSFIXABLE (sum)))
+            RETURN (SCM_I_MAKINUM (sum));
+        }
+
+      RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (imm)));
+    }
 
   /* sub dst:8 a:8 b:8
    *
@@ -2393,7 +2415,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       BINARY_INTEGER_OP (-, scm_difference);
     }
 
-  VM_DEFINE_OP (89, unused_89, NULL, NOP)
+  /* sub/immediate dst:8 src:8 imm:8
+   *
+   * Subtract the unsigned 8-bit value IMM from the value in SRC, and
+   * place the result in DST.
+   */
+  VM_DEFINE_OP (89, sub_immediate, "sub/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, src, imm;
+      SCM x;
+
+      UNPACK_8_8_8 (op, dst, src, imm);
+      x = SP_REF (src);
+
+      if (SCM_LIKELY (SCM_I_INUMP (x)))
+        {
+          scm_t_signed_bits diff = SCM_I_INUM (x) - (scm_t_signed_bits) imm;
+
+          if (SCM_LIKELY (SCM_NEGFIXABLE (diff)))
+            RETURN (SCM_I_MAKINUM (diff));
+        }
+
+      RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (imm)));
+    }
 
   /* mul dst:8 a:8 b:8
    *
@@ -3400,9 +3444,57 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       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)
+  /* uadd/immediate dst:8 src:8 imm:8
+   *
+   * Add the unsigned 64-bit value from SRC with the unsigned 8-bit
+   * value IMM and place the raw unsigned 64-bit result in DST.
+   * Overflow will wrap around.
+   */
+  VM_DEFINE_OP (152, uadd_immediate, "uadd/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, src, imm;
+      scm_t_uint64 x;
+
+      UNPACK_8_8_8 (op, dst, src, imm);
+      x = SP_REF_U64 (src);
+      SP_SET_U64 (dst, x + (scm_t_uint64) imm);
+      NEXT (1);
+    }
+
+  /* usub/immediate dst:8 src:8 imm:8
+   *
+   * Subtract the unsigned 8-bit value IMM from the unsigned 64-bit
+   * value in SRC and place the raw unsigned 64-bit result in DST.
+   * Overflow will wrap around.
+   */
+  VM_DEFINE_OP (153, usub_immediate, "usub/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, src, imm;
+      scm_t_uint64 x;
+
+      UNPACK_8_8_8 (op, dst, src, imm);
+      x = SP_REF_U64 (src);
+      SP_SET_U64 (dst, x - (scm_t_uint64) imm);
+      NEXT (1);
+    }
+
+  /* umul/immediate dst:8 src:8 imm:8
+   *
+   * Multiply the unsigned 64-bit value from SRC by the unsigned 8-bit
+   * value IMM and place the raw unsigned 64-bit result in DST.
+   * Overflow will wrap around.
+   */
+  VM_DEFINE_OP (154, umul_immediate, "umul/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, src, imm;
+      scm_t_uint64 x;
+
+      UNPACK_8_8_8 (op, dst, src, imm);
+      x = SP_REF_U64 (src);
+      SP_SET_U64 (dst, x * (scm_t_uint64) imm);
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (155, unused_155, NULL, NOP)
   VM_DEFINE_OP (156, unused_156, NULL, NOP)
   VM_DEFINE_OP (157, unused_157, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 2a6370c25..9dfee572a 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -179,6 +179,19 @@
         (($ $primcall 'struct-ref/immediate (struct n))
          (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
                                     (constant n)))
+        (($ $primcall 'add/immediate (x y))
+         (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
+        (($ $primcall 'sub/immediate (x y))
+         (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
+        (($ $primcall 'uadd/immediate (x y))
+         (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
+                              (constant y)))
+        (($ $primcall 'usub/immediate (x y))
+         (emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
+                              (constant y)))
+        (($ $primcall 'umul/immediate (x y))
+         (emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
+                              (constant y)))
         (($ $primcall 'builtin-ref (name))
          (emit-builtin-ref asm (from-sp dst) (constant name)))
         (($ $primcall 'scm->f64 (src))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 21df42ccd..43ec1b037 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -418,8 +418,10 @@ is or might be a read or a write to the same location as A."
   ((u64->= . _))
   ((zero? . _)                     &type-check)
   ((add . _)                       &type-check)
+  ((add/immediate . _)             &type-check)
   ((mul . _)                       &type-check)
   ((sub . _)                       &type-check)
+  ((sub/immediate . _)             &type-check)
   ((div . _)                       &type-check)
   ((fadd . _))
   ((fsub . _))
@@ -428,6 +430,9 @@ is or might be a read or a write to the same location as A."
   ((uadd . _))
   ((usub . _))
   ((umul . _))
+  ((uadd/immediate . _))
+  ((usub/immediate . _))
+  ((umul/immediate . _))
   ((quo . _)                       &type-check)
   ((rem . _)                       &type-check)
   ((mod . _)                       &type-check)
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 7d4dc2fe2..707b68d4e 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -94,7 +94,6 @@
   (simplify #:simplify? #t)
   (contify #:contify? #t)
   (inline-constructors #:inline-constructors? #t)
-  (specialize-primcalls #:specialize-primcalls? #t)
   (elide-values #:elide-values? #t)
   (prune-bailouts #:prune-bailouts? #t)
   (peel-loops #:peel-loops? #t)
@@ -110,7 +109,8 @@
   (eliminate-common-subexpressions #:cse? #t)
   (eliminate-dead-code #:eliminate-dead-code? #t)
   (rotate-loops #:rotate-loops? #t)
-  (simplify #:simplify? #t))
+  (simplify #:simplify? #t)
+  (specialize-primcalls #:specialize-primcalls? #t))
 
 (define (cps-default-optimization-options)
   (list ;; #:split-rec? #t
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index e8519f0fa..d41013f28 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -347,6 +347,10 @@ the definitions that are live before and after LABEL, as intsets."
               (defs+ s))
              (($ $primcall 'struct-set!/immediate (s n x))
               (defs+* (intset s x)))
+             (($ $primcall (or 'add/immediate 'sub/immediate
+                               'uadd/immediate 'usub/immediate 'umul/immediate)
+                 (x y))
+              (defs+ x))
              (($ $primcall 'builtin-ref (idx))
               defs)
              (_
@@ -794,7 +798,8 @@ are comparable with eqv?.  A tmp slot may be used."
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
              (($ $primcall (or 'scm->u64 'bv-length
-                               'uadd 'usub 'umul))
+                               'uadd 'usub 'umul
+                               'uadd/immediate 'usub/immediate 'umul/immediate))
               (intmap-add representations var 'u64))
              (_
               (intmap-add representations var 'scm))))
diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
index c15fbdb3b..0c234eed3 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -33,27 +33,36 @@
 
 (define (specialize-primcalls conts)
   (let ((constants (compute-constant-values conts)))
-    (define (immediate-u8? var)
+    (define (u8? var)
       (let ((val (intmap-ref constants var (lambda (_) #f))))
         (and (exact-integer? val) (<= 0 val 255))))
     (define (specialize-primcall name args)
+      (define (rename name)
+        (build-exp ($primcall name args)))
       (match (cons name args)
-        (('make-vector (? immediate-u8? n) init) 'make-vector/immediate)
-        (('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate)
-        (('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate)
-        (('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate)
-        (('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate)
-        (('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate)
+        (('make-vector (? u8? n) init) (rename 'make-vector/immediate))
+        (('vector-ref v (? u8? n)) (rename 'vector-ref/immediate))
+        (('vector-set! v (? u8? n) x) (rename 'vector-set!/immediate))
+        (('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate))
+        (('struct-ref s (? u8? n)) (rename 'struct-ref/immediate))
+        (('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate))
+        (('add x (? u8? y)) (build-exp ($primcall 'add/immediate (x y))))
+        (('add (? u8? x) y) (build-exp ($primcall 'add/immediate (y x))))
+        (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate (x y))))
+        (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate (x y))))
+        (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate (y x))))
+        (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y))))
+        (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y))))
+        (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
         (_ #f)))
     (intmap-map
      (lambda (label cont)
        (match cont
          (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
-          (let ((name* (specialize-primcall name args)))
-            (if name*
+          (let ((exp* (specialize-primcall name args)))
+            (if exp*
                 (build-cont
-                  ($kargs names vars
-                    ($continue k src ($primcall name* args))))
+                  ($kargs names vars ($continue k src ,exp*)))
                 cont)))
          (_ cont)))
      conts)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 1a0eebbe1..6928589da 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -933,6 +933,7 @@ minimum, and maximum."
                  min* max*))))))
 
 (define-simple-type-checker (add &number &number))
+(define-type-aliases add add/immediate)
 (define-type-checker (fadd a b) #t)
 (define-type-checker (uadd a b) #t)
 (define-type-inferrer (add a b result)
@@ -949,8 +950,10 @@ minimum, and maximum."
     (if (<= max #xffffffffffffffff)
         (define! result &u64 (+ (&min a) (&min b)) max)
         (define! result &u64 0 #xffffffffffffffff))))
+(define-type-aliases uadd uadd/immediate)
 
 (define-simple-type-checker (sub &number &number))
+(define-type-aliases sub sub/immediate)
 (define-type-checker (fsub a b) #t)
 (define-type-checker (usub a b) #t)
 (define-type-inferrer (sub a b result)
@@ -967,6 +970,7 @@ minimum, and maximum."
     (if (< min 0)
         (define! result &u64 0 #xffffffffffffffff)
         (define! result &u64 min (- (&max a) (&min b))))))
+(define-type-aliases usub usub/immediate)
 
 (define-simple-type-checker (mul &number &number))
 (define-type-checker (fmul a b) #t)
@@ -1019,6 +1023,7 @@ minimum, and maximum."
     (if (<= max #xffffffffffffffff)
         (define! result &u64 (* (&min a) (&min b)) max)
         (define! result &u64 0 #xffffffffffffffff))))
+(define-type-aliases umul umul/immediate)
 
 (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 9dcd6dc79..07333112f 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -129,7 +129,9 @@
             (emit-set-car!* . emit-set-car!)
             (emit-set-cdr!* . emit-set-cdr!)
             (emit-add* . emit-add)
+            (emit-add/immediate* . emit-add/immediate)
             (emit-sub* . emit-sub)
+            (emit-sub/immediate* . emit-sub/immediate)
             (emit-mul* . emit-mul)
             (emit-div* . emit-div)
             (emit-quo* . emit-quo)
@@ -143,6 +145,9 @@
             (emit-uadd* . emit-uadd)
             (emit-usub* . emit-usub)
             (emit-umul* . emit-umul)
+            (emit-uadd/immediate* . emit-uadd/immediate)
+            (emit-usub/immediate* . emit-usub/immediate)
+            (emit-umul/immediate* . emit-umul/immediate)
             (emit-logand* . emit-logand)
             (emit-logior* . emit-logior)
             (emit-logxor* . emit-logxor)