X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FPPC%2FCodeGen.hs;h=0db76416eb2fd113984e0a7c4abf2d2a01948395;hb=5b1053897fa16ced293e749447e9c027d15d29f5;hp=43f384956414cc6fa295c26a3bc89d0384d3b775;hpb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;p=ghc-hetmet.git diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 43f3849..0db7641 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -w #-} ----------------------------------------------------------------------------- -- @@ -29,7 +28,6 @@ where import PPC.Instr import PPC.Cond import PPC.Regs -import PPC.RegInfo import NCGMonad import Instruction import PIC @@ -48,20 +46,16 @@ import CLabel -- The rest: import StaticFlags ( opt_PIC ) import OrdList -import qualified Outputable as O import Outputable import Unique import DynFlags import Control.Monad ( mapAndUnzipM ) import Data.Bits -import Data.Int import Data.Word -#if darwin_TARGET_OS || linux_TARGET_OS import BasicTypes import FastString -#endif -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector @@ -118,24 +112,24 @@ stmtsToInstrs stmts return (concatOL instrss) stmtToInstrs :: CmmStmt -> NatM InstrBlock -stmtToInstrs stmt = case stmt of +stmtToInstrs stmt = do + dflags <- getDynFlagsNat + case stmt of CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src | isFloatType ty -> assignReg_FltCode size reg src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignReg_I64Code reg src -#endif + | target32Bit (targetPlatform dflags) && + isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode size reg src where ty = cmmRegType reg size = cmmTypeSize ty CmmStore addr src | isFloatType ty -> assignMem_FltCode size addr src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignMem_I64Code addr src -#endif + | target32Bit (targetPlatform dflags) && + isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode size addr src where ty = cmmExprType src size = cmmTypeSize ty @@ -146,8 +140,8 @@ stmtToInstrs stmt = case stmt of CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg params -> genJump arg - CmmReturn params -> + CmmJump arg _ -> genJump arg + CmmReturn _ -> panic "stmtToInstrs: return statement should have been cps'd away" @@ -209,17 +203,6 @@ temporary, then do the other computation, and then use the temporary: -} --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) @@ -305,7 +288,7 @@ assignMem_I64Code addrTree valueTree = do assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 @@ -318,7 +301,7 @@ assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do vcode `snocOL` mov_lo `snocOL` mov_hi ) -assignReg_I64Code lvalue valueTree +assignReg_I64Code _ _ = panic "assignReg_I64Code(powerpc): invalid lvalue" @@ -378,46 +361,49 @@ iselExpr64 expr getRegister :: CmmExpr -> NatM Register +getRegister e = do dflags <- getDynFlagsNat + getRegister' dflags e -getRegister (CmmReg (CmmGlobal PicBaseReg)) +getRegister' :: DynFlags -> CmmExpr -> NatM Register + +getRegister' _ (CmmReg (CmmGlobal PicBaseReg)) = do reg <- getPicBaseNat archWordSize return (Fixed archWordSize reg nilOL) -getRegister (CmmReg reg) +getRegister' _ (CmmReg reg) = return (Fixed (cmmTypeSize (cmmRegType reg)) (getRegisterReg reg) nilOL) -getRegister tree@(CmmRegOff _ _) - = getRegister (mangleIndexTree tree) - +getRegister' dflags tree@(CmmRegOff _ _) + = getRegister' dflags (mangleIndexTree tree) -#if WORD_SIZE_IN_BITS==32 -- for 32-bit architectuers, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do +getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do +getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -#endif - - -getRegister (CmmLoad mem pk) +getRegister' _ (CmmLoad mem pk) | not (isWord64 pk) = do Amode addr addr_code <- getAmode mem @@ -427,21 +413,21 @@ getRegister (CmmLoad mem pk) where size = cmmTypeSize pk -- catch simple cases of zero- or sign-extended load -getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) -- Note: there is no Load Byte Arithmetic instruction, so no signed case here -getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) -getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do +getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) -getRegister (CmmMachOp mop [x]) -- unary MachOps +getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps = case mop of MO_Not rep -> triv_ucode_int rep NOT @@ -477,17 +463,17 @@ getRegister (CmmMachOp mop [x]) -- unary MachOps triv_ucode_float width instr = trivialUCode (floatSize width) instr x conversionNop new_size expr - = do e_code <- getRegister expr + = do e_code <- getRegister' dflags expr return (swizzleRegisterRep e_code new_size) -getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps +getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps = case mop of - MO_F_Eq w -> condFltReg EQQ x y - MO_F_Ne w -> condFltReg NE x y - MO_F_Gt w -> condFltReg GTT x y - MO_F_Ge w -> condFltReg GE x y - MO_F_Lt w -> condFltReg LTT x y - MO_F_Le w -> condFltReg LE x y + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y MO_Eq rep -> condIntReg EQQ (extendUExpr rep x) (extendUExpr rep y) MO_Ne rep -> condIntReg NE (extendUExpr rep x) (extendUExpr rep y) @@ -535,8 +521,8 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y - MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= II32): not implemented" - MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented" + MO_S_MulMayOflo _ -> panic "S_MulMayOflo (rep /= II32): not implemented" + MO_U_MulMayOflo _ -> panic "U_MulMayOflo: not implemented" MO_S_Quot rep -> trivialCodeNoImm' (intSize rep) DIVW (extendSExpr rep x) (extendSExpr rep y) MO_U_Quot rep -> trivialCodeNoImm' (intSize rep) DIVWU (extendUExpr rep x) (extendUExpr rep y) @@ -557,14 +543,14 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps triv_float :: Width -> (Size -> Reg -> Reg -> Reg -> Instr) -> NatM Register triv_float width instr = trivialCodeNoImm (floatSize width) instr x y -getRegister (CmmLit (CmmInt i rep)) +getRegister' _ (CmmLit (CmmInt i rep)) | Just imm <- makeImmediate rep True i = let code dst = unitOL (LI dst imm) in return (Any (intSize rep) code) -getRegister (CmmLit (CmmFloat f frep)) = do +getRegister' _ (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat dflags <- getDynFlagsNat dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl @@ -576,7 +562,7 @@ getRegister (CmmLit (CmmFloat f frep)) = do `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) -getRegister (CmmLit lit) +getRegister' _ (CmmLit lit) = let rep = cmmLitType lit imm = litToImm lit code dst = toOL [ @@ -585,12 +571,15 @@ getRegister (CmmLit lit) ] in return (Any (cmmTypeSize rep) code) -getRegister other = pprPanic "getRegister(ppc)" (pprExpr other) +getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) -- extend?Rep: wrap integer expression of type rep -- in a conversion to II32 +extendSExpr :: Width -> CmmExpr -> CmmExpr extendSExpr W32 x = x extendSExpr rep x = CmmMachOp (MO_SS_Conv rep W32) [x] + +extendUExpr :: Width -> CmmExpr -> CmmExpr extendUExpr W32 x = x extendUExpr rep x = CmmMachOp (MO_UU_Conv rep W32) [x] @@ -706,9 +695,9 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt rep -> condIntCode LU (extendUExpr rep x) (extendUExpr rep y) MO_U_Le rep -> condIntCode LEU (extendUExpr rep x) (extendUExpr rep y) - other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) + _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) -getCondCode other = panic "getCondCode(2)(powerpc)" +getCondCode _ = panic "getCondCode(2)(powerpc)" @@ -848,14 +837,30 @@ genCondJump id bool = do -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. -genCCall - :: CmmCallTarget -- function to call +genCCall :: CmmCallTarget -- function to call + -> HintedCmmFormals -- where to put the result + -> HintedCmmActuals -- arguments (of mixed type) + -> NatM InstrBlock +genCCall target dest_regs argsAndHints + = do dflags <- getDynFlagsNat + case platformOS (targetPlatform dflags) of + OSLinux -> genCCall' GCPLinux target dest_regs argsAndHints + OSDarwin -> genCCall' GCPDarwin target dest_regs argsAndHints + OSSolaris2 -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSMinGW32 -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSFreeBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSOpenBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSUnknown -> panic "PPC.CodeGen.genCCall: not defined for this os" + +data GenCCallPlatform = GCPLinux | GCPDarwin + +genCCall' + :: GenCCallPlatform + -> CmmCallTarget -- function to call -> HintedCmmFormals -- where to put the result -> HintedCmmActuals -- arguments (of mixed type) -> NatM InstrBlock - -#if darwin_TARGET_OS || linux_TARGET_OS {- The PowerPC calling convention for Darwin/Mac OS X is described in Apple's document @@ -894,10 +899,10 @@ genCCall -} -genCCall (CmmPrim MO_WriteBarrier) _ _ +genCCall' _ (CmmPrim MO_WriteBarrier) _ _ = return $ unitOL LWSYNC -genCCall target dest_regs argsAndHints +genCCall' gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II8,II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do @@ -908,8 +913,8 @@ genCCall target dest_regs argsAndHints (toOL []) [] (labelOrExpr, reduceToFF32) <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) - CmmCallee expr conv -> return (Right expr, False) + CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) + CmmCallee expr _ -> return (Right expr, False) CmmPrim mop -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode @@ -928,15 +933,16 @@ genCCall target dest_regs argsAndHints `snocOL` BCTRL usedRegs `appOL` codeAfter) where -#if darwin_TARGET_OS - initialStackOffset = 24 + initialStackOffset = case gcp of + GCPDarwin -> 24 + GCPLinux -> 8 -- size of linkage area + size of arguments, in bytes - stackDelta _finalStack = roundTo 16 $ (24 +) $ max 32 $ sum $ - map (widthInBytes . typeWidth) argReps -#elif linux_TARGET_OS - initialStackOffset = 8 - stackDelta finalStack = roundTo 16 finalStack -#endif + stackDelta finalStack = case gcp of + GCPDarwin -> + roundTo 16 $ (24 +) $ max 32 $ sum $ + map (widthInBytes . typeWidth) argReps + GCPLinux -> roundTo 16 finalStack + -- need to remove alignment information argsAndHints' | (CmmPrim mop) <- target, (mop == MO_Memcpy || @@ -974,40 +980,39 @@ genCCall target dest_regs argsAndHints ChildCode64 code vr_lo <- iselExpr64 arg let vr_hi = getHiVRegFromLo vr_lo -#if darwin_TARGET_OS - passArguments args - (drop 2 gprs) - fprs - (stackOffset+8) - (accumCode `appOL` code - `snocOL` storeWord vr_hi gprs stackOffset - `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) - ((take 2 gprs) ++ accumUsed) - where - storeWord vr (gpr:_) offset = MR gpr vr - storeWord vr [] offset = ST II32 vr (AddrRegImm sp (ImmInt offset)) - -#elif linux_TARGET_OS - let stackOffset' = roundTo 8 stackOffset - stackCode = accumCode `appOL` code - `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) - `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) - regCode hireg loreg = - accumCode `appOL` code - `snocOL` MR hireg vr_hi - `snocOL` MR loreg vr_lo - - case gprs of - hireg : loreg : regs | even (length gprs) -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _skipped : hireg : loreg : regs -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _ -> -- only one or no regs left - passArguments args [] fprs (stackOffset'+8) - stackCode accumUsed -#endif + case gcp of + GCPDarwin -> + do let storeWord vr (gpr:_) _ = MR gpr vr + storeWord vr [] offset + = ST II32 vr (AddrRegImm sp (ImmInt offset)) + passArguments args + (drop 2 gprs) + fprs + (stackOffset+8) + (accumCode `appOL` code + `snocOL` storeWord vr_hi gprs stackOffset + `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) + ((take 2 gprs) ++ accumUsed) + GCPLinux -> + do let stackOffset' = roundTo 8 stackOffset + stackCode = accumCode `appOL` code + `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) + `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) + regCode hireg loreg = + accumCode `appOL` code + `snocOL` MR hireg vr_hi + `snocOL` MR loreg vr_lo + + case gprs of + hireg : loreg : regs | even (length gprs) -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _skipped : hireg : loreg : regs -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _ -> -- only one or no regs left + passArguments args [] fprs (stackOffset'+8) + stackCode accumUsed passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed | reg : _ <- regs = do @@ -1015,16 +1020,16 @@ genCCall target dest_regs argsAndHints let code = case register of Fixed _ freg fcode -> fcode `snocOL` MR reg freg Any _ acode -> acode reg + stackOffsetRes = case gcp of + -- The Darwin ABI requires that we reserve + -- stack slots for register parameters + GCPDarwin -> stackOffset + stackBytes + -- ... the SysV ABI doesn't. + GCPLinux -> stackOffset passArguments args (drop nGprs gprs) (drop nFprs fprs) -#if darwin_TARGET_OS - -- The Darwin ABI requires that we reserve stack slots for register parameters - (stackOffset + stackBytes) -#elif linux_TARGET_OS - -- ... the SysV ABI doesn't. - stackOffset -#endif + stackOffsetRes (accumCode `appOL` code) (reg : accumUsed) | otherwise = do @@ -1036,29 +1041,43 @@ genCCall target dest_regs argsAndHints (accumCode `appOL` code `snocOL` ST (cmmTypeSize rep) vr stackSlot) accumUsed where -#if darwin_TARGET_OS - -- stackOffset is at least 4-byte aligned - -- The Darwin ABI is happy with that. - stackOffset' = stackOffset -#else - -- ... the SysV ABI requires 8-byte alignment for doubles. - stackOffset' | isFloatType rep && typeWidth rep == W64 = - roundTo 8 stackOffset - | otherwise = stackOffset -#endif + stackOffset' = case gcp of + GCPDarwin -> + -- stackOffset is at least 4-byte aligned + -- The Darwin ABI is happy with that. + stackOffset + GCPLinux + -- ... the SysV ABI requires 8-byte + -- alignment for doubles. + | isFloatType rep && typeWidth rep == W64 -> + roundTo 8 stackOffset + | otherwise -> + stackOffset stackSlot = AddrRegImm sp (ImmInt stackOffset') - (nGprs, nFprs, stackBytes, regs) = case cmmTypeSize rep of - II32 -> (1, 0, 4, gprs) -#if darwin_TARGET_OS - -- The Darwin ABI requires that we skip a corresponding number of GPRs when - -- we use the FPRs. - FF32 -> (1, 1, 4, fprs) - FF64 -> (2, 1, 8, fprs) -#elif linux_TARGET_OS - -- ... the SysV ABI doesn't. - FF32 -> (0, 1, 4, fprs) - FF64 -> (0, 1, 8, fprs) -#endif + (nGprs, nFprs, stackBytes, regs) + = case gcp of + GCPDarwin -> + case cmmTypeSize rep of + II32 -> (1, 0, 4, gprs) + -- The Darwin ABI requires that we skip a + -- corresponding number of GPRs when we use + -- the FPRs. + FF32 -> (1, 1, 4, fprs) + FF64 -> (2, 1, 8, fprs) + II8 -> panic "genCCall' passArguments II8" + II16 -> panic "genCCall' passArguments II16" + II64 -> panic "genCCall' passArguments II64" + FF80 -> panic "genCCall' passArguments FF80" + GCPLinux -> + case cmmTypeSize rep of + II32 -> (1, 0, 4, gprs) + -- ... the SysV ABI doesn't. + FF32 -> (0, 1, 4, fprs) + FF64 -> (0, 1, 8, fprs) + II8 -> panic "genCCall' passArguments II8" + II16 -> panic "genCCall' passArguments II16" + II64 -> panic "genCCall' passArguments II64" + FF80 -> panic "genCCall' passArguments FF80" moveResult reduceToFF32 = case dest_regs of @@ -1071,6 +1090,7 @@ genCCall target dest_regs argsAndHints | otherwise -> unitOL (MR r_dest r3) where rep = cmmRegType (CmmLocal dest) r_dest = getRegisterReg (CmmLocal dest) + _ -> panic "genCCall' moveResult: Bad dest_regs" outOfLineMachOp mop = do @@ -1124,10 +1144,6 @@ genCCall target dest_regs argsAndHints other -> pprPanic "genCCall(ppc): unknown callish op" (pprCallishMachOp other) -#else /* darwin_TARGET_OS || linux_TARGET_OS */ -genCCall = panic "PPC.CodeGen.genCCall: not defined for this os" -#endif - -- ----------------------------------------------------------------------------- -- Generating a table-branch