diff options
| -rw-r--r-- | compiler/cmm/CmmCvt.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/CmmMachOp.hs | 1 | ||||
| -rw-r--r-- | compiler/cmm/CmmOpt.hs | 4 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 6 | ||||
| -rw-r--r-- | compiler/cmm/CmmType.hs | 6 | ||||
| -rw-r--r-- | compiler/cmm/OldCmm.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/OldCmmUtils.hs | 14 | ||||
| -rw-r--r-- | compiler/cmm/OldPprCmm.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 9 | ||||
| -rw-r--r-- | compiler/codeGen/CgClosure.lhs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgPrimOp.hs | 64 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 21 | ||||
| -rw-r--r-- | compiler/nativeGen/PPC/CodeGen.hs | 13 | ||||
| -rw-r--r-- | compiler/nativeGen/SPARC/CodeGen.hs | 13 | ||||
| -rw-r--r-- | compiler/nativeGen/X86/CodeGen.hs | 36 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 4 |
16 files changed, 123 insertions, 79 deletions
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 1c09599156..80c6079aac 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -37,7 +37,7 @@ get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS get_conv (ForeignTarget _ fc) = Foreign fc cmm_target :: ForeignTarget -> Old.CmmCallTarget -cmm_target (PrimTarget op) = Old.CmmPrim op +cmm_target (PrimTarget op) = Old.CmmPrim op Nothing cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index d88d1043d0..3deb4feb99 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_Add2 Width | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index ae715a9eb7..8066c60157 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -61,7 +61,7 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = stmt m (CmmStore e1 e2) = expr (expr m e1) e2 stmt m (CmmCall c _ as _) = f (actuals m as) c where f m (CmmCallee e _) = expr m e - f m (CmmPrim _) = m + f m (CmmPrim _ _) = m stmt m (CmmBranch b) = b:m stmt m (CmmCondBranch e b) = b:(expr m e) stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e @@ -269,7 +269,7 @@ inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e inlineStmt u a (CmmCall target regs es ret) = CmmCall (infn target) regs es' ret where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p) = CmmPrim p + infn (CmmPrim p m) = CmmPrim p m es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 029c3323db..64b2ae410a 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -912,13 +912,13 @@ primCall results_code name args_code vols safety case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> code (emitForeignCall' PlaySafe results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) where + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where CmmInterruptible -> code (emitForeignCall' PlayInterruptible results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 27277540fe..59455d3b54 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -10,6 +10,7 @@ module CmmType , Width(..) , widthInBits, widthInBytes, widthInLog, widthFromBytes , wordWidth, halfWordWidth, cIntWidth, cLongWidth + , halfWordMask , narrowU, narrowS ) where @@ -163,6 +164,11 @@ halfWordWidth | wORD_SIZE == 4 = W16 | wORD_SIZE == 8 = W32 | otherwise = panic "MachOp.halfWordRep: Unknown word size" +halfWordMask :: Integer +halfWordMask | wORD_SIZE == 4 = 0xFFFF + | wORD_SIZE == 8 = 0xFFFFFFFF + | otherwise = panic "MachOp.halfWordMask: Unknown word size" + -- cIntRep is the Width for a C-language 'int' cIntWidth, cLongWidth :: Width #if SIZEOF_INT == 4 diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 7b5917d3bf..97fdd4aed5 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -293,5 +293,8 @@ data CmmCallTarget | CmmPrim -- Call a "primitive" (eg. sin, cos) CallishMachOp -- These might be implemented as inline -- code by the backend. - deriving Eq + -- If we don't know how to implement the + -- mach op, then we can replace it with + -- this list of statements: + (Maybe ([HintedCmmFormal] -> [HintedCmmActual] -> [CmmStmt])) diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index efdeeff6ff..0ec7a25f15 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -12,8 +12,6 @@ module OldCmmUtils( maybeAssignTemp, loadArgsIntoTemps, - expandCallishMachOp, - module CmmUtils, ) where @@ -99,15 +97,3 @@ maybeAssignTemp uniques e | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) -expandCallishMachOp :: CallishMachOp -> [HintedCmmFormal] -> [HintedCmmActual] - -> Maybe [CmmStmt] -expandCallishMachOp (MO_S_QuotRem width) [CmmHinted res_q _, CmmHinted res_r _] args - = 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/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 4b1da0b242..24821b61af 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -139,7 +139,7 @@ pprStmt platform stmt = case stmt of _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. - CmmCall (CmmPrim op) results args ret -> + CmmCall (CmmPrim op _) results args ret -> pprStmt platform (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret) where diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index f3c762c581..fc4a2dec9e 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -28,7 +28,6 @@ import BlockId import CLabel import ForeignCall import OldCmm -import OldCmmUtils import OldPprCmm () -- Utils @@ -238,11 +237,10 @@ pprStmt platform stmt = case stmt of pprCall platform cast_fn cconv results args <> semi) -- for a dynamic call, no declaration is necessary. - CmmCall (CmmPrim op) results args _ret - | Just stmts <- expandCallishMachOp op results args -> - vcat $ map (pprStmt platform) stmts + CmmCall (CmmPrim _ (Just mkStmts)) results args _ret -> + vcat $ map (pprStmt platform) (mkStmts results args) - CmmCall (CmmPrim op) results args _ret -> + CmmCall (CmmPrim op _) results args _ret -> pprCall platform ppr_fn CCallConv results args' where ppr_fn = pprCallishMachOp_for_C op @@ -665,6 +663,7 @@ pprCallishMachOp_for_C mop MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> unsupported MO_Touch -> unsupported where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop ++ " not supported!") diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index d6537c27e5..4d1ce50099 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -485,7 +485,7 @@ emitBlackHoleCode is_single_entry = do stmtsC [ CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)), - CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmMayReturn, + CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) ] \end{code} diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 9ec99bf4f8..0b0b82cc29 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -430,7 +430,7 @@ emitPrimOp [res] op args live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim prim) + (CmmPrim prim Nothing) [CmmHinted a NoHint | a<-args] -- ToDo: hints? (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky @@ -441,7 +441,14 @@ emitPrimOp [res] op args live stmtC stmt emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ - = let stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth)) + = let genericImpl [CmmHinted res_q _, CmmHinted res_r _] + [CmmHinted arg_x _, CmmHinted arg_y _] + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])] + genericImpl _ _ = panic "emitPrimOp IntQuotRemOp generic: bad lengths" + stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, @@ -449,17 +456,60 @@ emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ CmmMayReturn in stmtC stmt emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ - = let stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth)) + = let genericImpl [CmmHinted res_q _, CmmHinted res_r _] + [CmmHinted arg_x _, CmmHinted arg_y _] + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])] + genericImpl _ _ = panic "emitPrimOp WordQuotRemOp generic: bad lengths" + stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt +emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ + = do r1 <- newLocalReg (cmmExprType arg_x) + r2 <- newLocalReg (cmmExprType arg_x) + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let genericImpl [CmmHinted res_h _, CmmHinted res_l _] + [CmmHinted arg_x _, CmmHinted arg_y _] + = [CmmAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + CmmAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + CmmAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + CmmAssign (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) + genericImpl _ _ = panic "emitPrimOp WordAdd2Op generic: bad lengths" + stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) + [CmmHinted res_h NoHint, + CmmHinted res_l NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt emitPrimOp _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) +newLocalReg :: CmmType -> FCode LocalReg +newLocalReg t = do u <- newUnique + return $ LocalReg u t -- These PrimOps are NOPs in Cmm @@ -906,7 +956,7 @@ emitMemcpyCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memcpy) + (CmmPrim MO_Memcpy Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -923,7 +973,7 @@ emitMemmoveCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memmove) + (CmmPrim MO_Memmove Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -941,7 +991,7 @@ emitMemsetCall dst c n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memset) + (CmmPrim MO_Memset Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted c NoHint) , (CmmHinted n NoHint) @@ -973,7 +1023,7 @@ emitPopCntCall res x width live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim (MO_PopCnt width)) + (CmmPrim (MO_PopCnt width) Nothing) [(CmmHinted x NoHint)] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 78df37346b..0df0fe3c5b 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -15,7 +15,6 @@ import BlockId import CgUtils ( activeStgRegs, callerSaves ) import CLabel import OldCmm -import OldCmmUtils import qualified OldPprCmm as PprCmm import DynFlags @@ -173,7 +172,7 @@ genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier) _ _ _ +genCall env (CmmPrim MO_WriteBarrier _) _ _ _ | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] = return (env, nilOL, []) | getLlvmVer env > 29 = barrier env @@ -183,7 +182,7 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. -genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do +genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do let width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible @@ -203,9 +202,9 @@ genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || - op == MO_Memset || - op == MO_Memmove = do +genCall env t@(CmmPrim op _) [] args CmmMayReturn | op == MO_Memcpy || + op == MO_Memset || + op == MO_Memmove = do let (isVolTy, isVolVal) = if getLlvmVer env >= 28 then ([i1], [mkIntLit i1 0]) else ([], []) argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy @@ -223,9 +222,8 @@ genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || `appOL` trashStmts `snocOL` call return (env2, stmts, top1 ++ top2) -genCall env (CmmPrim op) results args _ - | Just stmts <- expandCallishMachOp op results args - = stmtsToInstrs env stmts (nilOL, []) +genCall env (CmmPrim _ (Just mkStmts)) results args _ + = stmtsToInstrs env (mkStmts results args) (nilOL, []) -- Handle all other foreign calls and prim ops. genCall env target res args ret = do @@ -245,7 +243,7 @@ genCall env target res args ret = do -- extract Cmm call convention let cconv = case target of CmmCallee _ conv -> conv - CmmPrim _ -> PrimCallConv + CmmPrim _ _ -> PrimCallConv -- translate to LLVM call convention let lmconv = case cconv of @@ -342,7 +340,7 @@ getFunPtr env funTy targ = case targ of (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) return (env', v2, stmts `snocOL` s1, top) - CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop + CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop where litCase name = do @@ -476,6 +474,7 @@ cmmPrimOpFunctions env mop MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> unsupported MO_WriteBarrier -> unsupported MO_Touch -> unsupported diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 169cd0cac4..9974fb582b 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -42,7 +42,6 @@ import Platform import BlockId import PprCmm ( pprExpr ) import OldCmm -import OldCmmUtils import CLabel -- The rest: @@ -899,12 +898,11 @@ genCCall' -} -genCCall' _ (CmmPrim MO_WriteBarrier) _ _ +genCCall' _ (CmmPrim MO_WriteBarrier _) _ _ = return $ unitOL LWSYNC -genCCall' _ (CmmPrim op) results args - | Just stmts <- expandCallishMachOp op results args - = stmtsToInstrs stmts +genCCall' _ (CmmPrim _ (Just mkStmts)) results args + = stmtsToInstrs (mkStmts results args) genCCall' gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) @@ -919,7 +917,7 @@ genCCall' gcp target dest_regs argsAndHints (labelOrExpr, reduceToFF32) <- case target of CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) CmmCallee expr _ -> return (Right expr, False) - CmmPrim mop -> outOfLineMachOp mop + CmmPrim mop _ -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 @@ -948,7 +946,7 @@ genCCall' gcp target dest_regs argsAndHints GCPLinux -> roundTo 16 finalStack -- need to remove alignment information - argsAndHints' | (CmmPrim mop) <- target, + argsAndHints' | (CmmPrim mop _) <- target, (mop == MO_Memcpy || mop == MO_Memset || mop == MO_Memmove) @@ -1149,6 +1147,7 @@ genCCall' gcp target dest_regs argsAndHints MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> 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 6093751595..f5ee02204f 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -39,7 +39,6 @@ import NCGMonad -- Our intermediate code: import BlockId import OldCmm -import OldCmmUtils import PIC import Reg import CLabel @@ -381,17 +380,16 @@ genCCall -- -- In the SPARC case we don't need a barrier. -- -genCCall (CmmPrim (MO_WriteBarrier)) _ _ +genCCall (CmmPrim (MO_WriteBarrier) _) _ _ = do return nilOL -genCCall (CmmPrim op) results args - | Just stmts <- expandCallishMachOp op results args - = stmtsToInstrs stmts +genCCall (CmmPrim _ (Just mkStmts)) results args + = stmtsToInstrs (mkStmts results args) genCCall target dest_regs argsAndHints = do -- need to remove alignment information - let argsAndHints' | (CmmPrim mop) <- target, + let argsAndHints' | (CmmPrim mop _) <- target, (mop == MO_Memcpy || mop == MO_Memset || mop == MO_Memmove) @@ -423,7 +421,7 @@ genCCall target dest_regs argsAndHints -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - CmmPrim mop + CmmPrim mop _ -> do res <- outOfLineMachOp mop lblOrMopExpr <- case res of Left lbl -> do @@ -644,6 +642,7 @@ outOfLineMachOp_table mop MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> 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 7a3f93d057..3963d86f52 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -41,7 +41,6 @@ import BlockId import Module ( primPackageId ) import PprCmm () import OldCmm -import OldCmmUtils import OldPprCmm () import CLabel @@ -1520,7 +1519,7 @@ genCCall -- Unroll memcpy calls if the source and destination pointers are at -- least DWORD aligned and the number of bytes to copy isn't too -- large. Otherwise, call C's memcpy. -genCCall is32Bit (CmmPrim MO_Memcpy) _ +genCCall is32Bit (CmmPrim MO_Memcpy _) _ [CmmHinted dst _, CmmHinted src _, CmmHinted (CmmLit (CmmInt n _)) _, CmmHinted (CmmLit (CmmInt align _)) _] @@ -1563,7 +1562,7 @@ genCCall is32Bit (CmmPrim MO_Memcpy) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_Memset) _ +genCCall _ (CmmPrim MO_Memset _) _ [CmmHinted dst _, CmmHinted (CmmLit (CmmInt c _)) _, CmmHinted (CmmLit (CmmInt n _)) _, @@ -1602,11 +1601,11 @@ genCCall _ (CmmPrim MO_Memset) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_WriteBarrier) _ _ = return nilOL +genCCall _ (CmmPrim MO_WriteBarrier _) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -genCCall is32Bit (CmmPrim (MO_PopCnt width)) dest_regs@[CmmHinted dst _] +genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _] args@[CmmHinted src _] = do sse4_2 <- sse4_2Enabled if sse4_2 @@ -1642,10 +1641,10 @@ genCCall32 :: CmmCallTarget -- function to call genCCall32 target dest_regs args = case (target, dest_regs) of -- void return type prim op - (CmmPrim op, []) -> + (CmmPrim op _, []) -> outOfLineCmmOp op Nothing args -- we only cope with a single result for foreign calls - (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do + (CmmPrim op _, [r_hinted@(CmmHinted r _)]) -> do l1 <- getNewLabelNat l2 <- getNewLabelNat sse2 <- sse2Enabled @@ -1677,9 +1676,8 @@ genCCall32 target dest_regs args = = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" ++ show (length args) ++ ")" - (CmmPrim op, results) - | Just stmts <- expandCallishMachOp op results args -> - stmtsToInstrs stmts + (CmmPrim _ (Just mkStmts), results) -> + stmtsToInstrs (mkStmts results args) _ -> do let @@ -1710,7 +1708,7 @@ genCCall32 target dest_regs args = -> do { (dyn_r, dyn_c) <- getSomeReg expr ; ASSERT( isWord32 (cmmExprType expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - CmmPrim _ + CmmPrim _ _ -> panic $ "genCCall: Can't handle CmmPrim call type here, error " ++ "probably because too many return values." @@ -1833,20 +1831,19 @@ genCCall64 :: CmmCallTarget -- function to call genCCall64 target dest_regs args = case (target, dest_regs) of - (CmmPrim op, []) -> + (CmmPrim op _, []) -> -- void return type prim op outOfLineCmmOp op Nothing args - (CmmPrim op, [res]) -> + (CmmPrim op _, [res]) -> -- we only cope with a single result for foreign calls outOfLineCmmOp op (Just res) args - (CmmPrim (MO_S_QuotRem width), _) -> divOp True width dest_regs args - (CmmPrim (MO_U_QuotRem width), _) -> divOp False width dest_regs args + (CmmPrim (MO_S_QuotRem width) _, _) -> divOp True width dest_regs args + (CmmPrim (MO_U_QuotRem width) _, _) -> divOp False width dest_regs args - (CmmPrim op, results) - | Just stmts <- expandCallishMachOp op results args -> - stmtsToInstrs stmts + (CmmPrim _ (Just mkStmts), results) -> + stmtsToInstrs (mkStmts results args) _ -> genCCall64' target dest_regs args @@ -1915,7 +1912,7 @@ genCCall64' target dest_regs args = do CmmCallee expr conv -> do (dyn_r, dyn_c) <- getSomeReg expr return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - CmmPrim _ + CmmPrim _ _ -> panic $ "genCCall: Can't handle CmmPrim call type here, error " ++ "probably because too many return values." @@ -2091,6 +2088,7 @@ outOfLineCmmOp mop res args MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> 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 baedd14411..69503b1188 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -269,6 +269,10 @@ primtype Word# primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# with commutable = True +primop WordAdd2Op "plusWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# |