diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmmHeap.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 173 |
2 files changed, 171 insertions, 4 deletions
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index f64d203ee3..2151f84353 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -33,7 +33,7 @@ import StgCmmEnv import MkGraph -import Hoopl hiding ((<*>), mkBranch) +import Hoopl import SMRep import Cmm import CmmUtils diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index bd783a3b30..15020ccf7b 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -30,6 +30,8 @@ import StgCmmTicky import StgCmmHeap import StgCmmProf +import DynFlags +import Platform import BasicTypes import MkGraph import StgSyn @@ -47,6 +49,8 @@ import Outputable import StaticFlags import Util +import Control.Monad (liftM) + ------------------------------------------------------------------------ -- Primitive operations and foreign calls ------------------------------------------------------------------------ @@ -508,9 +512,172 @@ emitPrimOp r@[res] op args = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in emit stmt -emitPrimOp _ op _ - = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) - +emitPrimOp results op args + = do dflags <- getDynFlags + case callishPrimOpSupported dflags op of + Left op -> emit $ mkUnsafeCall (PrimTarget op) results args + Right gen -> gen results args + +type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () + +callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp +callishPrimOpSupported dflags op + = case op of + IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem wordWidth) + | otherwise -> Right genericIntQuotRemOp + + WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem wordWidth) + | otherwise -> Right genericWordQuotRemOp + + WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth) + | otherwise -> Right genericWordQuotRem2Op + + WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth) + | otherwise -> Right genericWordAdd2Op + + WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 wordWidth) + | otherwise -> Right genericWordMul2Op + + _ -> panic "emitPrimOp: can't translate PrimOp" (ppr op) + where + ncg = case hscTarget dflags of + HscAsm -> True + _ -> False + + x86ish = case platformArch (targetPlatform dflags) of + ArchX86 -> True + ArchX86_64 -> True + _ -> False + +genericIntQuotRemOp :: GenericOp +genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y]) +genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp" + +genericWordQuotRemOp :: GenericOp +genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y] + = emit $ mkAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*> + mkAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y]) +genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp" + +genericWordQuotRem2Op :: GenericOp +genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y] + = emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low + where 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 CmmAGraph + f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> + mkAssign (CmmLocal res_r) high) + f i acc high low = + do roverflowedBit <- newTemp ty + rhigh' <- newTemp ty + rhigh'' <- newTemp ty + rlow' <- newTemp ty + risge <- newTemp ty + racc' <- newTemp ty + let high' = CmmReg (CmmLocal rhigh') + isge = CmmReg (CmmLocal risge) + overflowedBit = CmmReg (CmmLocal roverflowedBit) + let this = catAGraphs + [mkAssign (CmmLocal roverflowedBit) + (shr high negone), + mkAssign (CmmLocal rhigh') + (or (shl high one) (shr low negone)), + mkAssign (CmmLocal rlow') + (shl low one), + mkAssign (CmmLocal risge) + (or (overflowedBit `ne` zero) + (high' `ge` arg_y)), + mkAssign (CmmLocal rhigh'') + (high' `minus` (arg_y `times` isge)), + mkAssign (CmmLocal racc') + (or (shl acc one) isge)] + rest <- f (i - 1) (CmmReg (CmmLocal racc')) + (CmmReg (CmmLocal rhigh'')) + (CmmReg (CmmLocal rlow')) + return (this <*> rest) +genericWordQuotRem2Op _ _ = panic "genericWordQuotRem2Op" + +genericWordAdd2Op :: GenericOp +genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] + = do r1 <- newTemp (cmmExprType arg_x) + r2 <- newTemp (cmmExprType arg_x) + emit $ catAGraphs + [mkAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + mkAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + mkAssign (CmmLocal res_l) + (or (toTopHalf (CmmReg (CmmLocal r2))) + (bottomHalf (CmmReg (CmmLocal r1))))] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) +genericWordAdd2Op _ _ = panic "genericWordAdd2Op" + +genericWordMul2Op :: GenericOp +genericWordMul2Op [res_h, res_l] [arg_x, arg_y] + = do let t = cmmExprType arg_x + xlyl <- liftM CmmLocal $ newTemp t + xlyh <- liftM CmmLocal $ newTemp t + xhyl <- liftM CmmLocal $ newTemp t + r <- liftM CmmLocal $ newTemp t + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + emit $ catAGraphs + [mkAssign xlyl + (mul (bottomHalf arg_x) (bottomHalf arg_y)), + mkAssign xlyh + (mul (bottomHalf arg_x) (topHalf arg_y)), + mkAssign xhyl + (mul (topHalf arg_x) (bottomHalf arg_y)), + mkAssign r + (sum [topHalf (CmmReg xlyl), + bottomHalf (CmmReg xhyl), + bottomHalf (CmmReg xlyh)]), + mkAssign (CmmLocal res_l) + (or (bottomHalf (CmmReg xlyl)) + (toTopHalf (CmmReg r))), + mkAssign (CmmLocal res_h) + (sum [mul (topHalf arg_x) (topHalf arg_y), + topHalf (CmmReg xhyl), + topHalf (CmmReg xlyh), + topHalf (CmmReg r)])] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) +genericWordMul2Op _ _ = panic "genericWordMul2Op" -- These PrimOps are NOPs in Cmm |