add reduction for add1/sub1 for fixnums in cptypes (#912)

Reduce (add1 <fixnum>) to (%3%$fxx+ x 1), and add equivalent reductions
for similar functions. This extends  the reductions used when the
argument is a flonum.

The new primitive $fxx+ is similat to fx+, but in case of an overflow it
calls + to get the correct result. This is slightly faster than using +
directly.

mats/cptypes.ms

@@ -893,6 +893,11 @@
   (not (cptypes-equivalent-expansion?
          '(lambda (x) (#2%exact? x))
          '(lambda (x) (#3%exact? x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (add1 x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%$fxx+ x 1))))
   (not (cptypes-equivalent-expansion?
          '(lambda (x) (when (fixnum? x)
                         (fixnum? (add1 x))))
@@ -908,11 +913,21 @@
                    (add1 x)))
     '(lambda (x) (when (flonum? x)
                    (#3%fl+ x 1.0))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (1+ x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%$fxx+ x 1))))
   (cptypes-equivalent-expansion?
     '(lambda (x) (when (flonum? x)
                    (1+ x)))
     '(lambda (x) (when (flonum? x)
                    (#3%fl+ x 1.0))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (sub1 x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%$fxx+ x -1))))
   (not (cptypes-equivalent-expansion?
          '(lambda (x) (when (fixnum? x)
                         (fixnum? (sub1 x))))
@@ -928,11 +943,21 @@
                    (sub1 x)))
     '(lambda (x) (when (flonum? x)
                    (#3%fl- x 1.0))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (1- x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%$fxx+ x -1))))
   (cptypes-equivalent-expansion?
     '(lambda (x) (when (flonum? x)
                    (1- x)))
     '(lambda (x) (when (flonum? x)
                    (#3%fl- x 1.0))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (-1+ x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%$fxx+ x -1))))
   (cptypes-equivalent-expansion?
     '(lambda (x) (when (flonum? x)
                    (-1+ x)))

release_notes/release_notes.stex

@@ -118,7 +118,8 @@ Online versions of both books can be found at
 
 \subsection{Type recovery improvements (10.2.0)}
 
-The type recovery pass has improved support for \scheme{abs} with a fixnum argument
+The type recovery pass has improved support for \scheme{abs},
+\scheme{add1} and \scheme{sub1}  with a fixnum argument
 and added support for \scheme{1+}, \scheme{1-}, and \scheme{-1+}.
 
 \subsection{Single-argument \scheme{fx-/wraparound} (10.2.0)}

s/cpprim.ss

@@ -1747,6 +1747,13 @@
                         (label ,Lfalse ,(%constant sfalse))
                         ,t))
                 (goto ,Lfalse))))])
+    (define-inline 3 $fxx+
+      [(e1 e2)
+       (bind #t (e1 e2)
+         (bind #f ([t (%inline +/ovfl ,e1 ,e2)])
+           `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code)
+                ,(build-libcall #t src sexpr + e1 e2)
+                ,t)))])
     (let ()
       (define (go src sexpr e1 e2)
         (let ([Llib (make-local-label 'Llib)])

s/cptypes.ss

@@ -1150,6 +1150,10 @@ Notes:
       (define-specialize 2 (add1 sub1 1+ 1- -1+)
         [(n) (let ([r (get-type n)])
                (cond
+                 [(predicate-implies? r 'fixnum)
+                  (let ([delta (if (memq prim-name '(add1 1+)) 1 -1)])
+                    (values `(call ,preinfo ,(lookup-primref 3 '$fxx+) ,n (quote ,delta))
+                            'exact-integer ntypes #f #f))]
                  [(predicate-implies? r 'exact-integer)
                   (values `(call ,preinfo ,pr ,n)
                           'exact-integer ntypes #f #f)]

s/mathprims.ss

@@ -523,6 +523,12 @@
        (unless (fixnum? y) (fxargerr '$fxu< y))
        (#3%$fxu< x y)))
 
+   (set! $fxx+
+     (lambda (x y)
+       (unless (fixnum? x) (fxargerr '$fxx+ x))
+       (unless (fixnum? y) (fxargerr '$fxx+ y))
+       (#3%$fxx+ x y)))
+
    (define-addop fxlogand)
    (define-addop fxlogior)
    (define-addop fxlogor)

s/primdata.ss

@@ -2017,13 +2017,13 @@
   ($fixmediate [sig [(ptr) -> (ptr)]] [flags pure discard])
   ($flvector-ref-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted pure])
   ($flvector-set!-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted discard])
-  ($<= [flags single-valued])
-  ($< [flags single-valued])
-  ($= [flags single-valued])
-  ($- [flags single-valued])
-  ($/ [flags single-valued])
-  ($* [flags single-valued])
-  ($+ [flags single-valued])
+  ($<= [sig [(who number number) -> (boolean)]] [flags pure discard safeongoodargs])
+  ($< [sig [(who number number) -> (boolean)]] [flags pure discard safeongoodargs])
+  ($= [sig [(who number number) -> (boolean)]] [flags pure discard safeongoodargs])
+  ($- [sig [(who number number) -> (number)]] [flags arith-op safeongoodargs])
+  ($/ [sig [(who number number) -> (number)]] [flags arith-op])
+  ($* [sig [(who number number) -> (number)]] [flags arith-op safeongoodargs])
+  ($+ [sig [(who number number) -> (number)]] [flags arith-op safeongoodargs])
   ($fleqv? [sig [(flonum flonum) -> (boolean)]] [flags pure mifoldable safeongoodargs])
   ($flhash [flags single-valued])
   ($flonum->digits [flags single-valued])
@@ -2212,6 +2212,7 @@
   ($fxu< [flags single-valued pure cp02])
   ($fxvector-ref-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted pure])
   ($fxvector-set!-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted discard])
+  ($fxx+ [sig [(fixnum fixnum) -> (sint)]] [flags arith-op safeongoodargs])
   ($gc-cpu-time [flags true])
   ($gc-real-time [flags true])
   ($generation [flags single-valued])

s/prims.ss

@@ -832,6 +832,10 @@
    (lambda (x y)
       ($fx+? x y)))
 
+(define $fxx+
+   (lambda (x y)
+      ($fxx+ x y)))
+
 (define $fx-?
    (lambda (x y)
       ($fx-? x y)))