Remaining /immediate instructions take primcall imm param

* module/language/cps/compile-bytecode.scm (compile-function): Update
  add/immediate, etc.
* module/language/cps/slot-allocation.scm (compute-needs-slot):
  Simplify.
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
  Rework for add/immediate, etc.
* module/language/cps/types.scm (define-unary-result!)
  (define-binary-result!): Take types as params instead of variables, so
  we can share this code with /imm variants.
  (add/immediate, sub/immediate, uadd/immediate, usub/immediate)
  (umul/immediate, ulsh/immediate, ursh/immediate): Update type
  inferrers.

module/language/cps/compile-bytecode.scm

@@ -182,25 +182,20 @@
          (emit-char->integer asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'integer->char #f (src))
          (emit-integer->char asm (from-sp dst) (from-sp (slot src))))
-        (($ $primcall 'add/immediate #f (x y))
+        (($ $primcall 'add/immediate y (x))
-         (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
+         (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
-        (($ $primcall 'sub/immediate #f (x y))
+        (($ $primcall 'sub/immediate y (x))
-         (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
+         (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) y))
-        (($ $primcall 'uadd/immediate #f (x y))
+        (($ $primcall 'uadd/immediate y (x))
-         (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
+         (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x)) y))
-                              (constant y)))
+        (($ $primcall 'usub/immediate y (x))
-        (($ $primcall 'usub/immediate #f (x y))
+         (emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) y))
-         (emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
+        (($ $primcall 'umul/immediate y (x))
-                              (constant y)))
+         (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) y))
-        (($ $primcall 'umul/immediate #f (x y))
+        (($ $primcall 'ursh/immediate y (x))
-         (emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
+         (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) y))
-                              (constant y)))
+        (($ $primcall 'ulsh/immediate y (x))
-        (($ $primcall 'ursh/immediate #f (x y))
+         (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
-         (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x))
-                              (constant y)))
-        (($ $primcall 'ulsh/immediate #f (x y))
-         (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x))
-                              (constant y)))
         (($ $primcall 'builtin-ref idx ())
          (emit-builtin-ref asm (from-sp dst) idx))
         (($ $primcall 'scm->f64 #f (src))

module/language/cps/slot-allocation.scm

@@ -324,24 +324,8 @@ the definitions that are live before and after LABEL, as intsets."
      (intset-union
       needs-slot
       (match cont
-        (($ $kargs _ _ ($ $continue k src exp))
+        (($ $kargs)
-         (let ((defs (get-defs label)))
+         (intset-union (get-defs label) (get-uses label)))
-           (define (defs+* uses)
-             (intset-union defs uses))
-           (define (defs+ use)
-             (intset-add defs use))
-           (match exp
-             (($ $const)
-              empty-intset)
-             ;; FIXME: Move all of these instructions to use $primcall
-             ;; params.
-             (($ $primcall (or 'add/immediate 'sub/immediate
-                               'uadd/immediate 'usub/immediate 'umul/immediate
-                               'ursh/immediate 'ulsh/immediate) #f
-                 (x y))
-              (defs+ x))
-             (_
-              (defs+* (get-uses label))))))
         (($ $kreceive arity k)
          ;; Only allocate results of function calls to slots if they are
          ;; used.

module/language/cps/specialize-primcalls.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -52,42 +52,34 @@
     (define (specialize-primcall name param args)
       (define (rename name)
         (build-exp ($primcall name param args)))
-      (match (cons name args)
+      (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...)
-        (('make-vector (? u8? n) init)
+        (match (cons name args)
-         (build-exp
+          (pat
-           ($primcall 'make-vector/immediate (intmap-ref constants n) (init))))
+           (let ((c (intmap-ref constants c)))
-        (('vector-ref v (? u8? n))
+             (build-exp ($primcall 'op c (arg ...)))))
-         (build-exp
+          ...
-           ($primcall 'vector-ref/immediate (intmap-ref constants n) (v))))
+          (_ #f)))
-        (('vector-set! v (? u8? n) x)
+      (specialize-case
-         (build-exp
+        (('make-vector (? u8? n) init) (make-vector/immediate n (init)))
-           ($primcall 'vector-set!/immediate (intmap-ref constants n) (v x))))
+        (('vector-ref v (? u8? n)) (vector-ref/immediate n (v)))
-        (('allocate-struct v (? u8? n))
+        (('vector-set! v (? u8? n) x) (vector-set!/immediate n (v x)))
-         (build-exp
+        (('allocate-struct v (? u8? n)) (allocate-struct/immediate n (v)))
-           ($primcall 'allocate-struct/immediate (intmap-ref constants n) (v))))
+        (('struct-ref s (? u8? n)) (struct-ref/immediate n (s)))
-        (('struct-ref s (? u8? n))
+        (('struct-set! s (? u8? n) x) (struct-set!/immediate n (s x)))
-         (build-exp
+        (('add x (? u8? y)) (add/immediate y (x)))
-           ($primcall 'struct-ref/immediate (intmap-ref constants n) (s))))
+        (('add (? u8? y) x) (add/immediate y (x)))
-        (('struct-set! s (? u8? n) x)
+        (('sub x (? u8? y)) (sub/immediate y (x)))
-         (build-exp
+        (('uadd x (? u8? y)) (uadd/immediate y (x)))
-           ($primcall 'struct-set!/immediate (intmap-ref constants n) (s x))))
+        (('uadd (? u8? y) x) (uadd/immediate y (x)))
-        (('add x (? u8? y)) (build-exp ($primcall 'add/immediate #f (x y))))
+        (('usub x (? u8? y)) (usub/immediate y (x)))
-        (('add (? u8? x) y) (build-exp ($primcall 'add/immediate #f (y x))))
+        (('umul x (? u8? y)) (umul/immediate y (x)))
-        (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate #f (x y))))
+        (('umul (? u8? y) x) (umul/immediate y (x)))
-        (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate #f (x y))))
+        (('ursh x (? u6? y)) (ursh/immediate y (x)))
-        (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate #f (y x))))
+        (('ulsh x (? u6? y)) (ulsh/immediate y (x)))
-        (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate #f (x y))))
+        (('scm->f64 (? f64? var)) (load-f64 var ()))
-        (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate #f (x y))))
+        (('scm->u64 (? u64? var)) (load-u64 var ()))
-        (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate #f (y x))))
+        (('scm->u64/truncate (? u64? var)) (load-u64 var ()))
-        (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate #f (x y))))
+        (('scm->s64 (? s64? var)) (load-s64 var ()))))
-        (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate #f (x y))))
-        (('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)
        (match cont
@@ -99,3 +91,7 @@
                 cont)))
          (_ cont)))
      conts)))
+
+;;; Local Variables:
+;;; eval: (put 'specialize-case 'scheme-indent-function 0)
+;;; End:

module/language/cps/types.scm

@@ -1091,27 +1091,24 @@ minimum, and maximum."
 (define-s64-comparison-inferrer (s64-> > <=))
 
 ;; Arithmetic.
-(define-syntax-rule (define-unary-result! a result min max)
+(define-syntax-rule (define-unary-result! a-type$ result min$ max$)
-  (let ((min* min)
+  (let ((min min$) (max max$) (type a-type$))
-        (max* max)
-        (type (logand (&type a) &number)))
     (cond
-     ((not (= type (&type a)))
+     ((not (type<=? type &number))
-      ;; Not a number.  Punt and do nothing.
+      ;; Not definitely a number.  Punt and do nothing.
       (define! result &all-types -inf.0 +inf.0))
      ;; Complex numbers don't have a range.
      ((eqv? type &complex)
       (define! result &complex -inf.0 +inf.0))
      (else
-      (define! result type min* max*)))))
+      (define! result type min max)))))
 
-(define-syntax-rule (define-binary-result! a b result closed? min max)
+(define-syntax-rule (define-binary-result! a-type$ b-type$ result closed?
-  (let ((min* min)
+                      min$ max$)
-        (max* max)
+  (let* ((min min$) (max max$) (a-type a-type$) (b-type b-type$)
-        (a-type (logand (&type a) &number))
+         (type (logior a-type b-type)))
-        (b-type (logand (&type b) &number)))
     (cond
-     ((or (not (= a-type (&type a))) (not (= b-type (&type b))))
+     ((not (type<=? type &number))
       ;; One input not a number.  Perhaps we end up dispatching to
       ;; GOOPS.
       (define! result &all-types -inf.0 +inf.0))
@@ -1121,33 +1118,35 @@ minimum, and maximum."
      ((or (eqv? a-type &flonum) (eqv? b-type &flonum))
       ;; If one argument is a flonum, the result will be flonum or
       ;; possibly complex.
-      (let ((result-type (logand (logior a-type b-type)
+      (let ((result-type (logand type (logior &complex &flonum))))
-                                 (logior &complex &flonum))))
+        (define! result result-type min max)))
-        (define! result result-type min* max*)))
      ;; Exact integers are closed under some operations.
-     ((and closed? (type<=? (logior a-type b-type) &exact-integer))
+     ((and closed? (type<=? type &exact-integer))
-      (define-exact-integer! result min* max*))
+      (define-exact-integer! result min max))
      (else
-      (let* ((type (logior a-type b-type))
+      (let* (;; Fractions may become integers.
-             ;; Fractions may become integers.
              (type (if (zero? (logand type &fraction))
                        type
                        (logior type &exact-integer)))
              ;; Integers may become fractions under division.
-             (type (if (or closed?
+             (type (if (or closed? (zero? (logand type &exact-integer)))
-                           (zero? (logand type (logior &exact-integer))))
                        type
                        (logior type &fraction))))
-        (define! result type min* max*))))))
+        (define! result type min max))))))
 
 (define-simple-type-checker (add &number &number))
-(define-type-aliases add add/immediate)
+(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! a b result #t
+  (define-binary-result! (&type a) (&type b) result #t
                          (+ (&min a) (&min b))
                          (+ (&max a) (&max b))))
+(define-type-inferrer/param (add/immediate param a result)
+  (let ((b-type (type-entry-type (constant-type param))))
+    (define-binary-result! (&type a) b-type result #t
+      (+ (&min a) param)
+      (+ (&max a) param))))
 (define-type-inferrer (fadd a b result)
   (define! result &f64
     (+ (&min a) (&min b))
@@ -1158,16 +1157,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-aliases uadd uadd/immediate)
+(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-simple-type-checker (sub &number &number))
-(define-type-aliases sub sub/immediate)
+(define-simple-type-checker (sub/immediate &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
+  (define-binary-result! (&type a) (&type b) result #t
                          (- (&min a) (&max b))
                          (- (&max a) (&min b))))
+(define-type-inferrer/param (sub/immediate param a result)
+  (let ((b-type (type-entry-type (constant-type param))))
+    (define-binary-result! (&type a) b-type result #t
+      (- (&min a) param)
+      (- (&max a) param))))
 (define-type-inferrer (fsub a b result)
   (define! result &f64
     (- (&min a) (&max b))
@@ -1178,7 +1187,12 @@ minimum, and maximum."
     (if (< min 0)
         (define! result &u64 0 &u64-max)
         (define! result &u64 min (- (&max/u64 a) (&min/0 b))))))
-(define-type-aliases usub usub/immediate)
+(define-type-inferrer/param (usub/immediate param a result)
+  ;; Handle wraparound.
+  (let ((min (- (&min/0 a) param)))
+    (if (< min 0)
+        (define! result &u64 0 &u64-max)
+        (define! result &u64 min (- (&max/u64 a) param)))))
 
 (define-simple-type-checker (mul &number &number))
 (define-type-checker (fmul a b) #t)
@@ -1215,7 +1229,7 @@ minimum, and maximum."
                         (mul-result-range (eqv? a b) nan-impossible?
                                           min-a max-a min-b max-b))
       (lambda (min max)
-        (define-binary-result! a b result #t min max)))))
+        (define-binary-result! (&type a) (&type b) result #t min max)))))
 (define-type-inferrer (fmul a b result)
   (let ((min-a (&min a)) (max-a (&max a))
         (min-b (&min b)) (max-b (&max b))
@@ -1231,7 +1245,12 @@ 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-aliases umul umul/immediate)
+(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-checker (div a b)
   (and (check-type a &number -inf.0 +inf.0)
@@ -1265,7 +1284,7 @@ minimum, and maximum."
     (call-with-values (lambda ()
                         (div-result-range min-a max-a min-b max-b))
       (lambda (min max)
-        (define-binary-result! a b result #f min max)))))
+        (define-binary-result! (&type a) (&type b) result #f min max)))))
 (define-type-inferrer (fdiv a b result)
   (let ((min-a (&min a)) (max-a (&max a))
         (min-b (&min b)) (max-b (&max b)))
@@ -1382,12 +1401,13 @@ minimum, and maximum."
 
 (define-simple-type-checker (ursh &u64 &u64))
 (define-type-inferrer (ursh a b result)
-  (restrict! a &u64 0 &u64-max)
-  (restrict! b &u64 0 &u64-max)
   (define! result &u64
     (ash (&min/0 a) (- (&max/u64 b)))
     (ash (&max/u64 a) (- (&min/0 b)))))
-(define-type-aliases ursh ursh/immediate)
+(define-type-inferrer/param (ursh/immediate param a result)
+  (define! result &u64
+    (ash (&min/0 a) (- param))
+    (ash (&max/u64 a) (- param))))
 
 (define-simple-type-checker (ulsh &u64 &u64))
 (define-type-inferrer (ulsh a b result)
@@ -1401,7 +1421,14 @@ minimum, and maximum."
         (ash (&max/u64 a) (&max/u64 b)))
       ;; Otherwise assume the whole range.
       (define! result &u64 0 &u64-max)))
-(define-type-aliases ulsh ulsh/immediate)
+(define-type-inferrer/param (ulsh/immediate param a result)
+  (if (and (< param 64) (<= (ash (&max/u64 a) param) &u64-max))
+      ;; No overflow; we can be precise.
+      (define! result &u64
+        (ash (&min/0 a) param)
+        (ash (&max/u64 a) param))
+      ;; Otherwise assume the whole range.
+      (define! result &u64 0 &u64-max)))
 
 (define (next-power-of-two n)
   (let lp ((out 1))