diff options
Diffstat (limited to 'compiler/GHC')
26 files changed, 793 insertions, 630 deletions
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index 5efecdc534..8850f2e19a 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -3,12 +3,11 @@ module GHC.Cmm ( -- * Cmm top-level datatypes - CmmProgram, CmmGroup, GenCmmGroup, - CmmDecl, GenCmmDecl(..), + CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, + CmmDecl, CmmDeclSRTs, GenCmmDecl(..), CmmGraph, GenCmmGraph(..), - CmmBlock, - RawCmmDecl, RawCmmGroup, - Section(..), SectionType(..), CmmStatics(..), CmmStatic(..), + CmmBlock, RawCmmDecl, + Section(..), SectionType(..), CmmStatics(..), RawCmmStatics(..), CmmStatic(..), isSecConstant, -- ** Blocks containing lists @@ -56,8 +55,12 @@ import Data.ByteString (ByteString) type CmmProgram = [CmmGroup] type GenCmmGroup d h g = [GenCmmDecl d h g] -type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph -type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph +-- | Cmm group before SRT generation +type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph +-- | Cmm group with SRTs +type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo CmmGraph +-- | "Raw" cmm group (TODO (osa): not sure what that means) +type RawCmmGroup = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) CmmGraph ----------------------------------------------------------------------------- -- CmmDecl, GenCmmDecl @@ -89,12 +92,13 @@ data GenCmmDecl d h g Section d -type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph +type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph +type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph type RawCmmDecl = GenCmmDecl - CmmStatics - (LabelMap CmmStatics) + RawCmmStatics + (LabelMap RawCmmStatics) CmmGraph ----------------------------------------------------------------------------- @@ -199,8 +203,20 @@ data CmmStatic | CmmString ByteString -- string of 8-bit values only, not zero terminated. +-- Static data before SRT generation data CmmStatics - = Statics + = CmmStatics + CLabel -- Label of statics + CmmInfoTable + CostCentreStack + [CmmLit] -- Payload + | CmmStaticsRaw + CLabel -- Label of statics + [CmmStatic] -- The static data itself + +-- Static data, after SRTs are generated +data RawCmmStatics + = RawCmmStatics CLabel -- Label of statics [CmmStatic] -- The static data itself diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index e84278bf65..c83dba8f39 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -106,7 +106,8 @@ module GHC.Cmm.CLabel ( pprCLabel, isInfoTableLabel, - isConInfoTableLabel + isConInfoTableLabel, + isIdLabel ) where #include "HsVersions.h" @@ -262,6 +263,10 @@ data CLabel deriving Eq +isIdLabel :: CLabel -> Bool +isIdLabel IdLabel{} = True +isIdLabel _ = False + -- This is laborious, but necessary. We can't derive Ord because -- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the -- implementation. See Note [No Ord for Unique] diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 6b940c9867..ae86788d9c 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -161,7 +161,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes = DebugBlock { dblProcedure = g_entry graph , dblLabel = label , dblCLabel = case info of - Just (Statics infoLbl _) -> infoLbl + Just (RawCmmStatics infoLbl _) -> infoLbl Nothing | g_entry graph == label -> entryLbl | otherwise -> blockLbl label diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index a10db2b292..9e12fb170d 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -2,7 +2,6 @@ module GHC.Cmm.Info ( mkEmptyContInfoTable, cmmToRawCmm, - mkInfoTable, srtEscape, -- info table accessors @@ -67,11 +66,11 @@ mkEmptyContInfoTable info_lbl , cit_srt = Nothing , cit_clo = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a +cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a) cmmToRawCmm dflags cmms = do { uniqs <- mkSplitUniqSupply 'i' - ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl]) + ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl]) do_one uniqs cmm = -- NB. strictness fixes a space leak. DO NOT REMOVE. withTimingSilent dflags (text "Cmm -> Raw Cmm") @@ -117,9 +116,8 @@ cmmToRawCmm dflags cmms -- -- * The SRT slot is only there if there is SRT info to record -mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] -mkInfoTable _ (CmmData sec dat) - = return [CmmData sec dat] +mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl] +mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) -- @@ -169,7 +167,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits -- - return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $ + return (top_decls, (lbl, RawCmmStatics info_lbl $ map CmmStaticLit $ reverse rel_extra_bits ++ rel_std_info)) ----------------------------------------------------- @@ -423,7 +421,7 @@ mkProfLits _ (ProfilingInfo td cd) ; (cd_lit, cd_decl) <- newStringLit cd ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } -newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt) +newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt) newStringLit bytes = do { uniq <- getUniqueM ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) } diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 1ba79befcd..8dbe13d937 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -1,14 +1,17 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards, - GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-} + GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections, + ScopedTypeVariables, OverloadedStrings #-} module GHC.Cmm.Info.Build - ( CAFSet, CAFEnv, cafAnal - , doSRTs, ModuleSRTInfo, emptySRT + ( CAFSet, CAFEnv, cafAnal, cafAnalData + , doSRTs, ModuleSRTInfo (..), emptySRT + , SRTMap, srtMapNonCAFs ) where import GhcPrelude hiding (succ) import Id +import IdInfo import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph @@ -28,6 +31,7 @@ import GHC.Runtime.Layout import UniqSupply import CostCentre import GHC.StgToCmm.Heap +import ErrUtils import Control.Monad import Data.Map (Map) @@ -37,7 +41,9 @@ import qualified Data.Set as Set import Data.Tuple import Control.Monad.Trans.State import Control.Monad.Trans.Class +import Data.List (unzip4) +import NameSet {- Note [SRTs] @@ -183,6 +189,63 @@ and the only SRT closure we generate is g_srt = SRT_2 [c2_closure, c1_closure] +Algorithm +^^^^^^^^^ + +0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {} + Maps closures to their SRT entries (i.e. how they appear in a SRT payload) + +1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG + after code-generation. + +2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might + be multiple CmmDecls in the result, due to proc-point splitting. + +3. In cpsTop, *before* proc-point splitting, when we still have a single + CmmDecl, we do cafAnal for procs: + + * cafAnal performs a backwards analysis on the code blocks + + * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel), + representing all the CAFLabels reachable from this label. + + * A label is added to the set if it refers to a FUN, THUNK, or RET, + and its CafInfo /= NoCafRefs. + (NB. all CafInfo for Ids in the current module should be initialised to + MayHaveCafRefs) + + * The result is CAFEnv = LabelMap CAFSet + + (Why *before* proc-point splitting? Because the analysis needs to propagate + information across branches, and proc-point splitting turns branches into + CmmCalls to top-level CmmDecls. The analysis would fail to find all the + references to CAFFY labels if we did it after proc-point splitting.) + + For static data, cafAnalData simply returns set of all labels that refer to a + FUN, THUNK, and RET whose CafInfos /= NoCafRefs. + +4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl) + for static data. So after `mapM cpsTop decls` we have + [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)] + +5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl]) + +6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets) + +7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel + +8. For each SCC in dependency order + - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC + - Apply CAFEnv to each label and concat the result :: [CAFLabel] + - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get + srt :: [SRTEntry] + - Make a label for this SRT, call it l + - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the + group to the SRT (see Note [Invalid optimisation: shortcutting]) + - Add to srtMap: lbls -> if null srt then Nothing else Just l + +9. At the end, for every top-level binding x, if srtMap x == Nothing, then the + binding is non-CAFFY, otherwise it is CAFFY. Optimisations ^^^^^^^^^^^^^ @@ -382,6 +445,35 @@ newtype SRTEntry = SRTEntry CLabel -- --------------------------------------------------------------------- -- CAF analysis +addCafLabel :: CLabel -> CAFSet -> CAFSet +addCafLabel l s + | Just _ <- hasHaskellName l + , let caf_label = mkCAFLabel l + -- For imported Ids hasCAF will have accurate CafInfo + -- Locals are initialized as CAFFY. We turn labels with empty SRTs into + -- non-CAFFYs in doSRTs + , hasCAF l + = Set.insert caf_label s + | otherwise + = s + +cafAnalData + :: CmmStatics + -> CAFSet + +cafAnalData (CmmStaticsRaw _lbl _data) = + Set.empty + +cafAnalData (CmmStatics _lbl _itbl _ccs payload) = + foldl' analyzeStatic Set.empty payload + where + analyzeStatic s lit = + case lit of + CmmLabel c -> addCafLabel c s + CmmLabelOff c _ -> addCafLabel c s + CmmLabelDiffOff c1 c2 _ _ -> addCafLabel c1 $! addCafLabel c2 s + _ -> s + -- | -- For each code block: -- - collect the references reachable from this code block to FUN, @@ -412,17 +504,24 @@ cafLattice = DataflowLattice Set.empty add cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet cafTransfers contLbls entry topLbl - (BlockCC eNode middle xNode) fBase = - let joined = cafsInNode xNode $! live' + block@(BlockCC eNode middle xNode) fBase = + let joined :: CAFSet + joined = cafsInNode xNode $! live' + + result :: CAFSet !result = foldNodesBwdOO cafsInNode middle joined + facts :: [Set CAFLabel] facts = mapMaybe successorFact (successors xNode) + + live' :: CAFSet live' = joinFacts cafLattice facts + successorFact :: Label -> Maybe (Set CAFLabel) successorFact s -- If this is a loop back to the entry, we can refer to the -- entry label. - | s == entry = Just (add topLbl Set.empty) + | s == entry = Just (addCafLabel topLbl Set.empty) -- If this is a continuation, we want to refer to the -- SRT for the continuation's info table | s `setMember` contLbls @@ -432,18 +531,27 @@ cafTransfers contLbls entry topLbl = lookupFact s fBase cafsInNode :: CmmNode e x -> CAFSet -> CAFSet - cafsInNode node set = foldExpDeep addCaf node set + cafsInNode node set = foldExpDeep addCafExpr node set - addCaf expr !set = + addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel + addCafExpr expr !set = case expr of - CmmLit (CmmLabel c) -> add c set - CmmLit (CmmLabelOff c _) -> add c set - CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set - _ -> set - add l s | hasCAF l = Set.insert (mkCAFLabel l) s - | otherwise = s - - in mapSingleton (entryLabel eNode) result + CmmLit (CmmLabel c) -> + addCafLabel c set + CmmLit (CmmLabelOff c _) -> + addCafLabel c set + CmmLit (CmmLabelDiffOff c1 c2 _ _) -> + addCafLabel c1 $! addCafLabel c2 set + _ -> + set + in + srtTrace "cafTransfers" (text "block:" <+> ppr block $$ + text "contLbls:" <+> ppr contLbls $$ + text "entry:" <+> ppr entry $$ + text "topLbl:" <+> ppr topLbl $$ + text "cafs in exit:" <+> ppr joined $$ + text "result:" <+> ppr result) $ + mapSingleton (entryLabel eNode) result -- ----------------------------------------------------------------------------- @@ -460,17 +568,24 @@ data ModuleSRTInfo = ModuleSRTInfo -- entries. e.g. if we have an SRT [a,b,c], and we know that b -- points to [c,d], we can omit c and emit [a,b]. -- Used to implement the [Filter] optimisation. + , moduleSRTMap :: SRTMap } + instance Outputable ModuleSRTInfo where ppr ModuleSRTInfo{..} = - text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs + text "ModuleSRTInfo {" $$ + (nest 4 $ text "dedupSRTs =" <+> ppr dedupSRTs $$ + text "flatSRTs =" <+> ppr flatSRTs $$ + text "moduleSRTMap =" <+> ppr moduleSRTMap) $$ char '}' emptySRT :: Module -> ModuleSRTInfo emptySRT mod = ModuleSRTInfo { thisModule = mod , dedupSRTs = Map.empty - , flatSRTs = Map.empty } + , flatSRTs = Map.empty + , moduleSRTMap = Map.empty + } -- ----------------------------------------------------------------------------- -- Constructing SRTs @@ -489,14 +604,33 @@ emptySRT mod = -} +data SomeLabel + = BlockLabel Label + | DeclLabel CLabel + deriving (Eq, Ord) + +instance Outputable SomeLabel where + ppr (BlockLabel l) = text "b:" <+> ppr l + ppr (DeclLabel l) = text "s:" <+> ppr l + +getBlockLabel :: SomeLabel -> Maybe Label +getBlockLabel (BlockLabel l) = Just l +getBlockLabel (DeclLabel _) = Nothing + +getBlockLabels :: [SomeLabel] -> [Label] +getBlockLabels = mapMaybe getBlockLabel + -- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl, -- where the label is -- - the info label for a continuation or dynamic closure -- - the closure label for a top-level function (not a CAF) -getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)] -getLabelledBlocks (CmmData _ _) = [] +getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)] +getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) = + [] +getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) = + [ (DeclLabel lbl, mkCAFLabel lbl) ] getLabelledBlocks (CmmProc top_info _ _ _) = - [ (blockId, mkCAFLabel (cit_lbl info)) + [ (BlockLabel blockId, mkCAFLabel (cit_lbl info)) | (blockId, info) <- mapToList (info_tbls top_info) , let rep = cit_rep info , not (isStaticRep rep) || not (isThunkRep rep) @@ -509,20 +643,30 @@ getLabelledBlocks (CmmProc top_info _ _ _) = -- SRTs. CAFs themselves are not included here; see getCAFs below. depAnalSRTs :: CAFEnv + -> Map CLabel CAFSet -- CAFEnv for statics -> [CmmDecl] - -> [SCC (Label, CAFLabel, Set CAFLabel)] -depAnalSRTs cafEnv decls = - srtTrace "depAnalSRTs" (ppr graph) graph + -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)] +depAnalSRTs cafEnv cafEnv_static decls = + srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$ + text "nodes:" <+> ppr (map node_payload nodes) $$ + text "graph:" <+> ppr graph) graph where labelledBlocks = concatMap getLabelledBlocks decls labelToBlock = Map.fromList (map swap labelledBlocks) - graph = stronglyConnCompFromEdgedVerticesOrd - [ let cafs' = Set.delete lbl cafs in - DigraphNode (l,lbl,cafs') l - (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs')) - | (l, lbl) <- labelledBlocks - , Just cafs <- [mapLookup l cafEnv] ] + nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)] + nodes = [ DigraphNode (l,lbl,cafs') l + (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs')) + | (l, lbl) <- labelledBlocks + , Just (cafs :: Set CAFLabel) <- + [case l of + BlockLabel l -> mapLookup l cafEnv + DeclLabel cl -> Map.lookup cl cafEnv_static] + , let cafs' = Set.delete lbl cafs + ] + + graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)] + graph = stronglyConnCompFromEdgedVerticesOrd nodes -- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF. -- These are treated differently from other labelled blocks: @@ -565,11 +709,21 @@ getStaticFuns decls = -- is empty, so we don't need to refer to it from other SRTs. type SRTMap = Map CAFLabel (Maybe SRTEntry) + +-- | Given SRTMap of a module returns the set of non-CAFFY names in the module. +-- Any Names not in the set are CAFFY. +srtMapNonCAFs :: SRTMap -> NameSet +srtMapNonCAFs srtMap = mkNameSet (mapMaybe get_name (Map.toList srtMap)) + where + get_name (CAFLabel l, Nothing) = hasHaskellName l + get_name (_l, Just _srt_entry) = Nothing + -- | resolve a CAFLabel to its SRTEntry using the SRTMap resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry resolveCAF srtMap lbl@(CAFLabel l) = - Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap - + srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret + where + ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap -- | Attach SRTs to all info tables in the CmmDecls, and add SRT -- declarations to the ModuleSRTInfo. @@ -578,16 +732,33 @@ doSRTs :: DynFlags -> ModuleSRTInfo -> [(CAFEnv, [CmmDecl])] - -> IO (ModuleSRTInfo, [CmmDecl]) + -> [(CAFSet, CmmDecl)] + -> IO (ModuleSRTInfo, [CmmDeclSRTs]) -doSRTs dflags moduleSRTInfo tops = do +doSRTs dflags moduleSRTInfo procs data_ = do us <- mkSplitUniqSupply 'u' -- Ignore the original grouping of decls, and combine all the -- CAFEnvs into a single CAFEnv. - let (cafEnvs, declss) = unzip tops - cafEnv = mapUnions cafEnvs - decls = concat declss + let static_data_env :: Map CLabel CAFSet + static_data_env = + Map.fromList $ + flip map data_ $ + \(set, decl) -> + case decl of + CmmProc{} -> + pprPanic "doSRTs" (text "Proc in static data list:" <+> ppr decl) + CmmData _ static -> + case static of + CmmStatics lbl _ _ _ -> (lbl, set) + CmmStaticsRaw lbl _ -> (lbl, set) + + static_data :: Set CLabel + static_data = Map.keysSet static_data_env + + (proc_envs, procss) = unzip procs + cafEnv = mapUnions proc_envs + decls = map snd data_ ++ concat procss staticFuns = mapFromList (getStaticFuns decls) -- Put the decls in dependency order. Why? So that we can implement @@ -597,56 +768,93 @@ doSRTs dflags moduleSRTInfo tops = do -- to do this we need to process blocks before things that depend on -- them. let - sccs = depAnalSRTs cafEnv decls + sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)] + sccs = depAnalSRTs cafEnv static_data_env decls + + cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)] cafsWithSRTs = getCAFs cafEnv decls + srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$ + text "procs:" <+> ppr procs $$ + text "static_data_env:" <+> ppr static_data_env $$ + text "sccs:" <+> ppr sccs $$ + text "cafsWithSRTs:" <+> ppr cafsWithSRTs) + -- On each strongly-connected group of decls, construct the SRT -- closures and the SRT fields for info tables. let result :: - [ ( [CmmDecl] -- generated SRTs + [ ( [CmmDeclSRTs] -- generated SRTs , [(Label, CLabel)] -- SRT fields for info tables , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references ) ] - ((result, _srtMap), moduleSRTInfo') = + + (result, moduleSRTInfo') = initUs_ us $ - flip runStateT moduleSRTInfo $ - flip runStateT Map.empty $ do - nonCAFs <- mapM (doSCC dflags staticFuns) sccs + flip runStateT moduleSRTInfo $ do + nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> - oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs + oneSRT dflags staticFuns [BlockLabel l] [cafLbl] + True{-is a CAF-} cafs static_data return (nonCAFs ++ cAFs) - (declss, pairs, funSRTs) = unzip3 result + (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result + srt_decls = concat srt_declss + + unless (null srt_decls) $ + dumpIfSet_dyn dflags Opt_D_dump_srts "SRTs" FormatCMM (ppr srt_decls) -- Next, update the info tables with the SRTs let srtFieldMap = mapFromList (concat pairs) funSRTMap = mapFromList (concat funSRTs) - decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls - - return (moduleSRTInfo', concat declss ++ decls') + has_caf_refs' = or has_caf_refs + decls' = + concatMap (updInfoSRTs dflags srtFieldMap funSRTMap has_caf_refs') decls + + -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are + -- not analysed in oneSRT so we never add entries for them to the SRTMap. + let srtMap_w_raws = + foldl' (\(srtMap :: SRTMap) (_, decl) -> + case decl of + CmmData _ CmmStatics{} -> + -- already updated by oneSRT + srtMap + CmmData _ (CmmStaticsRaw lbl _) + | isIdLabel lbl -> + -- not analysed by oneSRT, declare it non-CAFFY here + Map.insert (mkCAFLabel lbl) Nothing srtMap + | otherwise -> + -- Not an IdLabel, ignore + srtMap + CmmProc{} -> + pprPanic "doSRTs" (text "Found Proc in static data list:" <+> ppr decl)) + (moduleSRTMap moduleSRTInfo') data_ + + return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls') -- | Build the SRT for a strongly-connected component of blocks doSCC :: DynFlags - -> LabelMap CLabel -- which blocks are static function entry points - -> SCC (Label, CAFLabel, Set CAFLabel) - -> StateT SRTMap - (StateT ModuleSRTInfo UniqSM) - ( [CmmDecl] -- generated SRTs + -> LabelMap CLabel -- which blocks are static function entry points + -> Set CLabel -- static data + -> SCC (SomeLabel, CAFLabel, Set CAFLabel) + -> StateT ModuleSRTInfo UniqSM + ( [CmmDeclSRTs] -- generated SRTs , [(Label, CLabel)] -- SRT fields for info tables , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references ) -doSCC dflags staticFuns (AcyclicSCC (l, cafLbl, cafs)) = - oneSRT dflags staticFuns [l] [cafLbl] False cafs +doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) = + oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data -doSCC dflags staticFuns (CyclicSCC nodes) = do +doSCC dflags staticFuns static_data (CyclicSCC nodes) = do -- build a single SRT for the whole cycle, see Note [recursive SRTs] - let (blockids, lbls, cafsets) = unzip3 nodes + let (lbls, caf_lbls, cafsets) = unzip3 nodes cafs = Set.unions cafsets - oneSRT dflags staticFuns blockids lbls False cafs + oneSRT dflags staticFuns lbls caf_lbls False cafs static_data {- Note [recursive SRTs] @@ -677,34 +885,40 @@ references to static function closures. oneSRT :: DynFlags -> LabelMap CLabel -- which blocks are static function entry points - -> [Label] -- blocks in this set + -> [SomeLabel] -- blocks in this set -> [CAFLabel] -- labels for those blocks -> Bool -- True <=> this SRT is for a CAF -> Set CAFLabel -- SRT for this set - -> StateT SRTMap - (StateT ModuleSRTInfo UniqSM) - ( [CmmDecl] -- SRT objects we built + -> Set CLabel -- Static data labels in this group + -> StateT ModuleSRTInfo UniqSM + ( [CmmDeclSRTs] -- SRT objects we built , [(Label, CLabel)] -- SRT fields for these blocks' itbls , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references ) -oneSRT dflags staticFuns blockids lbls isCAF cafs = do - srtMap <- get - topSRT <- lift get +oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do + topSRT <- get + let + srtMap = moduleSRTMap topSRT + + blockids = getBlockLabels lbls + -- Can we merge this SRT with a FUN_STATIC closure? + maybeFunClosure :: Maybe (CLabel, Label) + otherFunLabels :: [CLabel] (maybeFunClosure, otherFunLabels) = case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of [] -> (Nothing, []) - ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs) + ((l,b):xs) -> (Just (l,b), map fst xs) - -- Remove recursive references from the SRT, except for (all but - -- one of the) static functions. See Note [recursive SRTs]. - nonRec = cafs `Set.difference` - (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels) + -- Remove recursive references from the SRT + nonRec :: Set CAFLabel + nonRec = cafs `Set.difference` Set.fromList caf_lbls - -- First resolve all the CAFLabels to SRTEntries - -- Implements the [Inline] optimisation. + -- Resolve references to their SRT entries + resolved :: [SRTEntry] resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec) -- The set of all SRTEntries in SRTs that we refer to from here. @@ -714,10 +928,21 @@ oneSRT dflags staticFuns blockids lbls isCAF cafs = do -- Remove SRTEntries that are also in an SRT that we refer to. -- Implements the [Filter] optimisation. - filtered = Set.difference (Set.fromList resolved) allBelow - - srtTrace "oneSRT:" - (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return () + filtered0 = Set.fromList resolved `Set.difference` allBelow + + srtTraceM "oneSRT:" + (text "srtMap:" <+> ppr srtMap $$ + text "nonRec:" <+> ppr nonRec $$ + text "lbls:" <+> ppr lbls $$ + text "caf_lbls:" <+> ppr caf_lbls $$ + text "static_data:" <+> ppr static_data $$ + text "cafs:" <+> ppr cafs $$ + text "blockids:" <+> ppr blockids $$ + text "maybeFunClosure:" <+> ppr maybeFunClosure $$ + text "otherFunLabels:" <+> ppr otherFunLabels $$ + text "resolved:" <+> ppr resolved $$ + text "allBelow:" <+> ppr allBelow $$ + text "filtered0:" <+> ppr filtered0) let isStaticFun = isJust maybeFunClosure @@ -726,76 +951,114 @@ oneSRT dflags staticFuns blockids lbls isCAF cafs = do -- update the SRTMap for the label to point to a closure. It's -- important that we don't do this for static functions or CAFs, -- see Note [Invalid optimisation: shortcutting]. + updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM () updateSRTMap srtEntry = - when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do - let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls] - put (Map.union newSRTMap srtMap) + srtTrace "updateSRTMap" + (ppr srtEntry <+> "isCAF:" <+> ppr isCAF <+> + "isStaticFun:" <+> ppr isStaticFun) $ + when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ + modify' $ \state -> + let !srt_map = + foldl' (\srt_map cafLbl@(CAFLabel clbl) -> + -- Only map static data to Nothing (== not CAFFY). For CAFFY + -- statics we refer to the static itself instead of a SRT. + if not (Set.member clbl static_data) || isNothing srtEntry then + Map.insert cafLbl srtEntry srt_map + else + srt_map) + (moduleSRTMap state) + caf_lbls + in + state{ moduleSRTMap = srt_map } this_mod = thisModule topSRT - case Set.toList filtered of - [] -> do - srtTrace "oneSRT: empty" (ppr lbls) $ return () - updateSRTMap Nothing - return ([], [], []) - - -- [Inline] - when we have only one entry there is no need to - -- build an SRT object at all, instead we put the singleton SRT - -- entry in the info table. - [one@(SRTEntry lbl)] - | -- Info tables refer to SRTs by offset (as noted in the section - -- "Referring to an SRT from the info table" of Note [SRTs]). However, - -- when dynamic linking is used we cannot guarantee that the offset - -- between the SRT and the info table will fit in the offset field. - -- Consequently we build a singleton SRT in in this case. - not (labelDynamic dflags this_mod lbl) - - -- MachO relocations can't express offsets between compilation units at - -- all, so we are always forced to build a singleton SRT in this case. - && (not (osMachOTarget $ platformOS $ targetPlatform dflags) - || isLocalCLabel this_mod lbl) -> do - - -- If we have a static function closure, then it becomes the - -- SRT object, and everything else points to it. (the only way - -- we could have multiple labels here is if this is a - -- recursive group, see Note [recursive SRTs]) - case maybeFunClosure of - Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, []) - where - withLabels = - [ (b, if b == staticFunBlock then lbl else staticFunLbl) - | b <- blockids ] + allStaticData = + all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls + + if Set.null filtered0 then do + srtTraceM "oneSRT: empty" (ppr caf_lbls) + updateSRTMap Nothing + return ([], [], [], False) + else do + -- We're going to build an SRT for this group, which should include function + -- references in the group. See Note [recursive SRTs]. + let allBelow_funs = + Set.fromList (map (SRTEntry . toClosureLbl) otherFunLabels) + let filtered = filtered0 `Set.union` allBelow_funs + srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$ + text "allBelow_funs:" <+> ppr allBelow_funs) + case Set.toList filtered of + [] -> pprPanic "oneSRT" empty -- unreachable + + -- [Inline] - when we have only one entry there is no need to + -- build an SRT object at all, instead we put the singleton SRT + -- entry in the info table. + [one@(SRTEntry lbl)] + | -- Info tables refer to SRTs by offset (as noted in the section + -- "Referring to an SRT from the info table" of Note [SRTs]). However, + -- when dynamic linking is used we cannot guarantee that the offset + -- between the SRT and the info table will fit in the offset field. + -- Consequently we build a singleton SRT in in this case. + not (labelDynamic dflags this_mod lbl) + + -- MachO relocations can't express offsets between compilation units at + -- all, so we are always forced to build a singleton SRT in this case. + && (not (osMachOTarget $ platformOS $ targetPlatform dflags) + || isLocalCLabel this_mod lbl) -> do + + -- If we have a static function closure, then it becomes the + -- SRT object, and everything else points to it. (the only way + -- we could have multiple labels here is if this is a + -- recursive group, see Note [recursive SRTs]) + case maybeFunClosure of + Just (staticFunLbl,staticFunBlock) -> + return ([], withLabels, [], True) + where + withLabels = + [ (b, if b == staticFunBlock then lbl else staticFunLbl) + | b <- blockids ] + Nothing -> do + srtTraceM "oneSRT: one" (text "caf_lbls:" <+> ppr caf_lbls $$ + text "one:" <+> ppr one) + updateSRTMap (Just one) + return ([], map (,lbl) blockids, [], True) + + cafList | allStaticData -> + return ([], [], [], not (null cafList)) + + cafList -> + -- Check whether an SRT with the same entries has been emitted already. + -- Implements the [Common] optimisation. + case Map.lookup filtered (dedupSRTs topSRT) of + Just srtEntry@(SRTEntry srtLbl) -> do + srtTraceM "oneSRT [Common]" (ppr caf_lbls <+> ppr srtLbl) + updateSRTMap (Just srtEntry) + return ([], map (,srtLbl) blockids, [], True) Nothing -> do - updateSRTMap (Just one) - return ([], map (,lbl) blockids, []) - - cafList -> - -- Check whether an SRT with the same entries has been emitted already. - -- Implements the [Common] optimisation. - case Map.lookup filtered (dedupSRTs topSRT) of - Just srtEntry@(SRTEntry srtLbl) -> do - srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return () - updateSRTMap (Just srtEntry) - return ([], map (,srtLbl) blockids, []) - Nothing -> do - -- No duplicates: we have to build a new SRT object - srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return () - (decls, funSRTs, srtEntry) <- - case maybeFunClosure of - Just (fun,block) -> - return ( [], [(block, cafList)], SRTEntry fun ) - Nothing -> do - (decls, entry) <- lift . lift $ buildSRTChain dflags cafList - return (decls, [], entry) - updateSRTMap (Just srtEntry) - let allBelowThis = Set.union allBelow filtered - oldFlatSRTs = flatSRTs topSRT - newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs - newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) - lift (put (topSRT { dedupSRTs = newDedupSRTs - , flatSRTs = newFlatSRTs })) - let SRTEntry lbl = srtEntry - return (decls, map (,lbl) blockids, funSRTs) + -- No duplicates: we have to build a new SRT object + (decls, funSRTs, srtEntry) <- + case maybeFunClosure of + Just (fun,block) -> + return ( [], [(block, cafList)], SRTEntry fun ) + Nothing -> do + (decls, entry) <- lift $ buildSRTChain dflags cafList + return (decls, [], entry) + updateSRTMap (Just srtEntry) + let allBelowThis = Set.union allBelow filtered + newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT) + -- When all definition in this group are static data we don't + -- generate any SRTs. + newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) + modify' (\state -> state{ dedupSRTs = newDedupSRTs, + flatSRTs = newFlatSRTs }) + srtTraceM "oneSRT: new" (text "caf_lbls:" <+> ppr caf_lbls $$ + text "filtered:" <+> ppr filtered $$ + text "srtEntry:" <+> ppr srtEntry $$ + text "newDedupSRTs:" <+> ppr newDedupSRTs $$ + text "newFlatSRTs:" <+> ppr newFlatSRTs) + let SRTEntry lbl = srtEntry + return (decls, map (,lbl) blockids, funSRTs, True) -- | build a static SRT object (or a chain of objects) from a list of @@ -804,8 +1067,8 @@ buildSRTChain :: DynFlags -> [SRTEntry] -> UniqSM - ( [CmmDecl] -- The SRT object(s) - , SRTEntry -- label to use in the info table + ( [CmmDeclSRTs] -- The SRT object(s) + , SRTEntry -- label to use in the info table ) buildSRTChain _ [] = panic "buildSRT: empty" buildSRTChain dflags cafSet = @@ -821,7 +1084,7 @@ buildSRTChain dflags cafSet = mAX_SRT_SIZE = 16 -buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry) +buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry) buildSRT dflags refs = do id <- getUniqueM let @@ -835,20 +1098,30 @@ buildSRT dflags refs = do [] -- no saved info return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) - -- | Update info tables with references to their SRTs. Also generate -- static closures, splicing in SRT fields as necessary. updInfoSRTs :: DynFlags -> LabelMap CLabel -- SRT labels for each block -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures + -> Bool -- Whether the CmmDecl's group has CAF references -> CmmDecl - -> [CmmDecl] + -> [CmmDeclSRTs] + +updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics)) + = [CmmData s (RawCmmStatics lbl statics)] + +updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload)) + = [CmmData s (RawCmmStatics lbl (map CmmStaticLit field_lits))] + where + caf_info = if caffy then MayHaveCafRefs else NoCafRefs + field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload -updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) +updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g) | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] | otherwise = [ proc ] where + caf_info = if caffy then MayHaveCafRefs else NoCafRefs proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info) updInfoTbl l info_tbl @@ -858,7 +1131,7 @@ updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) -- Generate static closures [FUN]. Note that this also generates -- static closures for thunks (CAFs), because it's easier to treat -- them uniformly in the code generator. - maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl) + maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs) maybeStaticClosure | Just info_tbl@CmmInfoTable{..} <- mapLookup (g_entry g) (info_tbls top_info) @@ -873,20 +1146,20 @@ updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) Just srtEntries -> srtTrace "maybeStaticFun" (ppr res) (info_tbl { cit_rep = new_rep }, res) where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] - fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id) - srtEntries + fields = mkStaticClosureFields dflags info_tbl ccs caf_info srtEntries new_rep = case cit_rep of HeapRep sta ptrs nptrs ty -> HeapRep sta (ptrs + length srtEntries) nptrs ty _other -> panic "maybeStaticFun" - lbl = mkLocalClosureLabel (idName id) (idCafInfo id) + lbl = mkLocalClosureLabel (idName id) caf_info in Just (newInfo, mkDataLits (Section Data lbl) lbl fields) | otherwise = Nothing -updInfoSRTs _ _ _ t = [t] - srtTrace :: String -> SDoc -> b -> b -- srtTrace = pprTrace srtTrace _ _ b = b + +srtTraceM :: Applicative f => String -> SDoc -> f () +srtTraceM str doc = srtTrace str doc (pure ()) diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index d7235d0167..886f429611 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -394,7 +394,7 @@ cmmdata :: { CmmParse () } : 'section' STRING '{' data_label statics '}' { do lbl <- $4; ss <- sequence $5; - code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) } + code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) } data_label :: { CmmParse CLabel } : NAME ':' @@ -1175,7 +1175,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] - code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits + code $ emitRawDataLits (mkCmmDataLabel pkg cl_label) lits foreignCall :: String diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 6db9e23ee1..9fd484fdb2 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} module GHC.Cmm.Pipeline ( -- | Converts C-- with an implicit stack and native C-- calls into @@ -27,6 +29,7 @@ import HscTypes import Control.Monad import Outputable import GHC.Platform +import Data.Either (partitionEithers) ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline @@ -37,14 +40,15 @@ cmmPipeline -- dynamic flags: -dcmm-lint -ddump-cmm-cps -> ModuleSRTInfo -- Info about SRTs generated so far -> CmmGroup -- Input C-- with Procedures - -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- + -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ do let dflags = hsc_dflags hsc_env tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog - (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops + let (procs, data_) = partitionEithers tops + (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms) return (srtInfo, cmms) @@ -54,8 +58,8 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") dflags = hsc_dflags hsc_env -cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) -cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) +cpsTop :: HscEnv -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) +cpsTop _ p@(CmmData _ statics) = return (Right (cafAnalData statics, p)) cpsTop hsc_env proc = do ----------- Control-flow optimisations ---------------------------------- @@ -85,7 +89,9 @@ cpsTop hsc_env proc = dump Opt_D_dump_cmm_switch "Post switch plan" g ----------- Proc points ------------------------------------------------- - let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g + let + call_pps :: ProcPointSet -- LabelMap + call_pps = {-# SCC "callProcPoints" #-} callProcPoints g proc_points <- if splitting_proc_points then do @@ -144,7 +150,7 @@ cpsTop hsc_env proc = -- See Note [unreachable blocks] dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - return (cafEnv, g) + return (Left (cafEnv, g)) where dflags = hsc_dflags hsc_env platform = targetPlatform dflags diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs index 2544e6a0d3..e91c4b6277 100644 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -54,13 +54,13 @@ import qualified Data.ByteString as BS pprCmms :: (Outputable info, Outputable g) - => [GenCmmGroup CmmStatics info g] -> SDoc + => [GenCmmGroup RawCmmStatics info g] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ text "-------------------" $$ space writeCmms :: (Outputable info, Outputable g) - => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () + => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO () writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms) ----------------------------------------------------------------------------- @@ -72,6 +72,9 @@ instance (Outputable d, Outputable info, Outputable i) instance Outputable CmmStatics where ppr = pprStatics +instance Outputable RawCmmStatics where + ppr = pprRawStatics + instance Outputable CmmStatic where ppr = pprStatic @@ -136,8 +139,14 @@ 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 ((ppr lbl <> colon) : map ppr ds) +pprStatics (CmmStatics lbl itbl ccs payload) = + ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload +pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds) + +pprRawStatics :: RawCmmStatics -> SDoc +pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) pprStatic :: CmmStatic -> SDoc pprStatic s = case s of diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 02d64da936..eda440040d 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -192,22 +192,22 @@ mkWordCLit :: DynFlags -> Integer -> CmmLit mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) mkByteStringCLit - :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) + :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt) -- We have to make a top-level decl for the string, -- and return a literal pointing to it mkByteStringCLit lbl bytes - = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes]) + = (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics lbl [CmmString bytes]) where -- This can not happen for String literals (as there \NUL is replaced by -- C0 80). However, it can happen with Addr# literals. sec = if 0 `BS.elem` bytes then ReadOnlyData else CString -mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt -- Build a data-segment data block mkDataLits section lbl lits - = CmmData section (Statics lbl $ map CmmStaticLit lits) + = CmmData section (RawCmmStatics lbl $ map CmmStaticLit lits) -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt -- Build a read-only data block mkRODataLits lbl lits = mkDataLits section lbl lits diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index a413820e30..66416c084c 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -87,7 +87,7 @@ pprTop (CmmProc infos clbl _in_live_regs graph) = (case mapLookup (g_entry graph) infos of Nothing -> empty - Just (Statics info_clbl info_dat) -> + Just (RawCmmStatics info_clbl info_dat) -> pprDataExterns info_dat $$ pprWordArray info_is_in_rodata info_clbl info_dat) $$ (vcat [ @@ -110,21 +110,21 @@ pprTop (CmmProc infos clbl _in_live_regs graph) = -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData section (Statics lbl [CmmString str])) = +pprTop (CmmData section (RawCmmStatics lbl [CmmString str])) = pprExternDecl lbl $$ hcat [ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, text "[] = ", pprStringInCStyle str, semi ] -pprTop (CmmData section (Statics lbl [CmmUninitialised size])) = +pprTop (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) = pprExternDecl lbl $$ hcat [ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, brackets (int size), semi ] -pprTop (CmmData section (Statics lbl lits)) = +pprTop (CmmData section (RawCmmStatics lbl lits)) = pprDataExterns lits $$ pprWordArray (isSecConstant section) lbl lits diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 83799f6e49..b0738fdb82 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -33,8 +33,7 @@ import DataCon import CostCentre import VarEnv import Module -import Name ( isExternalName, nameOccName, nameModule_maybe ) -import OccName ( occNameFS ) +import Name ( isExternalName, nameModule_maybe ) import BasicTypes ( Arity ) import TysWiredIn ( unboxedUnitDataCon, unitDataConId ) import Literal @@ -268,7 +267,6 @@ coreTopBindToStg dflags this_mod env ccs (NonRec id rhs) bind = StgTopLifted $ StgNonRec id stg_rhs in - assertConsistentCafInfo dflags id bind (ppr bind) -- NB: previously the assertion printed 'rhs' and 'bind' -- as well as 'id', but that led to a black hole -- where printing the assertion error tripped the @@ -296,34 +294,8 @@ coreTopBindToStg dflags this_mod env ccs (Rec pairs) bind = StgTopLifted $ StgRec (zip binders stg_rhss) in - assertConsistentCafInfo dflags (head binders) bind (ppr binders) (env', ccs', bind) --- | CAF consistency issues will generally result in segfaults and are quite --- difficult to debug (see #16846). We enable checking of the --- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that --- we catch these issues. -assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a -assertConsistentCafInfo dflags id bind err_doc result - | gopt Opt_DoStgLinting dflags || debugIsOn - , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc - | otherwise = result - --- Assertion helper: this checks that the CafInfo on the Id matches --- what CoreToStg has figured out about the binding's SRT. The --- CafInfo will be exact in all cases except when CorePrep has --- floated out a binding, in which case it will be approximate. -consistentCafInfo :: Id -> StgTopBinding -> Bool -consistentCafInfo id bind - = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) - safe - where - safe = id_marked_caffy || not binding_is_caffy - exact = id_marked_caffy == binding_is_caffy - id_marked_caffy = mayHaveCafRefs (idCafInfo id) - binding_is_caffy = topStgBindHasCafRefs bind - is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" - coreToTopStgRhs :: DynFlags -> CollectedCCs diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 14716081d4..59de501fa8 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -30,7 +30,6 @@ import CoreFVs import CoreMonad ( CoreToDo(..) ) import CoreLint ( endPassIO ) import CoreSyn -import CoreSubst import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here import Type import Literal @@ -54,13 +53,11 @@ import ErrUtils import DynFlags import Util import Outputable -import GHC.Platform import FastString import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits import MonadUtils ( mapAccumLM ) -import Data.List ( mapAccumL ) import Control.Monad import CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S @@ -266,40 +263,6 @@ where x is demanded, in which case we want to finish with x* = f a And then x will actually end up case-bound -Note [CafInfo and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What happens when we try to float bindings to the top level? At this -point all the CafInfo is supposed to be correct, and we must make certain -that is true of the new top-level bindings. There are two cases -to consider - -a) The top-level binding is marked asCafRefs. In that case we are - basically fine. The floated bindings had better all be lazy lets, - so they can float to top level, but they'll all have HasCafRefs - (the default) which is safe. - -b) The top-level binding is marked NoCafRefs. This really happens - Example. CoreTidy produces - $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... - Now CorePrep has to eta-expand to - $fApplicativeSTM = let sat = \xy. retry x y - in D:Alternative sat ...blah... - So what we *want* is - sat [NoCafRefs] = \xy. retry x y - $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... - - So, gruesomely, we must set the NoCafRefs flag on the sat bindings, - *and* substitute the modified 'sat' into the old RHS. - - It should be the case that 'sat' is itself [NoCafRefs] (a value, no - cafs) else the original top-level binding would not itself have been - marked [NoCafRefs]. The DEBUG check in CoreToStg for - consistentCafInfo will find this. - -This is all very gruesome and horrible. It would be better to figure -out CafInfo later, after CorePrep. We'll do that in due course. -Meanwhile this horrible hack works. - Note [Join points and floating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Join points can float out of other join points but not out of value bindings: @@ -503,8 +466,6 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs ; return (floats4, rhs4) } where - platform = targetPlatform (cpe_dynFlags env) - arity = idArity bndr -- We must match this arity --------------------- @@ -520,14 +481,12 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs | otherwise = dontFloat floats rhs --------------------- - float_top floats rhs -- Urhgh! See Note [CafInfo and floating] - | mayHaveCafRefs (idCafInfo bndr) - , allLazyTop floats + float_top floats rhs + | allLazyTop floats = return (floats, rhs) - -- So the top-level binding is marked NoCafRefs - | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs - = return (floats', rhs') + | Just floats <- canFloat floats rhs + = return floats | otherwise = dontFloat floats rhs @@ -1321,57 +1280,27 @@ deFloatTop (Floats _ floats) --------------------------------------------------------------------------- -canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) - -- Note [CafInfo and floating] -canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs +canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) +canFloat (Floats ok_to_spec fs) rhs | OkToSpec <- ok_to_spec -- Worth trying - , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) - = Just (Floats OkToSpec fs', subst_expr subst rhs) + , Just fs' <- go nilOL (fromOL fs) + = Just (Floats OkToSpec fs', rhs) | otherwise = Nothing where - subst_expr = substExpr (text "CorePrep") + go :: OrdList FloatingBind -> [FloatingBind] + -> Maybe (OrdList FloatingBind) - go :: (Subst, OrdList FloatingBind) -> [FloatingBind] - -> Maybe (Subst, OrdList FloatingBind) + go (fbs_out) [] = Just fbs_out - go (subst, fbs_out) [] = Just (subst, fbs_out) + go fbs_out (fb@(FloatLet _) : fbs_in) + = go (fbs_out `snocOL` fb) fbs_in - go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) - | rhs_ok r - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (subst', b') = set_nocaf_bndr subst b - new_fb = FloatLet (NonRec b' (subst_expr subst r)) + go fbs_out (ft@FloatTick{} : fbs_in) + = go (fbs_out `snocOL` ft) fbs_in - go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) - | all rhs_ok rs - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (bs,rs) = unzip prs - (subst', bs') = mapAccumL set_nocaf_bndr subst bs - rs' = map (subst_expr subst') rs - new_fb = FloatLet (Rec (bs' `zip` rs')) + go _ (FloatCase{} : _) = Nothing - go (subst, fbs_out) (ft@FloatTick{} : fbs_in) - = go (subst, fbs_out `snocOL` ft) fbs_in - - go _ _ = Nothing -- Encountered a caffy binding - - ------------ - set_nocaf_bndr subst bndr - = (extendIdSubst subst bndr (Var bndr'), bndr') - where - bndr' = bndr `setIdCafInfo` NoCafRefs - - ------------ - rhs_ok :: CoreExpr -> Bool - -- We can only float to top level from a NoCaf thing if - -- the new binding is static. However it can't mention - -- any non-static things or it would *already* be Caffy - rhs_ok = rhsIsStatic platform (\_ -> False) - (\_nt i -> pprPanic "rhsIsStatic" (integer i)) - -- Integer or Natural literals should not show up wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec dmd is_unlifted floats rhs diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 6f3a104925..8da7700e0e 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -23,12 +23,9 @@ import CoreUnfold import CoreFVs import CoreTidy import CoreMonad -import GHC.CoreToStg.Prep -import CoreUtils (rhsIsStatic) import CoreStats (coreBindsStats, CoreStats(..)) import CoreSeq (seqBinds) import CoreLint -import Literal import Rules import PatSyn import ConLike @@ -55,7 +52,6 @@ import DataCon import TyCon import Class import Module -import Packages( isDllName ) import HscTypes import Maybes import UniqSupply @@ -119,7 +115,7 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small * Drop rules altogether -* Tidy the bindings, to ensure that the Caf and Arity +* Tidy the bindings, to ensure that the Arity information is correct for each top-level binder; the code generator needs it. And to ensure that local names have distinct OccNames in case of object-file splitting @@ -217,7 +213,7 @@ globaliseAndTidyBootId :: Id -> Id -- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details --- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity) +-- * VanillaIdInfo (makes a conservative assumption about arity) -- * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) globaliseAndTidyBootId id = globaliseId id `setIdType` tidyTopType (idType id) @@ -316,8 +312,6 @@ binder * its arity, computed from the number of visible lambdas - * its CAF info, computed from what is free in its RHS - Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in @@ -359,7 +353,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod = findExternalRules omit_prags binds imp_rules unfold_env } ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds + <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds -- See Note [Grand plan for static forms] in StaticPtrTable. ; (spt_entries, tidy_binds') <- @@ -1070,22 +1064,13 @@ tidyTopName mod nc_var maybe_ref occ_env id -- * subst_env: A Var->Var mapping that substitutes the new Var for the old tidyTopBinds :: HscEnv - -> Module -> UnfoldEnv -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - mkNaturalId <- lookupMkNaturalName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env - let cvt_literal nt i = case nt of - LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i) - LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i) - _ -> Nothing - result = tidy cvt_literal init_env binds +tidyTopBinds hsc_env unfold_env init_occ_env binds + = do let result = tidy init_env binds seqBinds (snd result) `seq` return result -- This seqBinds avoids a spike in space usage (see #13564) where @@ -1093,35 +1078,28 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds init_env = (init_occ_env, emptyVarEnv) - tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env) + tidy = mapAccumL (tidyTopBind dflags unfold_env) ------------------------ tidyTopBind :: DynFlags - -> Module - -> (LitNumType -> Integer -> Maybe CoreExpr) -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind dflags this_mod cvt_literal unfold_env +tidyTopBind dflags unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs dflags this_mod - (subst1, cvt_literal) - (idArity bndr) rhs - (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' - (bndr, rhs) + (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind dflags this_mod cvt_literal unfold_env - (occ_env, subst1) (Rec prs) +tidyTopBind dflags unfold_env (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where - prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) + prs' = [ tidyTopPair dflags show_unfold tidy_env2 name' (id,rhs) | (id,rhs) <- prs, let (name',show_unfold) = expectJust "tidyTopBind" $ lookupVarEnv unfold_env id @@ -1132,21 +1110,11 @@ tidyTopBind dflags this_mod cvt_literal unfold_env bndrs = map fst prs - -- the CafInfo for a recursive group says whether *any* rhs in - -- the group may refer indirectly to a CAF (because then, they all do). - caf_info - | or [ mayHaveCafRefs (hasCafRefs dflags this_mod - (subst1, cvt_literal) - (idArity bndr) rhs) - | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - ----------------------------------------------------------- tidyTopPair :: DynFlags -> Bool -- show unfolding -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it! - -> CafInfo -> Name -- New name -> (Id, CoreExpr) -- Binder and RHS before tidying -> (Id, CoreExpr) @@ -1156,7 +1124,7 @@ tidyTopPair :: DynFlags -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) +tidyTopPair dflags show_unfold rhs_tidy_env name' (bndr, rhs) = (bndr1, rhs1) where bndr1 = mkGlobalId details name' ty' idinfo' @@ -1164,28 +1132,22 @@ tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) ty' = tidyTopType (idType bndr) rhs1 = tidyExpr rhs_tidy_env rhs idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) - show_unfold caf_info + show_unfold -- tidyTopIdInfo creates the final IdInfo for top-level --- binders. There are two delicate pieces: +-- binders. The delicate piece: -- -- * Arity. After CoreTidy, this arity must not change any more. -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. -- --- * CAF info. This must also remain valid through to code generation. --- We add the info here so that it propagates to all --- occurrences of the binders in RHSs, and hence to occurrences in --- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. --- CoreToStg makes use of this when constructing SRTs. tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr - -> IdInfo -> Bool -> CafInfo -> IdInfo -tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info + -> IdInfo -> Bool -> IdInfo +tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info `setArityInfo` arity `setStrictnessInfo` final_sig `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] @@ -1193,7 +1155,6 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo - `setCafInfo` caf_info `setArityInfo` arity `setStrictnessInfo` final_sig `setOccInfo` robust_occ_info @@ -1257,137 +1218,6 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ {- ************************************************************************ * * - Figuring out CafInfo for an expression -* * -************************************************************************ - -hasCafRefs decides whether a top-level closure can point into the dynamic heap. -We mark such things as `MayHaveCafRefs' because this information is -used to decide whether a particular closure needs to be referenced -in an SRT or not. - -There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs - -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore -it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. - -Note [Disgusting computation of CafRefs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute hasCafRefs here, because IdInfo is supposed to be finalised -after tidying. But CorePrep does some transformations that affect CAF-hood. -So we have to *predict* the result here, which is revolting. - -In particular CorePrep expands Integer and Natural literals. So in the -prediction code here we resort to applying the same expansion (cvt_literal). -There are also numerous other ways in which we can introduce inconsistencies -between CorePrep and GHC.Iface.Tidy. See Note [CAFfyness inconsistencies due to -eta expansion in TidyPgm] for one such example. - -Ugh! What ugliness we hath wrought. - - -Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Eta expansion during CorePrep can have non-obvious negative consequences on -the CAFfyness computation done by tidying (see Note [Disgusting computation of -CafRefs] in GHC.Iface.Tidy). This late expansion happens/happened for a few -reasons: - - * CorePrep previously eta expanded unsaturated primop applications, as - described in Note [Primop wrappers]). - - * CorePrep still does eta expand unsaturated data constructor applications. - -In particular, consider the program: - - data Ty = Ty (RealWorld# -> (# RealWorld#, Int #)) - - -- Is this CAFfy? - x :: STM Int - x = Ty (retry# @Int) - -Consider whether x is CAFfy. One might be tempted to answer "no". -Afterall, f obviously has no CAF references and the application (retry# -@Int) is essentially just a variable reference at runtime. - -However, when CorePrep expanded the unsaturated application of 'retry#' -it would rewrite this to - - x = \u [] - let sat = retry# @Int - in Ty sat - -This is now a CAF. Failing to handle this properly was the cause of -#16846. We fixed this by eliminating the need to eta expand primops, as -described in Note [Primop wrappers]), However we have not yet done the same for -data constructor applications. - --} - -type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr) - -- The env finds the Caf-ness of the Id - -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for - -- Integer and Natural literals - -- See Note [Disgusting computation of CafRefs] - -hasCafRefs :: DynFlags -> Module - -> CafRefEnv -> Arity -> CoreExpr - -> CafInfo -hasCafRefs dflags this_mod (subst, cvt_literal) arity expr - | is_caf || mentions_cafs = MayHaveCafRefs - | otherwise = NoCafRefs - where - mentions_cafs = cafRefsE expr - is_dynamic_name = isDllName dflags this_mod - is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name - cvt_literal expr) - - -- NB. we pass in the arity of the expression, which is expected - -- to be calculated by exprArity. This is because exprArity - -- knows how much eta expansion is going to be done by - -- CorePrep later on, and we don't want to duplicate that - -- knowledge in rhsIsStatic below. - - cafRefsE :: Expr a -> Bool - cafRefsE (Var id) = cafRefsV id - cafRefsE (Lit lit) = cafRefsL lit - cafRefsE (App f a) = cafRefsE f || cafRefsE a - cafRefsE (Lam _ e) = cafRefsE e - cafRefsE (Let b e) = cafRefsEs (rhssOfBind b) || cafRefsE e - cafRefsE (Case e _ _ alts) = cafRefsE e || cafRefsEs (rhssOfAlts alts) - cafRefsE (Tick _n e) = cafRefsE e - cafRefsE (Cast e _co) = cafRefsE e - cafRefsE (Type _) = False - cafRefsE (Coercion _) = False - - cafRefsEs :: [Expr a] -> Bool - cafRefsEs [] = False - cafRefsEs (e:es) = cafRefsE e || cafRefsEs es - - cafRefsL :: Literal -> Bool - -- Don't forget that mk_integer id might have Caf refs! - -- We first need to convert the Integer into its final form, to - -- see whether mkInteger is used. Same for LitNatural. - cafRefsL (LitNumber nt i _) = case cvt_literal nt i of - Just e -> cafRefsE e - Nothing -> False - cafRefsL _ = False - - cafRefsV :: Id -> Bool - cafRefsV id - | not (isLocalId id) = mayHaveCafRefs (idCafInfo id) - | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id') - | otherwise = False - - -{- -************************************************************************ -* * Old, dead, type-trimming code * * ************************************************************************ diff --git a/compiler/GHC/Iface/Utils.hs b/compiler/GHC/Iface/Utils.hs index d410a2c461..df3671fad1 100644 --- a/compiler/GHC/Iface/Utils.hs +++ b/compiler/GHC/Iface/Utils.hs @@ -160,17 +160,38 @@ mkPartialIface hsc_env mod_details -- | Fully instantiate a interface -- Adds fingerprints and potentially code generator produced information. -mkFullIface :: HscEnv -> PartialModIface -> IO ModIface -mkFullIface hsc_env partial_iface = do +mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface +mkFullIface hsc_env partial_iface mb_non_cafs = do + let decls + | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) + = mi_decls partial_iface + | otherwise + = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs + full_iface <- {-# SCC "addFingerprints" #-} - addFingerprints hsc_env partial_iface + addFingerprints hsc_env partial_iface{ mi_decls = decls } -- Debug printing dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface) return full_iface +updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl] +updateDeclCafInfos decls Nothing = decls +updateDeclCafInfos decls (Just non_cafs) = map update_decl decls + where + update_decl decl + | IfaceId nm ty details id_info <- decl + , elemNameSet nm non_cafs + = IfaceId nm ty details $ + case id_info of + NoInfo -> HasInfo [HsNoCafRefs] + HasInfo infos -> HasInfo (HsNoCafRefs : infos) + + | otherwise + = decl + -- | Make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). @@ -221,7 +242,7 @@ mkIfaceTc hsc_env safe_mode mod_details doc_hdr' doc_map arg_map mod_details - mkFullIface hsc_env partial_iface + mkFullIface hsc_env partial_iface Nothing mkIface_ :: HscEnv -> Module -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs new file mode 100644 index 0000000000..a042902180 --- /dev/null +++ b/compiler/GHC/Stg/DepAnal.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} + +module GHC.Stg.DepAnal (depSortStgPgm) where + +import GhcPrelude + +import GHC.Stg.Syntax +import Id +import Name (Name) +import NameEnv +import Outputable +import UniqSet (nonDetEltsUniqSet) +import VarSet + +import Data.Graph (SCC (..)) + +-------------------------------------------------------------------------------- +-- * Dependency analysis + +-- | Set of bound variables +type BVs = VarSet + +-- | Set of free variables +type FVs = VarSet + +-- | Dependency analysis on STG terms. +-- +-- Dependencies of a binding are just free variables in the binding. This +-- includes imported ids and ids in the current module. For recursive groups we +-- just return one set of free variables which is just the union of dependencies +-- of all bindings in the group. +-- +-- Implementation: pass bound variables (BVs) to recursive calls, get free +-- variables (FVs) back. +-- +annTopBindingsDeps :: [StgTopBinding] -> [(StgTopBinding, FVs)] +annTopBindingsDeps bs = zip bs (map top_bind bs) + where + top_bind :: StgTopBinding -> FVs + + top_bind StgTopStringLit{} = + emptyVarSet + + top_bind (StgTopLifted bs) = + binding emptyVarSet bs + + binding :: BVs -> StgBinding -> FVs + + binding bounds (StgNonRec _ r) = + rhs bounds r + + binding bounds (StgRec bndrs) = + unionVarSets $ + map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs + + bind_non_rec :: BVs -> (Id, StgRhs) -> FVs + bind_non_rec bounds (_, r) = + rhs bounds r + + rhs :: BVs -> StgRhs -> FVs + + rhs bounds (StgRhsClosure _ _ _ as e) = + expr (extendVarSetList bounds as) e + + rhs bounds (StgRhsCon _ _ as) = + args bounds as + + var :: BVs -> Var -> FVs + var bounds v + | not (elemVarSet v bounds) + = unitVarSet v + | otherwise + = emptyVarSet + + arg :: BVs -> StgArg -> FVs + arg bounds (StgVarArg v) = var bounds v + arg _ StgLitArg{} = emptyVarSet + + args :: BVs -> [StgArg] -> FVs + args bounds as = unionVarSets (map (arg bounds) as) + + expr :: BVs -> StgExpr -> FVs + + expr bounds (StgApp f as) = + var bounds f `unionVarSet` args bounds as + + expr _ StgLit{} = + emptyVarSet + + expr bounds (StgConApp _ as _) = + args bounds as + + expr bounds (StgOpApp _ as _) = + args bounds as + + expr _ lam@StgLam{} = + pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ ppr lam) + + expr bounds (StgCase scrut scrut_bndr _ as) = + expr bounds scrut `unionVarSet` + alts (extendVarSet bounds scrut_bndr) as + + expr bounds (StgLet _ bs e) = + binding bounds bs `unionVarSet` + expr (extendVarSetList bounds (bindersOf bs)) e + + expr bounds (StgLetNoEscape _ bs e) = + binding bounds bs `unionVarSet` + expr (extendVarSetList bounds (bindersOf bs)) e + + expr bounds (StgTick _ e) = + expr bounds e + + alts :: BVs -> [StgAlt] -> FVs + alts bounds = unionVarSets . map (alt bounds) + + alt :: BVs -> StgAlt -> FVs + alt bounds (_, bndrs, e) = + expr (extendVarSetList bounds bndrs) e + +-------------------------------------------------------------------------------- +-- * Dependency sorting + +-- | Dependency sort a STG program so that dependencies come before uses. +depSortStgPgm :: [StgTopBinding] -> [StgTopBinding] +depSortStgPgm = map fst . depSort . annTopBindingsDeps + +-- | Sort free-variable-annotated STG bindings so that dependencies come before +-- uses. +depSort :: [(StgTopBinding, FVs)] -> [(StgTopBinding, FVs)] +depSort = concatMap get_binds . depAnal defs uses + where + uses, defs :: (StgTopBinding, FVs) -> [Name] + + -- TODO (osa): I'm unhappy about two things in this code: + -- + -- * Why do we need Name instead of Id for uses and dependencies? + -- * Why do we need a [Name] instead of `Set Name`? Surely depAnal + -- doesn't need any ordering. + + uses (StgTopStringLit{}, _) = [] + uses (StgTopLifted{}, fvs) = map idName (nonDetEltsUniqSet fvs) + + defs (bind, _) = map idName (bindersOfTop bind) + + get_binds (AcyclicSCC bind) = + [bind] + get_binds (CyclicSCC binds) = + pprPanic "depSortStgBinds" (text "Found cyclic SCC:" $$ ppr binds) diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index e7044a89e0..d2a0b8980e 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -227,25 +227,6 @@ lintAlt (DataAlt _, bndrs, rhs) = do {- ************************************************************************ * * -Utilities -* * -************************************************************************ --} - -bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] -bindersOf (StgNonRec binder _) = [binder] -bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] - -bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] -bindersOfTop (StgTopLifted bind) = bindersOf bind -bindersOfTop (StgTopStringLit binder _) = [binder] - -bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] -bindersOfTopBinds = foldr ((++) . bindersOfTop) [] - -{- -************************************************************************ -* * The Lint monad * * ************************************************************************ diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index 13b403fc53..87690b90eb 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -19,6 +19,7 @@ import GHC.Stg.Syntax import GHC.Stg.Lint ( lintStgTopBindings ) import GHC.Stg.Stats ( showStgStats ) +import GHC.Stg.DepAnal ( depSortStgPgm ) import GHC.Stg.Unarise ( unarise ) import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( stgLiftLams ) @@ -56,9 +57,18 @@ stg2stg dflags this_mod binds ; binds' <- runStgM 'g' $ foldM do_stg_pass binds (getStgToDo dflags) - ; dump_when Opt_D_dump_stg_final "Final STG:" binds' - - ; return binds' + -- Dependency sort the program as last thing. The program needs to be + -- in dependency order for the SRT algorithm to work (see + -- CmmBuildInfoTables, which also includes a detailed description of + -- the algorithm), and we don't guarantee that the program is already + -- sorted at this point. #16192 is for simplifier not preserving + -- dependency order. We also don't guarantee that StgLiftLams will + -- preserve the order or only create minimal recursive groups, so a + -- sorting pass is necessary. + ; let binds_sorted = depSortStgPgm binds' + ; dump_when Opt_D_dump_stg_final "Final STG:" binds_sorted + + ; return binds_sorted } where diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 256be34ce8..5c57722a42 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -48,11 +48,12 @@ module GHC.Stg.Syntax ( StgOp(..), -- utils - topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, + stgRhsArity, isDllConApp, stgArgType, stripStgTicksTop, stripStgTicksTopE, stgCaseBndrInScope, + bindersOf, bindersOfTop, bindersOfTopBinds, pprStgBinding, pprGenStgTopBindings, pprStgTopBindings ) where @@ -70,7 +71,6 @@ import DataCon import DynFlags import ForeignCall ( ForeignCall ) import Id -import IdInfo ( mayHaveCafRefs ) import VarSet import Literal ( Literal, literalType ) import Module ( Module ) @@ -475,82 +475,6 @@ stgRhsArity (StgRhsClosure _ _ _ bndrs _) -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon _ _ _) = 0 --- Note [CAF consistency] --- ~~~~~~~~~~~~~~~~~~~~~~ --- --- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in --- `CoreToStg`) to make sure CAF-ness predicted by `GHC.Iface.Tidy` is consistent with --- reality. --- --- Specifically, if the RHS mentions any Id that itself is marked --- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the --- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble --- is that `GHC.Iface.Tidy` computed the CAF info on the `Id` but some transformations --- have taken place since then. - -topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool -topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs)) - = topRhsHasCafRefs rhs -topStgBindHasCafRefs (StgTopLifted (StgRec binds)) - = any topRhsHasCafRefs (map snd binds) -topStgBindHasCafRefs StgTopStringLit{} - = False - -topRhsHasCafRefs :: GenStgRhs pass -> Bool -topRhsHasCafRefs (StgRhsClosure _ _ upd _ body) - = -- See Note [CAF consistency] - isUpdatable upd || exprHasCafRefs body -topRhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -exprHasCafRefs :: GenStgExpr pass -> Bool -exprHasCafRefs (StgApp f args) - = stgIdHasCafRefs f || any stgArgHasCafRefs args -exprHasCafRefs StgLit{} - = False -exprHasCafRefs (StgConApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgOpApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgLam _ body) - = exprHasCafRefs body -exprHasCafRefs (StgCase scrt _ _ alts) - = exprHasCafRefs scrt || any altHasCafRefs alts -exprHasCafRefs (StgLet _ bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgLetNoEscape _ bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgTick _ expr) - = exprHasCafRefs expr - -bindHasCafRefs :: GenStgBinding pass -> Bool -bindHasCafRefs (StgNonRec _ rhs) - = rhsHasCafRefs rhs -bindHasCafRefs (StgRec binds) - = any rhsHasCafRefs (map snd binds) - -rhsHasCafRefs :: GenStgRhs pass -> Bool -rhsHasCafRefs (StgRhsClosure _ _ _ _ body) - = exprHasCafRefs body -rhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -altHasCafRefs :: GenStgAlt pass -> Bool -altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs - -stgArgHasCafRefs :: StgArg -> Bool -stgArgHasCafRefs (StgVarArg id) - = stgIdHasCafRefs id -stgArgHasCafRefs _ - = False - -stgIdHasCafRefs :: Id -> Bool -stgIdHasCafRefs id = - -- We are looking for occurrences of an Id that is bound at top level, and may - -- have CAF refs. At this point (after GHC.Iface.Tidy) top-level Ids (whether - -- imported or defined in this module) are GlobalIds, so the test is easy. - isGlobalId id && mayHaveCafRefs (idCafInfo id) - {- ************************************************************************ * * @@ -682,6 +606,25 @@ data StgOp {- ************************************************************************ * * +Utilities +* * +************************************************************************ +-} + +bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] +bindersOf (StgNonRec binder _) = [binder] +bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] + +bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] +bindersOfTop (StgTopLifted bind) = bindersOf bind +bindersOfTop (StgTopStringLit binder _) = [binder] + +bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] +bindersOfTopBinds = foldr ((++) . bindersOfTop) [] + +{- +************************************************************************ +* * Pretty-printing * * ************************************************************************ diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index f489ce6456..d83e8fbc7b 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -27,7 +27,6 @@ import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky import GHC.Cmm -import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Stg.Syntax @@ -178,7 +177,7 @@ mkModuleInit cost_centre_info this_mod hpc_info cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon = do dflags <- getDynFlags - emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) + emitRawRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con) | con <- tyConDataCons tycon] diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index a78ab5cb41..977fa4649e 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -87,15 +87,11 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body = -- hole detection from working in that case. Test -- concurrent/should_run/4030 fails, for instance. -- - gen_code dflags _ closure_label + gen_code _ _ closure_label | StgApp f [] <- body, null args, isNonRec rec = do cg_info <- getCgIdInfo f - let closure_rep = mkStaticClosureFields dflags - indStaticInfoTable ccs MayHaveCafRefs - [unLit (idInfoToAmode cg_info)] - emitDataLits closure_label closure_rep - return () + emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] gen_code dflags lf_info _closure_label = do { let name = idName id diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 2bbeabace6..7d86620708 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -104,17 +104,8 @@ cgTopRhsCon dflags id con args = -- NB2: all the amodes should be Lits! -- TODO (osa): Why? - ; let closure_rep = mkStaticClosureFields - dflags - info_tbl - dontCareCCS -- Because it's static data - caffy -- Has CAF refs - payload - -- BUILD THE OBJECT - ; emitDataLits closure_label closure_rep - - ; return () } + ; emitDataCon closure_label info_tbl dontCareCCS payload } --------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 0ac573314a..085d47219f 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -196,7 +196,9 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload | otherwise = [] static_link_field - | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl + | is_caf + = [mkIntCLit dflags 0] + | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl = [static_link_value] | otherwise = [] diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs index a3f4112206..219285efbe 100644 --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -41,7 +41,7 @@ initHpc _ (NoHpcInfo {}) initHpc this_mod (HpcInfo tickCount _hashNo) = do dflags <- getDynFlags when (gopt Opt_Hpc dflags) $ - do emitDataLits (mkHpcTicksLabel this_mod) + emitRawDataLits (mkHpcTicksLabel this_mod) [ (CmmInt 0 W64) | _ <- take tickCount [0 :: Int ..] ] diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index cf5ce5acfb..581e8279dc 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -231,7 +231,7 @@ emitCostCentreDecl cc = do is_caf, -- StgInt is_caf zero dflags -- struct _CostCentre *link ] - ; emitDataLits (mkCCLabel cc) lits + ; emitRawDataLits (mkCCLabel cc) lits } emitCostCentreStackDecl :: CostCentreStack -> FCode () @@ -247,7 +247,7 @@ emitCostCentreStackDecl ccs -- layouts of structs containing long-longs, simply -- pad out the struct with zero words until we hit the -- size of the overall struct (which we get via DerivedConstants.h) - emitDataLits (mkCCSLabel ccs) (mk_lits cc) + emitRawDataLits (mkCCSLabel ccs) (mk_lits cc) Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) zero :: DynFlags -> CmmLit diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 6e2e2d3a6b..fbb121dae6 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -240,7 +240,7 @@ emitTickyCounter cloType name args ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args - ; emitDataLits ctr_lbl + ; emitRawDataLits ctr_lbl -- Must match layout of includes/rts/Ticky.h's StgEntCounter -- -- krc: note that all the fields are I32 now; some were I16 diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 7a784ea85c..373beeed07 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -10,8 +10,9 @@ module GHC.StgToCmm.Utils ( cgLit, mkSimpleLit, - emitDataLits, mkDataLits, - emitRODataLits, mkRODataLits, + emitRawDataLits, mkRawDataLits, + emitRawRODataLits, mkRawRODataLits, + emitDataCon, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, assignTemp, newTemp, @@ -36,7 +37,7 @@ module GHC.StgToCmm.Utils ( cmmUntag, cmmIsTagged, addToMem, addToMemE, addToMemLblE, addToMemLbl, - mkWordCLit, + mkWordCLit, mkByteStringCLit, newStringCLit, newByteStringCLit, blankWord, @@ -57,7 +58,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Graph as CmmGraph import GHC.Platform.Regs import GHC.Cmm.CLabel -import GHC.Cmm.Utils +import GHC.Cmm.Utils hiding (mkDataLits, mkRODataLits, mkByteStringCLit) import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils @@ -76,9 +77,11 @@ import DynFlags import FastString import Outputable import GHC.Types.RepType +import CostCentre import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Char import Data.List @@ -270,13 +273,43 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) -- ------------------------------------------------------------------------- -emitDataLits :: CLabel -> [CmmLit] -> FCode () +mkRawDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +-- Build a data-segment data block +mkRawDataLits section lbl lits + = CmmData section (CmmStaticsRaw lbl (map CmmStaticLit lits)) + +mkRawRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +-- Build a read-only data block +mkRawRODataLits lbl lits + = mkRawDataLits section lbl lits + where + section | any needsRelocation lits = Section RelocatableReadOnlyData lbl + | otherwise = Section ReadOnlyData lbl + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False + +mkByteStringCLit + :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) +-- We have to make a top-level decl for the string, +-- and return a literal pointing to it +mkByteStringCLit lbl bytes + = (CmmLabel lbl, CmmData (Section sec lbl) (CmmStaticsRaw lbl [CmmString bytes])) + where + -- This can not happen for String literals (as there \NUL is replaced by + -- C0 80). However, it can happen with Addr# literals. + sec = if 0 `BS.elem` bytes then ReadOnlyData else CString + +emitRawDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block -emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits) +emitRawDataLits lbl lits = emitDecl (mkRawDataLits (Section Data lbl) lbl lits) -emitRODataLits :: CLabel -> [CmmLit] -> FCode () +emitRawRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block -emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) +emitRawRODataLits lbl lits = emitDecl (mkRawRODataLits lbl lits) + +emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () +emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) newStringCLit :: String -> FCode CmmLit -- Make a global definition for the string, |