Add a quotRemWord2 primop

It allows you to do
    (high, low) `quotRem` d
provided high < d.

Currently only has an inefficient fallback implementation.

8 files changed, 94 insertions, 29 deletions

diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index d9484a6644..2bf8bc207e 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -442,6 +442,7 @@ data CallishMachOp
 
   | MO_S_QuotRem Width
   | MO_U_QuotRem Width
+  | MO_U_QuotRem2 Width
   | MO_Add2      Width
   | MO_U_Mul2    Width
 
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 346b108fa4..9515612405 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -661,11 +661,12 @@ pprCallishMachOp_for_C mop
         MO_Memmove      -> ptext (sLit "memmove")
         (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
 
-        MO_S_QuotRem {} -> unsupported
-        MO_U_QuotRem {} -> unsupported
-        MO_Add2      {} -> unsupported
-        MO_U_Mul2    {} -> unsupported
-        MO_Touch        -> unsupported
+        MO_S_QuotRem  {} -> unsupported
+        MO_U_QuotRem  {} -> unsupported
+        MO_U_QuotRem2 {} -> unsupported
+        MO_Add2       {} -> unsupported
+        MO_U_Mul2     {} -> unsupported
+        MO_Touch         -> unsupported
     where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
                             ++ " not supported!")
 
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 3f1187f6be..9165cf44bc 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -468,6 +468,59 @@ emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
                           CmmHinted arg_y NoHint]
                          CmmMayReturn
       in stmtC stmt
+emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _
+    = do let ty = cmmExprType arg_x_high
+             shl   x i = CmmMachOp (MO_Shl   wordWidth) [x, i]
+             shr   x i = CmmMachOp (MO_U_Shr wordWidth) [x, i]
+             or    x y = CmmMachOp (MO_Or    wordWidth) [x, y]
+             ge    x y = CmmMachOp (MO_U_Ge  wordWidth) [x, y]
+             ne    x y = CmmMachOp (MO_Ne    wordWidth) [x, y]
+             minus x y = CmmMachOp (MO_Sub   wordWidth) [x, y]
+             times x y = CmmMachOp (MO_Mul   wordWidth) [x, y]
+             zero   = lit 0
+             one    = lit 1
+             negone = lit (fromIntegral (widthInBits wordWidth) - 1)
+             lit i = CmmLit (CmmInt i wordWidth)
+             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt]
+             f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc,
+                                      CmmAssign (CmmLocal res_r) high]
+             f i acc high low =
+                 do roverflowedBit <- newLocalReg ty
+                    rhigh'         <- newLocalReg ty
+                    rhigh''        <- newLocalReg ty
+                    rlow'          <- newLocalReg ty
+                    risge          <- newLocalReg ty
+                    racc'          <- newLocalReg ty
+                    let high'         = CmmReg (CmmLocal rhigh')
+                        isge          = CmmReg (CmmLocal risge)
+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)
+                    let this = [CmmAssign (CmmLocal roverflowedBit)
+                                          (shr high negone),
+                                CmmAssign (CmmLocal rhigh')
+                                          (or (shl high one) (shr low negone)),
+                                CmmAssign (CmmLocal rlow')
+                                          (shl low one),
+                                CmmAssign (CmmLocal risge)
+                                          (or (overflowedBit `ne` zero)
+                                              (high' `ge` arg_y)),
+                                CmmAssign (CmmLocal rhigh'')
+                                          (high' `minus` (arg_y `times` isge)),
+                                CmmAssign (CmmLocal racc')
+                                          (or (shl acc one) isge)]
+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))
+                                      (CmmReg (CmmLocal rhigh''))
+                                      (CmmReg (CmmLocal rlow'))
+                    return (this ++ rest)
+         genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low
+         let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl))
+                            [CmmHinted res_q NoHint,
+                             CmmHinted res_r NoHint]
+                            [CmmHinted arg_x_high NoHint,
+                             CmmHinted arg_x_low NoHint,
+                             CmmHinted arg_y NoHint]
+                            CmmMayReturn
+         stmtC stmt
+
 emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
  = do r1 <- newLocalReg (cmmExprType arg_x)
       r2 <- newLocalReg (cmmExprType arg_x)
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 70fa51aaa2..74311e0a51 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -473,12 +473,13 @@ cmmPrimOpFunctions env mop
 
     (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ show (widthToLlvmInt w)
 
-    MO_S_QuotRem {} -> unsupported
-    MO_U_QuotRem {} -> unsupported
-    MO_Add2 {}      -> unsupported
-    MO_U_Mul2 {}    -> unsupported
-    MO_WriteBarrier -> unsupported
-    MO_Touch        -> unsupported
+    MO_S_QuotRem {}  -> unsupported
+    MO_U_QuotRem {}  -> unsupported
+    MO_U_QuotRem2 {} -> unsupported
+    MO_Add2 {}       -> unsupported
+    MO_U_Mul2 {}     -> unsupported
+    MO_WriteBarrier  -> unsupported
+    MO_Touch         -> unsupported
 
     where
         intrinTy1 = (if getLlvmVer env >= 28
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index a30834daf6..2b8bb62ad2 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -1145,12 +1145,13 @@ genCCall' gcp target dest_regs argsAndHints
 
                     MO_PopCnt w  -> (fsLit $ popCntLabel w, False)
 
-                    MO_S_QuotRem {} -> unsupported
-                    MO_U_QuotRem {} -> unsupported
-                    MO_Add2 {}      -> unsupported
-                    MO_U_Mul2 {}    -> unsupported
-                    MO_WriteBarrier -> unsupported
-                    MO_Touch        -> unsupported
+                    MO_S_QuotRem {}  -> unsupported
+                    MO_U_QuotRem {}  -> unsupported
+                    MO_U_QuotRem2 {} -> unsupported
+                    MO_Add2 {}       -> unsupported
+                    MO_U_Mul2 {}     -> unsupported
+                    MO_WriteBarrier  -> unsupported
+                    MO_Touch         -> unsupported
                 unsupported = panic ("outOfLineCmmOp: " ++ show mop
                                   ++ " not supported")
 
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 85fd901c42..0f3041e9a9 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -640,12 +640,13 @@ outOfLineMachOp_table mop
 
         MO_PopCnt w  -> fsLit $ popCntLabel w
 
-        MO_S_QuotRem {} -> unsupported
-        MO_U_QuotRem {} -> unsupported
-        MO_Add2 {}      -> unsupported
-        MO_U_Mul2 {}    -> unsupported
-        MO_WriteBarrier -> unsupported
-        MO_Touch        -> unsupported
+        MO_S_QuotRem {}  -> unsupported
+        MO_U_QuotRem {}  -> unsupported
+        MO_U_QuotRem2 {} -> unsupported
+        MO_Add2 {}       -> unsupported
+        MO_U_Mul2 {}     -> unsupported
+        MO_WriteBarrier  -> unsupported
+        MO_Touch         -> unsupported
     where unsupported = panic ("outOfLineCmmOp: " ++ show mop
                             ++ " not supported here")
 
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index be07078c1a..c60debab6a 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -2225,12 +2225,13 @@ outOfLineCmmOp mop res args
 
               MO_PopCnt _  -> fsLit "popcnt"
 
-              MO_S_QuotRem {} -> unsupported
-              MO_U_QuotRem {} -> unsupported
-              MO_Add2 {}      -> unsupported
-              MO_U_Mul2 {}    -> unsupported
-              MO_WriteBarrier -> unsupported
-              MO_Touch        -> unsupported
+              MO_S_QuotRem {}  -> unsupported
+              MO_U_QuotRem {}  -> unsupported
+              MO_U_QuotRem2 {} -> unsupported
+              MO_Add2 {}       -> unsupported
+              MO_U_Mul2 {}     -> unsupported
+              MO_WriteBarrier  -> unsupported
+              MO_Touch         -> unsupported
         unsupported = panic ("outOfLineCmmOp: " ++ show mop
                           ++ "not supported here")
 
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 037915abd5..b1ef1d29f8 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -294,6 +294,12 @@ primop   WordQuotRemOp "quotRemWord#" GenPrimOp
    Word# -> Word# -> (# Word#, Word# #)
    with can_fail = True
 
+-- Takes high word of dividend, then low word of dividend, then divisor.
+-- Requires that high word is not divisible by divisor.
+primop   WordQuotRem2Op "quotRemWord2#" GenPrimOp
+   Word# -> Word# -> Word# -> (# Word#, Word# #)
+   with can_fail = True
+
 primop   AndOp   "and#"   Dyadic   Word# -> Word# -> Word#
    with commutable = True