add reductions for + in cptypes

Reduce + with some combintations of values that are
known at compile time to be real

(+ <fx> <fx> ...) => ($fxx+ <fx> <fx> ...)
(+ <fl> <fx> ...) => (fl+ <fl> (fixnum->flonum <fx>) ...)
(+ <fl> <real> ...) => (fl+ <fl> (real->flonum <real>) ...)
(+ <fl> <fl> ...) => (fl+ <fl> <fl>)

with some special cases for 0, in particular

(+ <fl> 1 ...) => (fl+ <fl> 1.0 ...)
(+ <fl> 0 ...) => (fl+ <fl> -0.0 ...)
(+ 1.0 0 ...) => (fl+ 1.0 0.0 ...)

Author: gus-massa

mats/cptypes.ms

@@ -59,6 +59,23 @@
                      #;[optimize-level (max (optimize-level) 2)])
         (expand/optimize y)))]))
 
+(define-syntax cptypes/first-equivalent-expansion?
+  ; When run-cp0 is call, use first #3%$cptypes and
+  ; then twice the cp0 function provided.
+  ; This checks that cptypes.ss doesn't mess up unusual combinations
+  ; that are reduced by cp0.
+  (syntax-rules ()
+    [(_ x y)
+     (equivalent-expansion?
+      (parameterize ([run-cp0 (lambda (cp0 c) (cp0 (cp0 (#3%$cptypes c))))]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize x))
+      (parameterize ([run-cp0 (lambda (cp0 c) (cp0 (cp0 (#3%$cptypes c))))]
+                     [#%$suppress-primitive-inlining #f]
+                     #;[optimize-level (max (optimize-level) 2)])
+        (expand/optimize y)))]))
+
 (mat cptypes-handcoded
   (cptypes-equivalent-expansion?
     '(vector? (vector))  ;actually reduced by folding, not cptypes 
@@ -658,6 +675,7 @@
   (test-chain* '(fixnum? integer? real?))
   (test-chain* '(fixnum? exact? number?)) ; exact? may raise an error
   (test-chain* '(bignum? exact? number?)) ; exact? may raise an error
+  (test-chain '(fixnum? (lambda (x) (and (integer? x) (exact? x))) (lambda (x) (and (number? x) (exact? x))) number?))
   (test-chain '((lambda (x) (eqv? x (expt 256 100))) bignum? integer? real? number?))
   (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?))
   (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? cflonum? number?))
@@ -1006,6 +1024,100 @@
                 '(flonum? real? (lambda (x) (and (integer? x) (exact? x)))))
 )
 
+(mat cptypes-plus
+  (test-closed1 '(+ (lambda (x) (+ x 1)) (lambda (x) (+ x x)))
+                '(flonum? real? (lambda (x) (and (integer? x) (exact? x))) (lambda (x) (and (number? x) (exact? x)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (when (and (fixnum? x) (fixnum? y))
+                     (+ x y)))
+    '(lambda (x y) (when (and (fixnum? x) (fixnum? y))
+                     (#3%$fxx+ x y))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (when (and (flonum? x) (flonum? y))
+                     (+ x y)))
+    '(lambda (x y) (when (and (flonum? x) (flonum? y))
+                     (#3%fl+ x y))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x y) (when (and (number? x) (number? y))
+                     (+ x y)))
+    '(lambda (x y) (when (and (number? x) (number? y))
+                     (#3%+ x y))))
+  ; in cp0, partial-folder reverses (+ x 1) to (+ 1 x)
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (+ 1 x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%$fxx+ 1 x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (flonum? x)
+                   (+ 1 x)))
+    '(lambda (x) (when (flonum? x)
+                   (#3%fl+ 1.0 x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (number? x)
+                   (+ 1 x)))
+    '(lambda (x) (when (number? x)
+                   (#3%+ 1 x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (+ 1.0 x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%fl+ 1.0 (fixnum->flonum x)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (+ -0.0 x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%fl+ -0.0 (if (#3%eq? x 0) -0.0 (fixnum->flonum x))))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (bignum? x)
+                   (+ -0.0 x)))
+    '(lambda (x) (when (bignum? x)
+                   (#3%fl+ -0.0 (real->flonum x)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (flonum? x)
+                   (+ 1.0 x)))
+    '(lambda (x) (when (flonum? x)
+                   (#3%fl+ 1.0 x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (number? x)
+                   (+ 1.0 x)))
+    '(lambda (x) (when (number? x)
+                   (#3%+ 1.0 x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (fixnum? x)
+                   (+ 1 x x)))
+    '(lambda (x) (when (fixnum? x)
+                   (#3%$fxx+ 1 x x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (flonum? x)
+                   (+ 1 x x)))
+    '(lambda (x) (when (flonum? x)
+                   (#3%fl+ 1.0 x x))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (number? x)
+                   (+ 1 x x)))
+    '(lambda (x) (when (number? x)
+                   (#3%+ 1 x x))))
+  (cptypes/first-equivalent-expansion?
+    '(lambda (x) (+))
+    '(lambda (x) 0))
+  (cptypes/first-equivalent-expansion?
+    '(lambda (x) (+ 0))
+    '(lambda (x) 0))
+  (cptypes/first-equivalent-expansion?
+    '(lambda (x) (+ 0 0))
+    '(lambda (x) 0))
+  (cptypes/first-equivalent-expansion?
+    '(lambda (x) (+ 0 0.0))
+    '(lambda (x) 0.0))
+  (cptypes/first-equivalent-expansion?
+    '(lambda (x) (+ 0 -0.0))
+    '(lambda (x) -0.0))
+  (cptypes/first-equivalent-expansion?
+    '(lambda (x) (+ 0.0 -0.0))
+    '(lambda (x) 0.0))
+)
+
 (mat cptypes-rest-argument
   (cptypes/nocp0-equivalent-expansion?
     '((lambda (x . r) (pair? r)) 1)

s/cp0.ss

@@ -3077,6 +3077,7 @@
         ; the multiply case.  maybe shouldn't bother with nans anyway.
         (partial-folder plus + + 0 generic-nan?)
         (partial-folder plus fx+ + 0 (lambda (x) #f) 3)
+        (partial-folder plus $fxx+ + 0 (lambda (x) #f))
         (r6rs-fixnum-partial-folder plus r6rs:fx+ fx+ + 0 (lambda (x) #f) 3)
         (r6rs-fixnum-partial-folder plus fx+/wraparound fx+/wraparound + 0 (lambda (x) #f) 3)
         (partial-folder plus fl+ fl+ -0.0 fl-nan? #f obviously-fl?)

s/cpprim.ss

@@ -1750,12 +1750,16 @@
                         ,t))
                 (goto ,Lfalse))))])
     (define-inline 3 $fxx+
+      [() `(immediate ,(fix 0))]
+      [(e) (ensure-single-valued e)]
       [(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)))])
+                ,t)))]
+      [e* #f])
+
     (let ()
       (define (go src sexpr e1 e2)
         (let ([Llib (make-local-label 'Llib)])

s/cptypes-lattice.ss

@@ -66,6 +66,11 @@
    real-pred
    number-pred
    flzero-pred
+   flinteger-pred
+   exact-real-pred
+   exact-pred
+   inexact-pred
+   integer-pred
    $fixmediate-pred
    $list-pred ; immutable lists
    list-pair-pred

s/cptypes.ss

@@ -355,6 +355,49 @@ Notes:
              [(ref ,maybe-src ,x) (and (not (prelex-assigned x)) x)]
              [else #f])))
 
+    (define (real-expr->flonum-expr x r)
+      ; Transform 0 into 0.0 as usual
+      ; Assume (predicate-implies r real-pred)
+      (cond
+        [(and (Lsrc? r)
+              (nanopass-case (Lsrc Expr) r
+                [(quote ,d) d]
+                [else #f])) =>
+         (lambda (d) (make-1seq 'value x `(quote ,(real->flonum d))))]
+        [(predicate-implies? r flonum-pred)
+         x]
+        [else
+         (let ([->flonum-name (if (predicate-implies? r 'fixnum)
+                                  'fixnum->flonum
+                                  'real->flonum)])
+         `(call ,(make-preinfo-call) ,(lookup-primref 3 ->flonum-name) ,x))]))
+
+    (define (real-expr->flonum-expr/- x r)
+      ; Transform 0 into -0.0 instead of 0.0
+      ; Assume (predicate-implies r real-pred)
+      (cond
+        [(and (Lsrc? r)
+              (nanopass-case (Lsrc Expr) r
+                [(quote ,d) d]
+                [else #f])) =>
+         (lambda (d) (make-1seq 'value x `(quote ,(if (eqv? d 0) -0.0 (real->flonum d)))))]
+        [(predicate-implies? r flonum-pred)
+         x]
+        [else
+         (let ([->flonum-name (if (predicate-implies? r 'fixnum)
+                                  'fixnum->flonum
+                                  'real->flonum)])
+           (cond
+             [(predicate-disjoint? r `(quote 0))
+              `(call ,(make-preinfo-call) ,(lookup-primref 3 ->flonum-name) ,x)] 
+             [else
+              (build-let 'value (list x) (list r)
+                (lambda (x*)
+                  (let ([x (car x*)])
+                    `(if (call ,(make-preinfo-call) ,(lookup-primref 3 'eq?) ,x (quote 0))
+                         (quote -0.0)
+                         (call ,(make-preinfo-call) ,(lookup-primref 3 ->flonum-name) ,x)))))]))]))
+
     (define (filter/head+rest pred? l)
       ; (filter/head+rest odd? '(1 3 2 5 4 6))
       ; ==> (values '(1 3) '(2 5 4 6))
@@ -1141,6 +1184,71 @@ Notes:
                                   (and (eq? ctxt 'test)
                                        (pred-env-add/ref ntypes val (rtd->record-predicate rtd #t) plxc))
                                   #f)]))])
+      
+      (let ()
+        (define (predicate-implies-real? r) (predicate-implies? r real-pred))
+        (define (predicate-implies-fixnum? r) (predicate-implies? r 'fixnum))
+        (define (predicate-implies-integer? r) (predicate-implies? r integer-pred))
+        (define (predicate-implies-flonum? r) (predicate-implies? r flonum-pred))
+        (define (predicate-implies-exact? r) (predicate-implies? r exact-pred))
+        (define (predicate-implies-inexact? r) (predicate-implies? r inexact-pred))
+
+        (define (predicate-close/plus r*)
+          (cond
+            [(andmap predicate-implies-exact? r*)
+             (if (andmap predicate-implies-real? r*)
+                 (if (andmap predicate-implies-integer? r*)
+                     'exact-integer
+                     exact-real-pred)
+                 exact-pred)]
+            [(ormap predicate-implies-inexact? r*)
+             (if (andmap predicate-implies-real? r*)
+                 flonum-pred
+                 inexact-pred)]
+            [else
+             (if (andmap predicate-implies-real? r*)
+                 real-pred
+                 number-pred)]))
+
+      (define-specialize 2 +
+        [() (values `(quote 0) `(quote 0) ntypes #f #f)]
+        [(x) (values `(call ,preinfo ,pr ,x)
+                     (predicate-intersect (get-type x) number-pred) ntypes #f #f)]
+        [x* ; x* has at least 2 arguments
+            (let* ([r* (get-type x*)]
+                   [ret (predicate-close/plus
+                          (map (lambda (r) (predicate-intersect r number-pred)) r*))]
+                   [ir (and (andmap predicate-implies-real? r*)
+                            (cond
+                              [(andmap predicate-implies-fixnum? r*)
+                               `(call ,preinfo ,(lookup-primref 3 '$fxx+) ,x* ...)]
+                              [(and (or (enable-arithmetic-left-associative)
+                                        (fx= (length r*) 2))
+                                    ; at least one of the first two is a flonum
+                                    (or (predicate-implies-flonum? (car r*))
+                                        (predicate-implies-flonum? (cadr r*))))
+                               (cond
+                                 [(and (predicate-disjoint? (car r*) `(quote -0.0))
+                                       (predicate-disjoint? (cadr r*) `(quote -0.0)))
+                                  ; use 0.0 in the first two and -0.0 in the others
+                                  `(call ,preinfo ,(lookup-primref 3 'fl+)
+                                                  ,(real-expr->flonum-expr (car x*) (car r*))
+                                                  ,(real-expr->flonum-expr (cadr x*) (cadr r*))
+                                                  ,(map real-expr->flonum-expr/- (cddr x*) (cddr r*)) ...)]
+                                 [else
+                                  `(call ,preinfo ,(lookup-primref 3 'fl+)
+                                                  ,(map real-expr->flonum-expr/- x* r*) ...)])]
+                              [(and ; all or all but one are flonums, in case they are reordered
+                                    (let-values ([(head* rest*)
+                                                  (filter/head+rest predicate-implies-flonum? r*)])
+                                      (or (null? rest*)
+                                          (andmap predicate-implies-flonum? (cdr rest*)))))
+                               `(call ,preinfo ,(lookup-primref 3 'fl+)
+                                               ,(map real-expr->flonum-expr/- x* r*) ...)]
+                              [else
+                               #f]))])
+              (values (or ir `(call ,preinfo ,pr ,x* ...)) ret ntypes #f #f))])
+      )
 
       (define-specialize 2 (add1 sub1 1+ 1- -1+)
         [(n) (let ([r (get-type n)])

s/mathprims.ss

@@ -524,10 +524,27 @@
        (#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)))
+     (case-lambda
+       [(x1 x2)
+        (unless (fixnum? x1) (fxargerr '$fxx+ x1))
+        (unless (fixnum? x2) (fxargerr '$fxx+ x2))
+        (#3%$fxx+ x1 x2)]
+       [(x1 x2 x3)
+        (unless (fixnum? x1) (fxargerr '$fxx+ x1))
+        (unless (fixnum? x2) (fxargerr '$fxx+ x2))
+        (unless (fixnum? x3) (fxargerr '$fxx+ x3))
+         (#3%+ (#3%$fxx+ x1 x2) x3)]
+       [(x1 x2 x3 . rest)
+        (unless (fixnum? x1) (fxargerr '$fxx+ x1))
+        (unless (fixnum? x2) (fxargerr '$fxx+ x2))
+        (let loop ([x1 (#3%$fxx+ x1 x2)] [x3 x3] [rest rest])
+          (unless (fixnum? x3) (fxargerr '$fxx+ x3))
+            (let ([x (#3%+ x1 x3)])
+               (if (null? rest) x (loop x (car rest) (cdr rest)))))]
+       [(x1)
+        (unless (fixnum? x1) (fxargerr '$fxx+ x1))
+        x1]
+       [() 0]))
 
    (define-addop fxlogand)
    (define-addop fxlogior)

s/primdata.ss

@@ -211,7 +211,7 @@
   (nan? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
   (max [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs cptypes2])
   (min [sig [(real real ...) -> (real)]] [flags arith-op mifoldable discard safeongoodargs ieee r5rs cptypes2])
-  (+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
+  (+ [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs cptypes2])
   (* [sig [(number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
   (- [sig [(number number ...) -> (number)]] [flags arith-op partial-folder safeongoodargs ieee r5rs])
   (/ [sig [(number number ...) -> (number)]] [flags arith-op partial-folder ieee r5rs])
@@ -2215,7 +2215,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])
+  ($fxx+ [sig [(fixnum ...) -> (sint)]] [flags arith-op partial-folder safeongoodargs])
   ($gc-cpu-time [flags true])
   ($gc-real-time [flags true])
   ($generation [flags single-valued])

s/prims.ss

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