X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FX86%2FCodeGen.hs;h=a6cc36fcb76743cec53f8f924a242f108943d37f;hp=e9bbc0691b8eeca1567c4afe51ee1d4fe4ceaeb7;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=335b9f366ac440259318777c4c07e4fa42fbbec6 diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index e9bbc06..a6cc36f 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -20,6 +20,7 @@ module X86.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -47,7 +48,8 @@ import Platform import BasicTypes import BlockId import PprCmm ( pprExpr ) -import Cmm +import OldCmm +import OldPprCmm import CLabel import ClosureInfo ( C_SRT(..) ) @@ -58,6 +60,7 @@ import OrdList import Pretty import qualified Outputable as O import Outputable +import Unique import FastString import FastBool ( isFastTrue ) import Constants ( wORD_SIZE ) @@ -93,11 +96,10 @@ cmmTopCodeGen -> RawCmmTop -> NatM [NatCmmTop Instr] -cmmTopCodeGen dynflags - (CmmProc info lab params (ListGraph blocks)) = do +cmmTopCodeGen dynflags (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 dynflags @@ -226,12 +228,12 @@ getRegisterReg use_sse2 (CmmLocal (LocalReg u pk)) else RegVirtual (mkVirtualReg u sz) 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 -> RegReal $ 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 ... -- | Memory addressing modes passed up the tree. @@ -271,8 +273,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) -- ----------------------------------------------------------------------------- @@ -430,7 +432,7 @@ getRegister (CmmReg reg) size | not use_sse2 && isFloatSize sz = FF80 | otherwise = sz -- - return (Fixed sz (getRegisterReg use_sse2 reg) nilOL) + return (Fixed size (getRegisterReg use_sse2 reg) nilOL) getRegister tree@(CmmRegOff _ _) @@ -604,9 +606,7 @@ getRegister (CmmMachOp mop [x]) = do -- unary MachOps | sse2 -> coerceFP2FP W64 x | otherwise -> conversionNop FF80 x - MO_FF_Conv W64 W32 - | sse2 -> coerceFP2FP W32 x - | otherwise -> conversionNop FF80 x + MO_FF_Conv W64 W32 -> coerceFP2FP W32 x MO_FS_Conv from to -> coerceFP2Int from to x MO_SF_Conv from to -> coerceInt2FP from to x @@ -991,11 +991,11 @@ getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit lit@(CmmInt i _)]) let off = ImmInt (-(fromInteger i)) return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) -getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit@(CmmInt i _)]) +getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit]) | is32BitLit lit -- ASSERT(rep == II32)??? = do (x_reg, x_code) <- getSomeReg x - let off = ImmInt (fromInteger i) + let off = litToImm lit return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be @@ -1575,7 +1575,7 @@ genCCall target dest_regs args = do return (unitOL (CALL (Left fn_imm) []), conv) where fn_imm = ImmCLbl lbl CmmCallee expr conv - -> do { (dyn_c, dyn_r) <- get_op expr + -> do { (dyn_r, dyn_c) <- getSomeReg expr ; ASSERT( isWord32 (cmmExprType expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } @@ -1588,12 +1588,24 @@ genCCall target dest_regs args = do | otherwise #endif = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- on Darwin even if we are doing stdcall, though (#5052) + pop_size | cconv /= StdCallConv = tot_arg_size + | otherwise +#if darwin_TARGET_OS + = arg_pad_size +#else + = 0 +#endif + call = callinsns `appOL` toOL ( - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - (if cconv == StdCallConv || tot_arg_size==0 then [] else - [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) ++ [DELTA (delta + tot_arg_size)] ) @@ -1655,13 +1667,11 @@ genCCall target dest_regs args = do DELTA (delta-8)] ) - | otherwise = do - (code, reg) <- get_op arg + | isFloatType arg_ty = do + (reg, code) <- getSomeReg arg delta <- getDeltaNat - let size = arg_size arg_ty -- Byte size setDeltaNat (delta-size) - if (isFloatType arg_ty) - then return (code `appOL` + return (code `appOL` toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), DELTA (delta-size), let addr = AddrBaseIndex (EABaseReg esp) @@ -1674,18 +1684,18 @@ genCCall target dest_regs args = do else GST size reg addr ] ) - else return (code `snocOL` - PUSH II32 (OpReg reg) `snocOL` - DELTA (delta-size) - ) + + | otherwise = do + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + where arg_ty = cmmExprType arg - - ------------ - get_op :: CmmExpr -> NatM (InstrBlock, Reg) -- code, reg - get_op op = do - (reg,code) <- getSomeReg op - return (code, reg) + size = arg_size arg_ty -- Byte size #elif x86_64_TARGET_ARCH @@ -1923,16 +1933,7 @@ 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 - - op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) #if x86_64_TARGET_ARCH @@ -1945,8 +1946,7 @@ genSwitch expr ids code = e_code `appOL` t_code `appOL` toOL [ ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ], - LDATA Text (CmmDataLabel lbl : jumpTable) + JMP_TBL (OpReg tableReg) ids Text lbl ] #else -- HACK: On x86_64 binutils<2.17 is only able to generate PC32 @@ -1956,20 +1956,18 @@ genSwitch expr ids -- conjunction with the hack in PprMach.hs/pprDataItem once -- binutils 2.17 is standard. code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), MOVSxL II32 (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0))) (OpReg reg), ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] #endif #else code = e_code `appOL` t_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), ADD (intSize wordWidth) op (OpReg tableReg), - JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] #endif return code @@ -1978,15 +1976,28 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat let - jumpTable = map jumpTableEntry ids op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl)) code = e_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), - JMP_TBL op [ id | Just id <- ids ] + JMP_TBL op ids ReadOnlyData lbl ] -- in return code +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) +generateJumpTableForInstr _ = Nothing + +createJumpTable ids section lbl + = let jumpTable + | opt_PIC = + let jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 wordWidth) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel (getUnique blockid) + in map jumpTableEntryRel ids + | otherwise = map jumpTableEntry ids + in CmmData section (CmmDataLabel lbl : jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers @@ -2258,12 +2269,14 @@ coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87 -------------------------------------------------------------------------------- coerceFP2FP :: Width -> CmmExpr -> NatM Register coerceFP2FP to x = do + use_sse2 <- sse2Enabled (x_reg, x_code) <- getSomeReg x let - opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD + opc | use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD + | otherwise = GDTOF code dst = x_code `snocOL` opc x_reg dst -- in - return (Any (floatSize to) code) + return (Any (if use_sse2 then floatSize to else FF80) code) --------------------------------------------------------------------------------