From 070dd62d0d7d7a11cef052db7648d382add774cf Mon Sep 17 00:00:00 2001
From: Gustavo Massaccesi <gustavo@oma.org.ar>
Date: Sun, 8 Oct 2017 23:25:43 -0300
Subject: [PATCH] fix cp0 reduction of fx[+-*]/carry and their signatures

  cp0.ss
  primdata.ss
  fx.ms

original commit: 8c0ec93c9eb16bae8a920bb9b5e2f9d3e96ed250
---
 LOG           |  4 ++++
 mats/fx.ms    | 18 ++++++++++++++++++
 s/cp0.ss      |  4 ++--
 s/primdata.ss |  6 +++---
 4 files changed, 27 insertions(+), 5 deletions(-)

diff --git a/LOG b/LOG
index 8ee86aeaa3..7f05f860fe 100644
--- a/LOG
+++ b/LOG
@@ -584,3 +584,7 @@
     3.ms
 - removed a useless check in foreign-alloc
     record.ss
+- fix cp0 reduction of fx[+-*]/carry and their signatures
+    cp0.ss
+    primdata.ss
+    fx.ms
diff --git a/mats/fx.ms b/mats/fx.ms
index 0aabaa625d..7654f5064b 100644
--- a/mats/fx.ms
+++ b/mats/fx.ms
@@ -2600,6 +2600,12 @@
               (errorf #f "failed for ~s, ~s, ~s" x y z)))
           (f (fx- n 1)))))
     #t)
+  (let-values ([(r c) (fx+/carry 100 20 3)])
+    (and (= r 123) (= c 0)))
+  (equal?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(fx+/carry 100 20 3)))
+      '(#3%values 123 0))
 )
 
 (mat fx-/carry
@@ -2642,6 +2648,12 @@
               (errorf #f "failed for ~s, ~s, ~s" x y z)))
           (f (fx- n 1)))))
     #t)
+  (let-values ([(r c) (fx-/carry 100 20 3)])
+    (and (= r 77) (= c 0)))
+  (equal?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(fx-/carry 100 20 3)))
+      '(#3%values 77 0))
 )
 
 (mat fx*/carry
@@ -2684,6 +2696,12 @@
               (errorf #f "failed for ~s, ~s, ~s" x y z)))
           (f (fx- n 1)))))
     #t)
+  (let-values ([(r c) (fx*/carry 100 20 3)])
+    (and (= r 2003) (= c 0)))
+  (equal?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize '(fx*/carry 100 20 3)))
+      '(#3%values 2003 0))
 )
 
 (mat fxrotate-bit-field
diff --git a/s/cp0.ss b/s/cp0.ss
index a192b17442..e8f6145d8e 100644
--- a/s/cp0.ss
+++ b/s/cp0.ss
@@ -2583,8 +2583,8 @@
                    (build-primcall 3 'values
                      (let ([s (base-op dx dy dz)])
                        (list
-                         (mod0 s (expt 2 (constant fixnum-bits)))
-                         (div0 s (expt 2 (constant fixnum-bits))))))))))
+                         `(quote ,(mod0 s (expt 2 (constant fixnum-bits))))
+                         `(quote ,(div0 s (expt 2 (constant fixnum-bits)))))))))))
         (define-syntax define-inline-carry-op
           (syntax-rules ()
             [(_ op base-op)
diff --git a/s/primdata.ss b/s/primdata.ss
index a1e326723e..5bd0c3411b 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -61,9 +61,9 @@
   (fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard])
   (fxdiv0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxmod0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
-  (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
+  (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02])
+  (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02])
+  (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02])
   (fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
   (fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
   (fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])