Add subWordC# on x86ish

This adds a subWordC# primop which implements subtraction with overflow
reporting.

Reviewers: tibbe, goldfire, rwbarton, bgamari, austin, hvr

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1334

GHC Trac Issues: #10962

14 files changed, 68 insertions, 21 deletions

diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index f3f9e74a0b..a8cbd682e6 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -549,6 +549,7 @@ data CallishMachOp
   | MO_U_QuotRem Width
   | MO_U_QuotRem2 Width
   | MO_Add2      Width
+  | MO_SubWordC  Width
   | MO_AddIntC   Width
   | MO_SubIntC   Width
   | MO_U_Mul2    Width
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 365aa5990b..719d753a57 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -763,6 +763,7 @@ pprCallishMachOp_for_C mop
         MO_U_QuotRem  {} -> unsupported
         MO_U_QuotRem2 {} -> unsupported
         MO_Add2       {} -> unsupported
+        MO_SubWordC   {} -> unsupported
         MO_AddIntC    {} -> unsupported
         MO_SubIntC    {} -> unsupported
         MO_U_Mul2     {} -> unsupported
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 4400d72639..5d3b94f090 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -824,6 +824,10 @@ callishPrimOpSupported dflags op
                          || llvm      -> Left (MO_Add2       (wordWidth dflags))
                      | otherwise      -> Right genericWordAdd2Op
 
+      WordSubCOp     | (ncg && x86ish)
+                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))
+                     | otherwise      -> Right genericWordSubCOp
+
       IntAddCOp      | (ncg && x86ish)
                          || llvm      -> Left (MO_AddIntC    (wordWidth dflags))
                      | otherwise      -> Right genericIntAddCOp
@@ -940,6 +944,19 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
                    (bottomHalf (CmmReg (CmmLocal r1))))]
 genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
 
+genericWordSubCOp :: GenericOp
+genericWordSubCOp [res_r, res_c] [aa, bb] = do
+  dflags <- getDynFlags
+  emit $ catAGraphs
+    [ -- Put the result into 'res_r'.
+      mkAssign (CmmLocal res_r) $
+        CmmMachOp (mo_wordSub dflags) [aa, bb]
+      -- Set 'res_c' to 1 if 'bb > aa' and to 0 otherwise.
+    , mkAssign (CmmLocal res_c) $
+        CmmMachOp (mo_wordUGt dflags) [bb, aa]
+    ]
+genericWordSubCOp _ _ = panic "genericWordSubCOp"
+
 genericIntAddCOp :: GenericOp
 genericIntAddCOp [res_r, res_c] [aa, bb]
 {-
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index f1ced7ced8..b754a93b44 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -366,6 +366,9 @@ genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
 genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
     genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
 
+genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
 -- Handle all other foreign calls and prim ops.
 genCall target res args = runStmtsDecls $ do
     dflags <- lift $ getDynFlags
@@ -472,8 +475,12 @@ genCall target res args = runStmtsDecls $ do
 genCallWithOverflow
   :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
 genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
-    -- So far this was only tested for the following three CallishMachOps.
-    MASSERT( (op `elem` [MO_Add2 w, MO_AddIntC w, MO_SubIntC w]) )
+    -- So far this was only tested for the following four CallishMachOps.
+    MASSERT( (op `elem` [ MO_Add2 w
+                        , MO_AddIntC w
+                        , MO_SubIntC w
+                        , MO_SubWordC w
+                        ]) )
     let width = widthToLlvmInt w
     -- This will do most of the work of generating the call to the intrinsic and
     -- extracting the values from the struct.
@@ -728,6 +735,8 @@ cmmPrimOpFunctions mop = do
                              ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."
                              ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
 
     MO_S_QuotRem {}  -> unsupported
     MO_U_QuotRem {}  -> unsupported
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 379bfe2167..e2d86a93aa 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -1468,6 +1468,7 @@ genCCall' dflags gcp target dest_regs args
                     MO_U_QuotRem {}  -> unsupported
                     MO_U_QuotRem2 {} -> unsupported
                     MO_Add2 {}       -> unsupported
+                    MO_SubWordC {}   -> unsupported
                     MO_AddIntC {}    -> unsupported
                     MO_SubIntC {}    -> unsupported
                     MO_U_Mul2 {}     -> unsupported
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index eca171b597..330d4fae10 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -660,6 +660,7 @@ outOfLineMachOp_table mop
         MO_U_QuotRem {}  -> unsupported
         MO_U_QuotRem2 {} -> unsupported
         MO_Add2 {}       -> unsupported
+        MO_SubWordC {}   -> unsupported
         MO_AddIntC {}    -> unsupported
         MO_SubIntC {}    -> unsupported
         MO_U_Mul2 {}     -> unsupported
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 1d517b95dd..30ecc2db8b 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -2065,10 +2065,12 @@ genCCall _ is32Bit target dest_regs args = do
                           ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)
                return code
         _ -> panic "genCCall: Wrong number of arguments/results for add2"
