Add a cmov# primopwip/andreask/cmov-primop

The cmov# primop allows users to force GHC to emit a conditional move
instead of a branch if so desired.

7 files changed, 66 insertions, 2 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 617abe5f9e..9aee1b55de 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -3412,6 +3412,14 @@ primop CompactSize "compactSize#" GenPrimOp
    out_of_line      = True
 
 ------------------------------------------------------------------------
+section "Cmove"
+------------------------------------------------------------------------
+
+primop CMovOp "cmov#" GenPrimOp
+   Int# -> o -> o -> (# o #)
+   { Returns the last argument if the first argument is zero, the first argument otherwise. }
+
+------------------------------------------------------------------------
 section "Unsafe pointer equality"
 --  (#1 Bad Guy: Alastair Reid :)
 ------------------------------------------------------------------------
diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
index d134fdc346..5029ca54eb 100644
--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -108,6 +108,9 @@ data MachOp
   | MO_U_Shr Width      -- unsigned shift right
   | MO_S_Shr Width      -- signed shift right
 
+  -- | Conditional move. First argument tells us which arg to select.
+  | MO_Cmov Width
+
   -- Conversions.  Some of these will be NOPs.
   -- Floating-point conversions use the signed variant.
   | MO_SF_Conv Width Width      -- Signed int -> Float
@@ -412,6 +415,7 @@ machOpResultType platform mop tys =
     MO_Shl   r          -> cmmBits r
     MO_U_Shr r          -> cmmBits r
     MO_S_Shr r          -> cmmBits r
+    MO_Cmov r           -> cmmBits r
 
     MO_SS_Conv _ to     -> cmmBits to
     MO_UU_Conv _ to     -> cmmBits to
@@ -503,6 +507,7 @@ machOpArgReps platform op =
     MO_Shl   r          -> [r, wordWidth platform]
     MO_U_Shr r          -> [r, wordWidth platform]
     MO_S_Shr r          -> [r, wordWidth platform]
+    MO_Cmov r           -> [wordWidth platform, r, r]
 
     MO_SS_Conv from _   -> [from]
     MO_UU_Conv from _   -> [from]
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index bf8c96fd14..e468cbbd6e 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -38,7 +38,7 @@ module GHC.Cmm.Utils(
         cmmNeWord, cmmEqWord,
         cmmOrWord, cmmAndWord,
         cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
-        cmmToWord,
+        cmmToWord, cmmCMov,
 
         cmmMkAssign,
 
@@ -390,6 +390,12 @@ cmmToWord platform e
     w = cmmExprWidth platform e
     word = wordWidth platform
 
+-- Might not be supported on all platforms
+cmmCMov :: Platform -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+cmmCMov platform cond x y =
+  CmmMachOp (MO_Cmov (cmmExprWidth platform x))
+    [cmmNeWord platform (cmmToWord platform cond) (zeroExpr platform),x,y]
+
 cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
 cmmMkAssign platform expr uq =
   let !ty = cmmExprType platform expr
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index 8e57473384..346b3cef6a 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -379,7 +379,11 @@ type InstrBlock
 -- | Condition codes passed up the tree.
 --
 data CondCode
-        = CondCode Bool Cond InstrBlock
+        = CondCode
+        { _cond_is_float :: Bool
+        , _cond_cond :: Cond
+        , _cond_instr :: InstrBlock
+        }
 
 
 -- | Register's passed up the tree.  If the stix code forces the register
@@ -1148,6 +1152,26 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
 
            return (Fixed format result code)
 
+getRegister' _bid _is32Bit (CmmMachOp mop [x, y, z]) = -- triadic MachOps
+    case mop of
+        MO_Cmov width -> do
+            let format = (intFormat width)
+
+            CondCode is_float cond code_cond <- getCondCode x
+            massert (not is_float)
+
+            (y_reg, code_y) <- getSomeReg y
+
+            get_code_z <- getAnyReg z
+            let cmov_code dst_reg =
+                  code_y `appOL` (get_code_z dst_reg) `appOL` code_cond `appOL`
+                        toOL [CMOV cond format (OpReg y_reg) dst_reg]
+            return $ Any format cmov_code
+        _other -> pprPanic "getRegister(x86) - trinary CmmMachOp (1)" (pprMachOp mop)
+  where
+
+
+
 
 getRegister' _ _ (CmmLoad mem pk _)
   | isFloatType pk
diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs
index 283ece1d50..f4297305dc 100644
--- a/compiler/GHC/Driver/Config/StgToCmm.hs
+++ b/compiler/GHC/Driver/Config/StgToCmm.hs
@@ -51,6 +51,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
   , stgToCmmAllowQuotRem2             = (ncg && (x86ish || ppc)) || llvm
   , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm
   , stgToCmmAllowIntMul2Instr         = (ncg && x86ish) || llvm
+  , stgToCmmAllowCMovInstr             = (ncg && x86_64)
   -- SIMD flags
   , stgToCmmVecInstrsErr  = vec_err
   , stgToCmmAvx           = isAvxEnabled                   dflags
@@ -70,6 +71,9 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
                       ArchX86    -> True
                       ArchX86_64 -> True
                       _          -> False
+          x86_64 = case platformArch platform of
+                      ArchX86_64 -> True
+                      _          -> False
           ppc     = case platformArch platform of
                       ArchPPC      -> True
                       ArchPPC_64 _ -> True
diff --git a/compiler/GHC/StgToCmm/Config.hs b/compiler/GHC/StgToCmm/Config.hs
index f2bd349ae7..8265cb10ec 100644
--- a/compiler/GHC/StgToCmm/Config.hs
+++ b/compiler/GHC/StgToCmm/Config.hs
@@ -66,6 +66,7 @@ data StgToCmmConfig = StgToCmmConfig
   , stgToCmmAllowQuotRem2             :: !Bool   -- ^ Allowed to generate QuotRem
   , stgToCmmAllowExtendedAddSubInstrs :: !Bool   -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc.
   , stgToCmmAllowIntMul2Instr         :: !Bool   -- ^ Allowed to generate IntMul2 instruction
+  , stgToCmmAllowCMovInstr            :: !Bool   -- ^ Allowed to generate conditional move instructions.
   , stgToCmmTickyAP                   :: !Bool   -- ^ Disable use of precomputed standard thunks.
   ------------------------------ SIMD flags ------------------------------------
   -- Each of these flags checks vector compatibility with the backend requested
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index e17a937a9e..9614689c04 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -341,6 +341,12 @@ emitPrimOp cfg primop =
 
   EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform)
 
+  CMovOp -> \[cond, x, y] ->
+        opIntoRegs $ \[res] -> if allowCmov
+          then emitAssign (CmmLocal res) (cmmCMov platform cond x y)
+          -- Fall back to using a branch
+          else emitGenericCMov [res] [cond, x, y]
+
   ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->
     emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])
 
@@ -1735,6 +1741,7 @@ emitPrimOp cfg primop =
   allowQuotRem2 = stgToCmmAllowQuotRem2             cfg
   allowExtAdd   = stgToCmmAllowExtendedAddSubInstrs cfg
   allowInt2Mul  = stgToCmmAllowIntMul2Instr         cfg
+  allowCmov     = stgToCmmAllowCMovInstr            cfg
 
 data PrimopCmmEmit
   -- | Out of line fake primop that's actually just a foreign call to other
@@ -2024,6 +2031,15 @@ genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]
              ]
 genericIntMul2Op _ _ = panic "genericIntMul2Op"
 
+-- | Emulate cmov by using a branch, urkh
+emitGenericCMov :: GenericOp
+emitGenericCMov [res] [cond, arg_x, arg_y]
+ = do true_lbl <- newBlockId
+      emitAssign (CmmLocal res) arg_x
+      emit =<< mkCmmIfGoto cond true_lbl
+      emitAssign (CmmLocal res) arg_y
+      emitLabel true_lbl
+emitGenericCMov _ _ = panic "genericIntMul2Op"
 ------------------------------------------------------------------------------
 -- Helpers for translating various minor variants of array indexing.