Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/7a7f6d703a99045cb9f590c819b795409a090022 >--------------------------------------------------------------- commit 7a7f6d703a99045cb9f590c819b795409a090022 Author: Ian Lynagh <[email protected]> Date: Fri Feb 17 22:46:27 2012 +0000 Add a primop for unsigned quotRem; part of #5598 Only amd64 has an efficient implementation currently. >--------------------------------------------------------------- compiler/cmm/CmmMachOp.hs | 1 + compiler/cmm/OldCmmUtils.hs | 4 +++ compiler/cmm/PprC.hs | 1 + compiler/codeGen/CgPrimOp.hs | 8 ++++++ compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 1 + compiler/nativeGen/PPC/CodeGen.hs | 1 + compiler/nativeGen/SPARC/CodeGen.hs | 1 + compiler/nativeGen/X86/CodeGen.hs | 38 ++++++++++++++++++------------ compiler/prelude/primops.txt.pp | 4 +++ 9 files changed, 44 insertions(+), 15 deletions(-) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 967f328..d88d104 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -441,6 +441,7 @@ data CallishMachOp | MO_F32_Sqrt | MO_S_QuotRem Width + | MO_U_QuotRem Width | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index 3fc6fd4..efdeeff 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -105,5 +105,9 @@ expandCallishMachOp (MO_S_QuotRem width) [CmmHinted res_q _, CmmHinted res_r _] = Just [CmmAssign (CmmLocal res_q) (CmmMachOp (MO_S_Quot width) args'), CmmAssign (CmmLocal res_r) (CmmMachOp (MO_S_Rem width) args')] where args' = map hintlessCmm args +expandCallishMachOp (MO_U_QuotRem width) [CmmHinted res_q _, CmmHinted res_r _] args + = Just [CmmAssign (CmmLocal res_q) (CmmMachOp (MO_U_Quot width) args'), + CmmAssign (CmmLocal res_r) (CmmMachOp (MO_U_Rem width) args')] + where args' = map hintlessCmm args expandCallishMachOp _ _ _ = Nothing diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index d636c41..f3c762c 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -664,6 +664,7 @@ pprCallishMachOp_for_C mop (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> 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 f169c0c..9ec99bf 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -448,6 +448,14 @@ emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt +emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ + = let stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt emitPrimOp _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 98fb8eb..78df373 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -475,6 +475,7 @@ cmmPrimOpFunctions env mop (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w) MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index db97a8c..169cd0c 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -1148,6 +1148,7 @@ genCCall' gcp target dest_regs argsAndHints MO_PopCnt w -> (fsLit $ popCntLabel w, False) MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported unsupported = panic ("outOfLineCmmOp: " ++ show mop diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index f8e71f4..6093751 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -643,6 +643,7 @@ outOfLineMachOp_table mop MO_PopCnt w -> fsLit $ popCntLabel w MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported where unsupported = panic ("outOfLineCmmOp: " ++ show mop diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 7900b3e..ec6bf59 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1841,24 +1841,31 @@ genCCall64 target dest_regs args = -- we only cope with a single result for foreign calls outOfLineCmmOp op (Just res) args - (CmmPrim (MO_S_QuotRem width), [CmmHinted res_q _, CmmHinted res_r _]) -> - case args of - [CmmHinted arg_x _, CmmHinted arg_y _] -> - do let size = intSize width - reg_q = getRegisterReg True (CmmLocal res_q) - reg_r = getRegisterReg True (CmmLocal res_r) - (y_reg, y_code) <- getRegOrMem arg_y - x_code <- getAnyReg arg_x - return $ y_code `appOL` - x_code rax `appOL` - toOL [CLTD size, - IDIV size y_reg, - MOV size (OpReg rax) (OpReg reg_q), - MOV size (OpReg rdx) (OpReg reg_r)] - _ -> panic "genCCall64: Wrong number of arguments for MO_S_QuotRem" + (CmmPrim (MO_S_QuotRem width), _) -> divOp True width dest_regs args + (CmmPrim (MO_U_QuotRem width), _) -> divOp False width dest_regs args _ -> genCCall64' target dest_regs args + where divOp signed width [CmmHinted res_q _, CmmHinted res_r _] + [CmmHinted arg_x _, CmmHinted arg_y _] + = do let size = intSize width + reg_q = getRegisterReg True (CmmLocal res_q) + reg_r = getRegisterReg True (CmmLocal res_r) + widen | signed = CLTD size + | otherwise = XOR size (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + return $ y_code `appOL` + x_code rax `appOL` + toOL [widen, + instr size y_reg, + MOV size (OpReg rax) (OpReg reg_q), + MOV size (OpReg rdx) (OpReg reg_r)] + divOp _ _ _ _ + = panic "genCCall64: Wrong number of arguments/results for divOp" + genCCall64' :: CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) @@ -2079,6 +2086,7 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported unsupported = panic ("outOfLineCmmOp: " ++ show mop diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 183bd35..baedd14 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -280,6 +280,10 @@ primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# with can_fail = True +primop WordQuotRemOp "quotRemWord#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with can_fail = True + primop AndOp "and#" Dyadic Word# -> Word# -> Word# with commutable = True _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