+    (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->
+        addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args
     (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->
-        addSubIntC platform ADD_CC (Just . ADD_CC) width res_r res_c args
+        addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args
     (PrimTarget (MO_SubIntC width), [res_r, res_c]) ->
-        addSubIntC platform SUB_CC (const Nothing) width res_r res_c args
+        addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args
     (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->
         case args of
         [arg_x, arg_y] ->
@@ -2122,7 +2124,8 @@ genCCall _ is32Bit target dest_regs args = do
         divOp _ _ _ _ _ _ _
             = panic "genCCall: Wrong number of results for divOp"
 
-        addSubIntC platform instr mrevinstr width res_r res_c [arg_x, arg_y]
+        addSubIntC platform instr mrevinstr cond width
+                   res_r res_c [arg_x, arg_y]
             = do let format = intFormat width
                  rCode <- anyReg =<< trivialCode width (instr format)
                                        (mrevinstr format) arg_x arg_y
@@ -2130,10 +2133,11 @@ genCCall _ is32Bit target dest_regs args = do
                  let reg_c = getRegisterReg platform True (CmmLocal res_c)
                      reg_r = getRegisterReg platform True (CmmLocal res_r)
                      code = rCode reg_r `snocOL`
-                            SETCC OFLO (OpReg reg_tmp) `snocOL`
+                            SETCC cond (OpReg reg_tmp) `snocOL`
                             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)
+
                  return code
-        addSubIntC _ _ _ _ _ _ _
+        addSubIntC _ _ _ _ _ _ _ _
             = panic "genCCall: Wrong number of arguments/results for addSubIntC"
 
 genCCall32' :: DynFlags
@@ -2576,6 +2580,7 @@ outOfLineCmmOp mop res args
               MO_Add2 {}       -> unsupported
               MO_AddIntC {}    -> unsupported
               MO_SubIntC {}    -> unsupported
+              MO_SubWordC {}   -> unsupported
               MO_U_Mul2 {}     -> unsupported
               MO_WriteBarrier  -> unsupported
               MO_Touch         -> unsupported
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index e060deb747..c16646e0f6 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -316,6 +316,11 @@ primtype Word#
 primop   WordAddOp   "plusWord#"   Dyadic   Word# -> Word# -> Word#
    with commutable = True
 
+primop   WordSubCOp   "subWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)
+         {Subtract unsigned integers reporting overflow.
+          The first element of the pair is the result.  The second element is
+          the carry flag, which is nonzero on overflow.}
+
 -- Returns (# high, low #) (or equivalently, (# carry, low #))
 primop   WordAdd2Op  "plusWord2#"  GenPrimOp
    Word# -> Word# -> (# Word#, Word# #)
diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs
index 23296604c6..dedf4f8790 100644
--- a/libraries/base/GHC/Natural.hs
+++ b/libraries/base/GHC/Natural.hs
@@ -396,13 +396,6 @@ minusNaturalMaybe (NatJ# x) (NatJ# y)
   where
     res = minusBigNat x y
 
--- | Helper for 'minusNatural' and 'minusNaturalMaybe'
-subWordC# :: Word# -> Word# -> (# Word#, Int# #)
-subWordC# x# y# = (# d#, c# #)
-  where
-    d# = x# `minusWord#` y#
-    c# = d# `gtWord#` x#
-
 -- | Convert 'BigNat' to 'Natural'.
 -- Throws 'Underflow' if passed a 'nullBigNat'.
 bigNatToNatural :: BigNat -> Natural
diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs
index fd7901a6c9..5bc52539fd 100644
--- a/libraries/integer-gmp/src/GHC/Integer/Type.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs
@@ -1988,13 +1988,6 @@ cmpW# x# y#
   | True                      = GT
 {-# INLINE cmpW# #-}
 
-subWordC# :: Word# -> Word# -> (# Word#, Int# #)
-subWordC# x# y# = (# d#, c# #)
-  where
-    d# = x# `minusWord#` y#
-    c# = d# `gtWord#` x#
-{-# INLINE subWordC# #-}
-
 bitWord# :: Int# -> Word#
 bitWord# = uncheckedShiftL# 1##
 {-# INLINE bitWord# #-}
diff --git a/testsuite/tests/numeric/should_run/T10962.hs b/testsuite/tests/numeric/should_run/T10962.hs
new file mode 100644
index 0000000000..896c9e987f
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T10962.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash     #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import GHC.Base
+
+main :: IO ()
+main = do
+  -- Overflow.
+  let (# w1, i1 #) = subWordC# 1## 3##
+  print (W# w1, I# i1)
+
+  -- No overflow.
+  let (# w2, i2 #) = subWordC# 3## 1##
+  print (W# w2, I# i2)
diff --git a/testsuite/tests/numeric/should_run/T10962.stdout-ws-32 b/testsuite/tests/numeric/should_run/T10962.stdout-ws-32
new file mode 100644
index 0000000000..a1dec8410a
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T10962.stdout-ws-32
@@ -0,0 +1,2 @@
+(4294967294,1)
+(2,0)
diff --git a/testsuite/tests/numeric/should_run/T10962.stdout-ws-64 b/testsuite/tests/numeric/should_run/T10962.stdout-ws-64
new file mode 100644
index 0000000000..853bf94a61
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T10962.stdout-ws-64
@@ -0,0 +1,2 @@
+(18446744073709551614,1)
+(2,0)
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index 27dccc7286..7ebdd44cbd 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -64,3 +64,4 @@ test('T8726', normal, compile_and_run, [''])
 test('CarryOverflow', omit_ways(['ghci']), compile_and_run, [''])
 test('T9810', normal, compile_and_run, [''])
 test('T10011', normal, compile_and_run, [''])
+test('T10962', omit_ways(['ghci']), compile_and_run, [''])