diff options
45 files changed, 277 insertions, 242 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 5c931d9d3a..a380b742f6 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -19,7 +19,9 @@ types that module BasicTypes( Version, bumpVersion, initialVersion, - Arity, + Arity, + + Alignment, FunctionOrData(..), @@ -96,6 +98,16 @@ type Arity = Int %************************************************************************ %* * +\subsection[Alignment]{Alignment} +%* * +%************************************************************************ + +\begin{code} +type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). +\end{code} + +%************************************************************************ +%* * \subsection[FunctionOrData]{FunctionOrData} %* * %************************************************************************ diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index a6b215b38f..e49d960c17 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -53,8 +53,8 @@ type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff} data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo} -type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph -type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph +type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph +type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph ------------------------------------------------- -- Manipulating CmmGraphs diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 3d0d6fb426..fc7e488103 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -238,7 +238,7 @@ addCAF caf srt = where last = next_elt srt srtToData :: TopSRT -> Cmm -srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)] +srtToData srt = Cmm [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) -- Once we have found the CAFs, we need to do two things: @@ -317,7 +317,7 @@ to_SRT top_srt off len bmp = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ - CmmDataLabel srt_desc_lbl : map CmmStaticLit + Statics srt_desc_lbl $ map CmmStaticLit ( cmmLabelOffW top_srt off : mkWordCLit (fromIntegral len) : map mkWordCLit bmp) diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs index 542e390128..a04491e10e 100644 --- a/compiler/cmm/CmmDecl.hs +++ b/compiler/cmm/CmmDecl.hs @@ -11,11 +11,12 @@ module CmmDecl ( CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, ProfilingInfo(..), ClosureTypeTag, CmmActual, CmmFormal, ForeignHint(..), - CmmStatic(..), Section(..), + CmmStatics(..), CmmStatic(..), Section(..), ) where #include "HsVersions.h" +import BasicTypes (Alignment) import CmmExpr import CLabel import SMRep @@ -60,7 +61,7 @@ data GenCmmTop d h g | CmmData -- Static data Section - [d] + d ----------------------------------------------------------------------------- @@ -132,10 +133,11 @@ data CmmStatic -- a literal value, size given by cmmLitRep of the literal. | CmmUninitialised Int -- uninitialised data, N bytes long - | CmmAlign Int + | CmmAlign Alignment -- align to next N-byte boundary (N must be a power of 2). | CmmDataLabel CLabel -- label the current position in this section. | CmmString [Word8] -- string of 8-bit values only, not zero terminated. +data CmmStatics = Statics CLabel {- Label of statics -} [CmmStatic] {- The static data itself -} diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 60f3bb5623..eceff8350d 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -188,21 +188,24 @@ cmmtop :: { ExtCode } -- * we can derive closure and info table labels from a single NAME cmmdata :: { ExtCode } - : 'section' STRING '{' statics '}' - { do ss <- sequence $4; - code (emitData (section $2) (concat ss)) } + : 'section' STRING '{' static_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitData (section $2) (Statics lbl $ concat ss)) } statics :: { [ExtFCode [CmmStatic]] } : {- empty -} { [] } | static statics { $1 : $2 } +static_label :: { ExtFCode CLabel } + : NAME ':' + {% withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg $1) } + -- Strings aren't used much in the RTS HC code, so it doesn't seem -- worth allowing inline strings. C-- doesn't allow them anyway. static :: { ExtFCode [CmmStatic] } - : NAME ':' - {% withThisPackage $ \pkg -> - return [CmmDataLabel (mkCmmDataLabel pkg $1)] } - + : static_label { liftM (\x -> [CmmDataLabel x]) $1 } | type expr ';' { do e <- $2; return [CmmStaticLit (getLit e)] } | type ';' { return [CmmUninitialised diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index de1a8e0dcb..5ba78dcc7e 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -73,12 +73,12 @@ newtype ListGraph i = ListGraph [GenBasicBlock i] -- across a whole compilation unit. -- | Cmm with the info table as a data type -type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt) -type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt) +type Cmm = GenCmm CmmStatics CmmInfo (ListGraph CmmStmt) +type CmmTop = GenCmmTop CmmStatics CmmInfo (ListGraph CmmStmt) -- | Cmm with the info tables converted to a list of 'CmmStatic' -type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt) -type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt) +type RawCmm = GenCmm CmmStatics [CmmStatic] (ListGraph CmmStmt) +type RawCmmTop = GenCmmTop CmmStatics [CmmStatic] (ListGraph CmmStmt) -- A basic block containing a single label, at the beginning. diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index c405b650a6..b12d172a74 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -112,31 +112,21 @@ pprTop (CmmProc info clbl (ListGraph blocks)) = -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) = +pprTop (CmmData _section (Statics lbl [CmmString str])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, ptext (sLit "[] = "), pprStringInCStyle str, semi ] -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = +pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, brackets (int size), semi ] -pprTop (CmmData _section (CmmDataLabel lbl : lits)) = +pprTop (CmmData _section (Statics lbl lits)) = pprDataExterns lits $$ - pprWordArray lbl lits - --- Floating info table for safe a foreign call. -pprTop (CmmData _section d@(_ : _)) - | CmmDataLabel lbl : lits <- reverse d = - let lits' = reverse lits - in pprDataExterns lits' $$ - pprWordArray lbl lits' - --- these shouldn't appear? -pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" + pprWordArray lbl lits -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 1f520bfc90..ed143f3908 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -54,12 +54,12 @@ import ClosureInfo #include "../includes/rts/storage/FunTypes.h" -pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc +pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatics info g] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ ptext (sLit "-------------------") $$ space -writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatic info g] -> IO () +writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatics info g] -> IO () writeCmms handle cmms = printForC handle (pprCmms cmms) ----------------------------------------------------------------------------- @@ -72,6 +72,9 @@ instance (Outputable d, Outputable info, Outputable i) => Outputable (GenCmmTop d info i) where ppr t = pprTop t +instance Outputable CmmStatics where + ppr e = pprStatics e + instance Outputable CmmStatic where ppr e = pprStatic e @@ -103,7 +106,7 @@ pprTop (CmmProc info lbl graph) -- section "data" { ... } -- pprTop (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds))) + (hang (pprSection section <+> lbrace) 4 (ppr ds)) $$ rbrace -- -------------------------------------------------------------------------- @@ -171,6 +174,9 @@ instance Outputable ForeignHint where -- Strings are printed as C strings, and we print them as I8[], -- following C-- -- +pprStatics :: CmmStatics -> SDoc +pprStatics (Statics lbl ds) = vcat (map ppr (CmmDataLabel lbl:ds)) + pprStatic :: CmmStatic -> SDoc pprStatic s = case s of CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 48756505c3..a134f00067 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -12,6 +12,7 @@ import OldCmm import CLabel import Module import OldCmmUtils +import CgUtils import CgMonad import HscTypes @@ -30,9 +31,8 @@ cgTickBox mod n = do hpcTable :: Module -> HpcInfo -> Code hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) + emitDataLits (mkHpcTicksLabel this_mod) $ + [ CmmInt 0 W64 | _ <- take hpc_tickCount [0::Int ..] ] diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 9b195bfab2..273c1bf16e 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -736,7 +736,7 @@ emitCgStmt stmt ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } } -emitData :: Section -> [CmmStatic] -> Code +emitData :: Section -> CmmStatics -> Code emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 63d99a629f..effa7a42d6 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -545,26 +545,26 @@ baseRegOffset _ = panic "baseRegOffset:other" emitDataLits :: CLabel -> [CmmLit] -> Code -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: String -> CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits caller lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -580,7 +580,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 7a7bf48b92..1825c97256 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -105,7 +105,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] ; whenC (this_mod == mainModIs dflags) $ emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 2bfe1876ba..0404258446 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -182,7 +182,7 @@ mkModuleInit cost_centre_info this_mod hpc_info ; initCostCentres cost_centre_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] } --------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index fae3bef016..4465e30b04 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -11,11 +11,11 @@ module StgCmmHpc ( initHpc, mkTickBox ) where import StgCmmMonad import MkGraph -import CmmDecl import CmmExpr import CLabel import Module import CmmUtils +import StgCmmUtils import HscTypes import StaticFlags @@ -36,9 +36,8 @@ initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) = whenC opt_Hpc $ - do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) - | _ <- take tickCount [0::Int ..] - ] + do { emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0::Int ..] + ] } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index f92b3cde27..d06b581f26 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -593,7 +593,7 @@ emit ag = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } -emitData :: Section -> [CmmStatic] -> FCode () +emitData :: Section -> CmmStatics -> FCode () emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 558b7fdeaa..74da7317d4 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -508,26 +508,26 @@ baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) emitDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block emitRODataLits lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -543,7 +543,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 56d8386431..21d463e5c5 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -62,7 +62,7 @@ llvmCodeGen dflags h us cmms -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. -- -cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])] +cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)] -> [LlvmUnresData] -> IO ( LlvmEnv ) cmmDataLlvmGens dflags h env [] lmdata diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 59cdad4918..e73f41cde1 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -41,7 +41,7 @@ import Unique -- * Some Data Types -- -type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement) +type LlvmCmmTop = GenCmmTop [LlvmData] [CmmStatic] (ListGraph LlvmStatement) type LlvmBasicBlock = GenBasicBlock LlvmStatement -- | Unresolved code. diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 3e486a544f..7cca522d39 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -37,8 +37,8 @@ structStr = fsLit "_struct" -- complete this completely though as we need to pass all CmmStatic -- sections before all references can be resolved. This last step is -- done by 'resolveLlvmData'. -genLlvmData :: (Section, [CmmStatic]) -> LlvmUnresData -genLlvmData (sec, CmmDataLabel lbl:xs) = +genLlvmData :: (Section, CmmStatics) -> LlvmUnresData +genLlvmData (sec, Statics lbl xs) = let static = map genData xs label = strCLabel_llvm lbl @@ -50,8 +50,6 @@ genLlvmData (sec, CmmDataLabel lbl:xs) = alias = LMAlias ((label `appendFS` structStr), strucTy) in (lbl, sec, alias, static) -genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!" - resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData] -> (LlvmEnv, [LlvmData]) diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 9f25c08826..48a0d6967c 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -83,7 +83,7 @@ pprLlvmCmmTop _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks)) - = let static = CmmDataLabel lbl : info + = let static = Statics lbl info (idoc, ivar) = if not (null info) then pprInfoTable env count lbl static else (empty, []) @@ -103,7 +103,7 @@ pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks)) -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar]) +pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar]) pprInfoTable env count lbl stat = let unres = genLlvmData (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ff18615b1a..bfeaf9e8e3 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -62,6 +62,7 @@ import DynFlags import StaticFlags import Util +import BasicTypes ( Alignment ) import Digraph import Pretty (Doc) import qualified Pretty @@ -131,31 +132,32 @@ The machine-dependent bits break down as follows: -- ----------------------------------------------------------------------------- -- Top-level of the native codegen -data NcgImpl instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr], - generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr), +data NcgImpl statics instr jumpDest = NcgImpl { + cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, canShortcut :: instr -> Maybe jumpDest, - shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmTop :: NatCmmTop instr -> Doc, + pprNatCmmTop :: NatCmmTop statics instr -> Doc, maxSpillSlots :: Int, allocatableRegs :: [RealReg], - ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr], - ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr], + ncg_x86fp_kludge :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], + ncgExpandTop :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] } -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen dflags h us cmms - = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + = let nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId ,canShortcut = X86.Instr.canShortcut - ,shortcutStatic = X86.Instr.shortcutStatic + ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump ,pprNatCmmTop = X86.Ppr.pprNatCmmTop ,maxSpillSlots = X86.Instr.maxSpillSlots @@ -173,7 +175,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId ,canShortcut = PPC.RegInfo.canShortcut - ,shortcutStatic = PPC.RegInfo.shortcutStatic + ,shortcutStatics = PPC.RegInfo.shortcutStatics ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop ,maxSpillSlots = PPC.Instr.maxSpillSlots @@ -188,7 +190,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId ,canShortcut = SPARC.ShortcutJump.canShortcut - ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics ,shortcutJump = SPARC.ShortcutJump.shortcutJump ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop ,maxSpillSlots = SPARC.Instr.maxSpillSlots @@ -204,9 +206,9 @@ nativeCodeGen dflags h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (Instruction instr, Outputable instr) +nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen' dflags ncgImpl h us cmms = do @@ -270,20 +272,20 @@ nativeCodeGen' dflags ncgImpl h us cmms -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (Instruction instr, Outputable instr) +cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply -> [RawCmmTop] -> [[CLabel]] - -> [ ([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + -> [ ([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats]) ] -> Int -> IO ( [[CLabel]], - [([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + [([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats])] ) cmmNativeGens _ _ _ _ [] impAcc profAcc _ @@ -325,17 +327,17 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen - :: (Instruction instr, Outputable instr) + :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmTop -- ^ the cmm to generate code for -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + , [NatCmmTop statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags ncgImpl us cmm count = do @@ -483,7 +485,7 @@ cmmNativeGen dflags ncgImpl us cmm count , ppr_raStatsLinear) -x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr +x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top x86fp_kludge (CmmProc info lbl (ListGraph code)) = CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) @@ -556,7 +558,7 @@ makeImportsDoc dflags imports sequenceTop :: Instruction instr - => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr + => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr sequenceTop _ top@(CmmData _ _) = top sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = @@ -670,8 +672,8 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: NcgImpl instr jumpDest - -> [NatCmmTop instr] -> [NatCmmTop instr] + :: NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] -> [NatCmmTop statics instr] generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] @@ -682,9 +684,9 @@ generateJumpTables ncgImpl xs = concatMap f xs shortcutBranches :: DynFlags - -> NcgImpl instr jumpDest - -> [NatCmmTop instr] - -> [NatCmmTop instr] + -> NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] + -> [NatCmmTop statics instr] shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher @@ -693,7 +695,7 @@ shortcutBranches dflags ncgImpl tops (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops mapping = foldr plusUFM emptyUFM mappings -build_mapping :: NcgImpl instr jumpDest +build_mapping :: NcgImpl statics instr jumpDest -> GenCmmTop d t (ListGraph instr) -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) @@ -723,14 +725,12 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest -apply_mapping :: NcgImpl instr jumpDest +apply_mapping :: NcgImpl statics instr jumpDest -> UniqFM jumpDest - -> GenCmmTop CmmStatic h (ListGraph instr) - -> GenCmmTop CmmStatic h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) - = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. + = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) = CmmProc info lbl (ListGraph $ map short_bb blocks) where @@ -761,10 +761,10 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) genMachCode :: DynFlags - -> (RawCmmTop -> NatM [NatCmmTop instr]) + -> (RawCmmTop -> NatM [NatCmmTop statics instr]) -> RawCmmTop -> UniqSM - ( [NatCmmTop instr] + ( [NatCmmTop statics instr] , [CLabel]) genMachCode dflags cmmTopCodeGen cmm_top diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 918198cb9c..5c85101e8e 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -37,13 +37,13 @@ noUsage = RU [] [] -- Type synonyms for Cmm populated with native code type NatCmm instr = GenCmm - CmmStatic + CmmStatics [CmmStatic] (ListGraph instr) -type NatCmmTop instr +type NatCmmTop statics instr = GenCmmTop - CmmStatic + statics [CmmStatic] (ListGraph instr) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index c375ab4707..7f59fd6fc9 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -709,8 +709,8 @@ pprImportedSymbol _ _ _ initializePicBase_ppc :: Arch -> OS -> Reg - -> [NatCmmTop PPC.Instr] - -> NatM [NatCmmTop PPC.Instr] + -> [NatCmmTop CmmStatics PPC.Instr] + -> NatM [NatCmmTop CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg (CmmProc info lab (ListGraph blocks) : statics) @@ -719,8 +719,7 @@ initializePicBase_ppc ArchPPC os picReg gotOffLabel <- getNewLabelNat tmp <- getNewRegNat $ intSize wordWidth let - gotOffset = CmmData Text [ - CmmDataLabel gotOffLabel, + gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel mkPicBaseLabel 0) @@ -762,8 +761,8 @@ initializePicBase_ppc _ _ _ _ initializePicBase_x86 :: Arch -> OS -> Reg - -> [NatCmmTop X86.Instr] - -> NatM [NatCmmTop X86.Instr] + -> [NatCmmTop (Alignment, CmmStatics) X86.Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg (CmmProc info lab (ListGraph blocks) : statics) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index f4c972e4b0..84737310aa 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -67,7 +67,7 @@ import FastString cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -86,7 +86,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -557,8 +557,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do Amode addr addr_code <- getAmode dynRef let size = floatSize frep code dst = - LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f frep)] + LDATA ReadOnlyData (Statics lbl + [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) @@ -1180,7 +1180,7 @@ genSwitch expr ids ] return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (BCTR ids (Just lbl)) = let jumpTable | opt_PIC = map jumpTableEntryRel ids @@ -1190,7 +1190,7 @@ generateJumpTableForInstr (BCTR ids (Just lbl)) = jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) - in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) + in Just (CmmData ReadOnlyData (Statics lbl jumpTable)) generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- @@ -1362,10 +1362,9 @@ coerceInt2FP fromRep toRep x = do Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), ST II32 itmp (spRel 3), LIS itmp (ImmInt 0x4330), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 0288f1bf02..d13d6afca6 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -75,7 +75,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- start a new basic block. Useful during -- codegen, removed later. Preceding diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index bd12a8188c..6750985f16 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -49,9 +49,9 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc +pprNatCmmTop :: NatCmmTop CmmStatics Instr -> Doc pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) + pprSectionHeader section $$ pprDatas dats -- special case for split markers: pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl @@ -93,6 +93,10 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) + +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (map pprData (CmmDataLabel lbl:dats)) + pprData :: CmmStatic -> Doc pprData (CmmAlign bytes) = pprAlign bytes pprData (CmmDataLabel lbl) = pprLabel lbl diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bfc712af86..2a30087ab7 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -11,7 +11,7 @@ module PPC.RegInfo ( canShortcut, shortcutJump, - shortcutStatic + shortcutStatics ) where @@ -43,18 +43,24 @@ shortcutJump _ other = other -- Here because it knows about JumpDest -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 1eaf00f3a2..a499e1d562 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -27,8 +27,8 @@ import Data.List -- the same and the move instruction safely erased. regCoalesce :: Instruction instr - => [LiveCmmTop instr] - -> UniqSM [LiveCmmTop instr] + => [LiveCmmTop statics instr] + -> UniqSM [LiveCmmTop statics instr] regCoalesce code = do @@ -61,7 +61,7 @@ sinkReg fm r -- then we can rename the two regs to the same thing and eliminate the move. slurpJoinMovs :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpJoinMovs live diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index cdbe98755a..298b5673d4 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -44,12 +44,12 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) + -> [LiveCmmTop statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmTop statics instr], [RegAllocStats statics instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation @@ -239,7 +239,7 @@ regAlloc_spin -- | Build a graph from the liveness and coalesce information in this code. buildGraph :: Instruction instr - => [LiveCmmTop instr] + => [LiveCmmTop statics instr] -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code @@ -320,9 +320,9 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => Color.Graph VirtualReg RegClass RealReg - -> LiveCmmTop instr -> LiveCmmTop instr + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchRegsFromGraph graph code = let diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 4eabb3b0b4..c4fb783688 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -41,13 +41,13 @@ import qualified Data.Set as Set -- regSpill :: Instruction instr - => [LiveCmmTop instr] -- ^ the code + => [LiveCmmTop statics instr] -- ^ the code -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , SpillStats ) -- stats about what happened during spilling + ([LiveCmmTop statics instr] -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , SpillStats ) -- stats about what happened during spilling regSpill code slotsFree regs @@ -81,8 +81,8 @@ regSpill code slotsFree regs regSpill_top :: Instruction instr => RegMap Int -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmTop instr -- ^ the top level thing. - -> SpillM (LiveCmmTop instr) + -> LiveCmmTop statics instr -- ^ the top level thing. + -> SpillM (LiveCmmTop statics instr) regSpill_top regSlotMap cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 38c33b708a..710055c045 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -54,7 +54,7 @@ type Slot = Int -- | Clean out unneeded spill\/reloads from this top level thing. cleanSpills :: Instruction instr - => LiveCmmTop instr -> LiveCmmTop instr + => LiveCmmTop statics instr -> LiveCmmTop statics instr cleanSpills cmm = evalState (cleanSpin 0 cmm) initCleanS @@ -63,8 +63,8 @@ cleanSpills cmm cleanSpin :: Instruction instr => Int - -> LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + -> LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) {- cleanSpin spinCount code @@ -282,8 +282,8 @@ cleanReload _ _ _ -- cleanTopBackward :: Instruction instr - => LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) cleanTopBackward cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 330a410312..8a16b25187 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -64,7 +64,7 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- slurpSpillCostInfo :: (Outputable instr, Instruction instr) - => LiveCmmTop instr + => LiveCmmTop statics instr -> SpillCostInfo slurpSpillCostInfo cmm diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 5ff7bff91a..f24e876cb2 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -36,36 +36,36 @@ import State import Data.List -data RegAllocStats instr +data RegAllocStats statics instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + { raLiveCmm :: [LiveCmmTop statics instr] -- ^ initial code, with liveness , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill -- a spill stage | RegAllocStatsSpill - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced , raSpillStats :: SpillStats -- ^ spiller stats , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added + , raSpilled :: [LiveCmmTop statics instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced - , raCodeCoalesced :: [LiveCmmTop instr] -- ^ code with coalescings applied - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code + , raCodeCoalesced :: [LiveCmmTop statics instr] -- ^ code with coalescings applied + , raPatched :: [LiveCmmTop statics instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop statics instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance Outputable instr => Outputable (RegAllocStats instr) where +instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where ppr (s@RegAllocStatsStart{}) = text "# Start" @@ -147,7 +147,7 @@ instance Outputable instr => Outputable (RegAllocStats instr) where -- | Do all the different analysis on this list of RegAllocStats pprStats - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -> SDoc @@ -162,7 +162,7 @@ pprStats stats graph -- | Dump a table of how many spill loads \/ stores were inserted for each vreg. pprStatsSpills - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsSpills stats = let @@ -180,7 +180,7 @@ pprStatsSpills stats -- | Dump a table of how long vregs tend to live for in the initial code. pprStatsLifetimes - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsLifetimes stats = let info = foldl' plusSpillCostInfo zeroSpillCostInfo @@ -208,7 +208,7 @@ binLifetimeCount fm -- | Dump a table of how many conflicts vregs tend to have in the initial code. pprStatsConflict - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsConflict stats = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) @@ -225,7 +225,7 @@ pprStatsConflict stats -- | For every vreg, dump it's how many conflicts it has and its lifetime -- good for making a scatter plot. pprStatsLifeConflict - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc @@ -256,7 +256,7 @@ pprStatsLifeConflict stats graph -- Lets us see how well the register allocator has done. countSRMs :: Instruction instr - => LiveCmmTop instr -> (Int, Int, Int) + => LiveCmmTop statics instr -> (Int, Int, Int) countSRMs cmm = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3682ffbe1d..4e54b4744d 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -129,8 +129,8 @@ import Control.Monad regAlloc :: (Outputable instr, Instruction instr) => DynFlags - -> LiveCmmTop instr - -> UniqSM (NatCmmTop instr, Maybe RegAllocStats) + -> LiveCmmTop statics instr + -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats) regAlloc _ (CmmData sec d) = return diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index c80f77f893..0c059eac27 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -37,7 +37,7 @@ binSpillReasons reasons -- | Count reg-reg moves remaining in this code. countRegRegMovesNat :: Instruction instr - => NatCmmTop instr -> Int + => NatCmmTop statics instr -> Int countRegRegMovesNat cmm = execState (mapGenBlockTopM countBlock cmm) 0 @@ -58,7 +58,7 @@ countRegRegMovesNat cmm -- | Pretty print some RegAllocStats pprStats :: Instruction instr - => [NatCmmTop instr] -> [RegAllocStats] -> SDoc + => [NatCmmTop statics instr] -> [RegAllocStats] -> SDoc pprStats code statss = let -- sum up all the instrs inserted by the spiller diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index a2030fafa9..a6a3724bfa 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -66,9 +66,9 @@ type BlockMap a = BlockEnv a -- | A top level thing which carries liveness information. -type LiveCmmTop instr +type LiveCmmTop statics instr = GenCmmTop - CmmStatic + statics LiveInfo [SCC (LiveBasicBlock instr)] @@ -224,7 +224,7 @@ instance Outputable LiveInfo where -- mapBlockTop :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmTop instr -> LiveCmmTop instr + -> LiveCmmTop statics instr -> LiveCmmTop statics instr mapBlockTop f cmm = evalState (mapBlockTopM (\x -> return $ f x) cmm) () @@ -235,7 +235,7 @@ mapBlockTop f cmm mapBlockTopM :: Monad m => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmTop instr -> m (LiveCmmTop instr) + -> LiveCmmTop statics instr -> m (LiveCmmTop statics instr) mapBlockTopM _ cmm@(CmmData{}) = return cmm @@ -283,7 +283,7 @@ mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) -- slurpConflicts :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> (Bag (UniqSet Reg), Bag (Reg, Reg)) slurpConflicts live @@ -357,8 +357,8 @@ slurpConflicts live -- -- slurpReloadCoalesce - :: forall instr. Instruction instr - => LiveCmmTop instr + :: forall statics instr. Instruction instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpReloadCoalesce live @@ -458,9 +458,9 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmTop stripLive - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> NatCmmTop instr + :: (Outputable statics, Outputable instr, Instruction instr) + => LiveCmmTop statics instr + -> NatCmmTop statics instr stripLive live = stripCmm live @@ -525,8 +525,8 @@ stripLiveBlock (BasicBlock i lis) eraseDeltasLive :: Instruction instr - => LiveCmmTop instr - -> LiveCmmTop instr + => LiveCmmTop statics instr + -> LiveCmmTop statics instr eraseDeltasLive cmm = mapBlockTop eraseBlock cmm @@ -543,7 +543,7 @@ eraseDeltasLive cmm patchEraseLive :: Instruction instr => (Reg -> Reg) - -> LiveCmmTop instr -> LiveCmmTop instr + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchEraseLive patchF cmm = patchCmm cmm @@ -620,8 +620,8 @@ patchRegsLiveInstr patchF li natCmmTopToLive :: Instruction instr - => NatCmmTop instr - -> LiveCmmTop instr + => NatCmmTop statics instr + -> LiveCmmTop statics instr natCmmTopToLive (CmmData i d) = CmmData i d @@ -658,8 +658,8 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph -- regLiveness :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> UniqSM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> UniqSM (LiveCmmTop statics instr) regLiveness (CmmData i d) = returnUs $ CmmData i d @@ -720,7 +720,7 @@ checkIsReverseDependent sccs' -- | If we've compute liveness info for this code already we have to reverse -- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr +reverseBlocksInTops :: LiveCmmTop statics instr -> LiveCmmTop statics instr reverseBlocksInTops top = case top of CmmData{} -> top diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index a4dbbe8771..72e4649eca 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -51,7 +51,7 @@ import Control.Monad ( mapAndUnzipM ) -- | Top level code generation cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) @@ -75,7 +75,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -313,8 +313,8 @@ genSwitch expr ids , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable)) + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index d4500e8a8e..3e49f5c025 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -21,7 +21,7 @@ import Outputable import OrdList -- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmTop Instr -> NatCmmTop Instr +expandTop :: NatCmmTop CmmStatics Instr -> NatCmmTop CmmStatics Instr expandTop top@(CmmData{}) = top diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 9d6aa5e646..ddeed0508b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -83,9 +83,8 @@ getRegister (CmmLit (CmmFloat f W32)) = do let code dst = toOL [ -- the data area - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal SETHI (HI (ImmCLbl lbl)) tmp, @@ -97,9 +96,8 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat d W64)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 93f4d27444..816af9ba2a 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -112,7 +112,7 @@ data Instr -- some static data spat out during code generation. -- Will be extracted before pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- Start a new basic block. Useful during codegen, removed later. -- Preceding instruction should be a jump, as per the invariants diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index d78d1a760e..8563aab4fe 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -47,9 +47,9 @@ import Data.Word -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc +pprNatCmmTop :: NatCmmTop CmmStatics Instr -> Doc pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) + pprSectionHeader section $$ pprDatas dats -- special case for split markers: pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl @@ -91,6 +91,9 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (map pprData (CmmDataLabel lbl:dats)) + pprData :: CmmStatic -> Doc pprData (CmmAlign bytes) = pprAlign bytes pprData (CmmDataLabel lbl) = pprLabel lbl diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 30e48bb377..10e2e9fbaa 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -3,7 +3,7 @@ module SPARC.ShortcutJump ( JumpDest(..), getJumpDestBlockId, canShortcut, shortcutJump, - shortcutStatic, + shortcutStatics, shortBlockId ) @@ -38,16 +38,23 @@ shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump _ other = other -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index d191733af1..49ac543e65 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -80,7 +80,7 @@ if_sse2 sse2 x87 = do cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -95,13 +95,13 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do Nothing -> return tops cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic + return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop (Alignment, CmmStatics) Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -1123,10 +1123,7 @@ memConstant align lit = do return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA ReadOnlyData - [CmmAlign align, - CmmDataLabel lbl, - CmmStaticLit lit] + LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -2041,11 +2038,11 @@ genSwitch expr ids -- in return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop (Alignment, CmmStatics) Instr) generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) generateJumpTableForInstr _ = Nothing -createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop CmmStatic h g +createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop (Alignment, CmmStatics) h g createJumpTable ids section lbl = let jumpTable | opt_PIC = @@ -2056,7 +2053,7 @@ createJumpTable ids section lbl where blockLabel = mkAsmTempLabel (getUnique blockid) in map jumpTableEntryRel ids | otherwise = map jumpTableEntry ids - in CmmData section (CmmDataLabel lbl : jumpTable) + in CmmData section (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index b9c851a859..0e70dbb503 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -27,6 +27,7 @@ import FastBool import Outputable import Constants (rESERVED_C_STACK_BYTES) +import BasicTypes (Alignment) import CLabel import UniqSet import Unique @@ -151,7 +152,6 @@ bit precision. --SDM 1/2003 -} - data Instr -- comment pseudo-op = COMMENT FastString @@ -159,7 +159,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section (Alignment, CmmStatics) -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -805,16 +805,24 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn shortcutJump' _ _ other = other -- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) +shortcutStatics fn (align, Statics lbl statics) + = (align, Statics lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) + | otherwise = lab + shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq))) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 769057ae02..676e4c828b 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -31,6 +31,7 @@ import Reg import PprBase +import BasicTypes (Alignment) import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) @@ -48,9 +49,9 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc +pprNatCmmTop :: NatCmmTop (Alignment, CmmStatics) Instr -> Doc pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) + pprSectionHeader section $$ pprDatas dats -- special case for split markers: pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl @@ -102,6 +103,9 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) +pprDatas :: (Alignment, CmmStatics) -> Doc +pprDatas (align, (Statics lbl dats)) = vcat (map pprData (CmmAlign align:CmmDataLabel lbl:dats)) -- TODO: could remove if align == 1 + pprData :: CmmStatic -> Doc pprData (CmmAlign bytes) = pprAlign bytes pprData (CmmDataLabel lbl) = pprLabel lbl |