X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FPPC%2FCodeGen.hs;h=ae8ef406881cb563d5d85ddb0d5ec0ee00ebb28b;hp=d3ec27f45c63d3dfe05167a5cd67f02f14a6c007;hb=93d6c9d532b678a91bafd4bf5f5f10c4f4b6d9b9;hpb=f9288086f935c97812b2d80defcff38baf7b6a6c diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index d3ec27f..ae8ef40 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -15,6 +15,7 @@ module PPC.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -22,7 +23,7 @@ where #include "HsVersions.h" #include "nativeGen/NCG.h" -#include "MachDeps.h" +#include "../includes/MachDeps.h" -- NCG stuff: import PPC.Instr @@ -35,12 +36,13 @@ import PIC import Size import RegClass import Reg +import TargetReg import Platform -- Our intermediate code: import BlockId import PprCmm ( pprExpr ) -import Cmm +import OldCmm import CLabel -- The rest: @@ -48,6 +50,7 @@ import StaticFlags ( opt_PIC ) import OrdList import qualified Outputable as O import Outputable +import Unique import DynFlags import Control.Monad ( mapAndUnzipM ) @@ -73,10 +76,10 @@ cmmTopCodeGen -> RawCmmTop -> NatM [NatCmmTop Instr] -cmmTopCodeGen dflags (CmmProc info lab params (ListGraph blocks)) = do +cmmTopCodeGen dflags (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags case picBaseMb of @@ -176,15 +179,15 @@ swizzleRegisterRep (Any _ codefn) size = Any size codefn getRegisterReg :: CmmReg -> Reg getRegisterReg (CmmLocal (LocalReg u pk)) - = mkVReg u (cmmTypeSize pk) + = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) getRegisterReg (CmmGlobal mid) - = case get_GlobalReg_reg_or_addr mid of - Left reg@(RegReal _) -> reg - _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence ... + = case globalRegMaybe mid of + Just reg -> reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... {- @@ -220,8 +223,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel id +jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -305,7 +308,7 @@ assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let - r_dst_lo = mkVReg u_dst II32 + r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo mov_lo = MR r_dst_lo r_src_lo @@ -329,7 +332,7 @@ iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do rlo iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty - = return (ChildCode64 nilOL (mkVReg vu II32)) + = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat II32 @@ -376,6 +379,11 @@ iselExpr64 expr getRegister :: CmmExpr -> NatM Register +getRegister (CmmReg (CmmGlobal PicBaseReg)) + = do + reg <- getPicBaseNat archWordSize + return (Fixed archWordSize reg nilOL) + getRegister (CmmReg reg) = return (Fixed (cmmTypeSize (cmmRegType reg)) (getRegisterReg reg) nilOL) @@ -413,7 +421,7 @@ getRegister (CmmLoad mem pk) | not (isWord64 pk) = do Amode addr addr_code <- getAmode mem - let code dst = ASSERT((regClass dst == RcDouble) == isFloatType pk) + let code dst = ASSERT((targetClassOfReg dst == RcDouble) == isFloatType pk) addr_code `snocOL` LD size dst addr return (Any size code) where size = cmmTypeSize pk @@ -791,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl)) genJump tree = do (target,code) <- getSomeReg tree - return (code `snocOL` MTCTR target `snocOL` BCTR []) + return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) -- ----------------------------------------------------------------------------- @@ -902,7 +910,7 @@ genCCall target dest_regs argsAndHints (labelOrExpr, reduceToFF32) <- case target of CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) CmmCallee expr conv -> return (Right expr, False) - CmmPrim mop -> outOfLineFloatOp mop + CmmPrim mop -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 @@ -929,7 +937,17 @@ genCCall target dest_regs argsAndHints initialStackOffset = 8 stackDelta finalStack = roundTo 16 finalStack #endif - args = map hintlessCmm argsAndHints + -- need to remove alignment information + argsAndHints' | (CmmPrim mop) <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + -> init argsAndHints + + | otherwise + -> argsAndHints + + args = map hintlessCmm argsAndHints' argReps = map cmmExprType args roundTo a x | x `mod` a == 0 = x @@ -1054,11 +1072,11 @@ genCCall target dest_regs argsAndHints where rep = cmmRegType (CmmLocal dest) r_dest = getRegisterReg (CmmLocal dest) - outOfLineFloatOp mop = + outOfLineMachOp mop = do dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ - mkForeignLabel functionName Nothing True IsFunction + mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl _ -> Right mopExpr @@ -1098,6 +1116,11 @@ genCCall target dest_regs argsAndHints MO_F64_Cosh -> (fsLit "cosh", False) MO_F64_Tanh -> (fsLit "tanh", False) MO_F64_Pwr -> (fsLit "pow", False) + + MO_Memcpy -> (fsLit "memcpy", False) + MO_Memset -> (fsLit "memset", False) + MO_Memmove -> (fsLit "memmove", False) + other -> pprPanic "genCCall(ppc): unknown callish op" (pprCallishMachOp other) @@ -1119,22 +1142,12 @@ genSwitch expr ids dflags <- getDynFlagsNat dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef - let - jumpTable = map jumpTableEntryRel ids - - jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) - jumpTableEntryRel (Just (BlockId id)) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel id - - code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + let code = e_code `appOL` t_code `appOL` toOL [ SLW tmp reg (RIImm (ImmInt 2)), LD II32 tmp (AddrRegReg tableReg tmp), ADD tmp tmp (RIReg tableReg), MTCTR tmp, - BCTR [ id | Just id <- ids ] + BCTR ids (Just lbl) ] return code | otherwise @@ -1142,19 +1155,27 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat II32 lbl <- getNewLabelNat - let - jumpTable = map jumpTableEntry ids - - code = e_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + let code = e_code `appOL` toOL [ SLW tmp reg (RIImm (ImmInt 2)), ADDIS tmp tmp (HA (ImmCLbl lbl)), LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), MTCTR tmp, - BCTR [ id | Just id <- ids ] + BCTR ids (Just lbl) ] return code +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (BCTR ids (Just lbl)) = + let jumpTable + | opt_PIC = map jumpTableEntryRel ids + | otherwise = map jumpTableEntry ids + where jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 wordWidth) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) +generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers