diff options
77 files changed, 1132 insertions, 1030 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, diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 679360f3de..e073078766 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -28,7 +28,7 @@ module CoreUtils ( exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, exprIsBig, exprIsConLike, - rhsIsStatic, isCheapApp, isExpandableApp, + isCheapApp, isExpandableApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, altsAreExhaustive, @@ -89,7 +89,6 @@ import FastString import Maybes import ListSetOps ( minusList ) import BasicTypes ( Arity, isConLike ) -import GHC.Platform import Util import Pair import Data.ByteString ( ByteString ) @@ -2494,128 +2493,6 @@ If this happens we simply make the RHS into an updatable thunk, and 'execute' it rather than allocating it statically. -} --- | This function is called only on *top-level* right-hand sides. --- Returns @True@ if the RHS can be allocated statically in the output, --- with no thunks involved at all. -rhsIsStatic - :: Platform - -> (Name -> Bool) -- Which names are dynamic - -> (LitNumType -> Integer -> Maybe CoreExpr) - -- Desugaring for some literals (disgusting) - -- C.f. Note [Disgusting computation of CafRefs] in GHC.Iface.Tidy - -> CoreExpr -> Bool --- It's called (i) in GHC.Iface.Tidy.hasCafRefs to decide if the rhs is, or --- refers to, CAFs; (ii) in CoreToStg to decide whether to put an --- update flag on it and (iii) in DsExpr to decide how to expand --- list literals --- --- The basic idea is that rhsIsStatic returns True only if the RHS is --- (a) a value lambda --- (b) a saturated constructor application with static args --- --- BUT watch out for --- (i) Any cross-DLL references kill static-ness completely --- because they must be 'executed' not statically allocated --- ("DLL" here really only refers to Windows DLLs, on other platforms, --- this is not necessary) --- --- (ii) We treat partial applications as redexes, because in fact we --- make a thunk for them that runs and builds a PAP --- at run-time. The only applications that are treated as --- static are *saturated* applications of constructors. - --- We used to try to be clever with nested structures like this: --- ys = (:) w ((:) w []) --- on the grounds that CorePrep will flatten ANF-ise it later. --- But supporting this special case made the function much more --- complicated, because the special case only applies if there are no --- enclosing type lambdas: --- ys = /\ a -> Foo (Baz ([] a)) --- Here the nested (Baz []) won't float out to top level in CorePrep. --- --- But in fact, even without -O, nested structures at top level are --- flattened by the simplifier, so we don't need to be super-clever here. --- --- Examples --- --- f = \x::Int. x+7 TRUE --- p = (True,False) TRUE --- --- d = (fst p, False) FALSE because there's a redex inside --- (this particular one doesn't happen but...) --- --- h = D# (1.0## /## 2.0##) FALSE (redex again) --- n = /\a. Nil a TRUE --- --- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) --- --- --- This is a bit like CoreUtils.exprIsHNF, with the following differences: --- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) --- --- b) (C x xs), where C is a constructor is updatable if the application is --- dynamic --- --- c) don't look through unfolding of f in (f x). - -rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs - where - is_static :: Bool -- True <=> in a constructor argument; must be atomic - -> CoreExpr -> Bool - - is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Tick n e) = not (tickishIsCode n) - && is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e - is_static _ (Coercion {}) = True -- Behaves just like a literal - is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of - Just e -> is_static in_arg e - Nothing -> True - is_static _ (Lit (LitLabel {})) = False - is_static _ (Lit _) = True - -- A LitLabel (foreign import "&foo") in an argument - -- prevents a constructor application from being static. The - -- reason is that it might give rise to unresolvable symbols - -- in the object file: under Linux, references to "weak" - -- symbols from the data segment give rise to "unresolvable - -- relocation" errors at link time This might be due to a bug - -- in the linker, but we'll work around it here anyway. - -- SDM 24/2/2004 - - is_static in_arg other_expr = go other_expr 0 - where - go (Var f) n_val_args - | (platformOS platform /= OSMinGW32) || - not (is_dynamic_name (idName f)) - = saturated_data_con f n_val_args - || (in_arg && n_val_args == 0) - -- A naked un-applied variable is *not* deemed a static RHS - -- E.g. f = g - -- Reason: better to update so that the indirection gets shorted - -- out, and the true value will be seen - -- NB: if you change this, you'll break the invariant that THUNK_STATICs - -- are always updatable. If you do so, make sure that non-updatable - -- ones have enough space for their static link field! - - go (App f a) n_val_args - | isTypeArg a = go f n_val_args - | not in_arg && is_static True a = go f (n_val_args + 1) - -- The (not in_arg) checks that we aren't in a constructor argument; - -- if we are, we don't allow (value) applications of any sort - -- - -- NB. In case you wonder, args are sometimes not atomic. eg. - -- x = D# (1.0## /## 2.0##) - -- can't float because /## can fail. - - go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args - go (Cast e _) n_val_args = go e n_val_args - go _ _ = False - - saturated_data_con f n_val_args - = case isDataConWorkId_maybe f of - Just dc -> n_val_args == dataConRepArity dc - Nothing -> False - {- ************************************************************************ * * diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index c0cc1cc642..59a93362bd 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -236,6 +236,7 @@ Library SrcLoc UniqSupply Unique + UpdateCafInfos Var VarEnv VarSet @@ -460,6 +461,7 @@ Library GHC.Stg.Lint GHC.Stg.Syntax GHC.Stg.FVs + GHC.Stg.DepAnal GHC.CoreToStg GHC.CoreToStg.Prep GHC.Types.RepType diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 8bff8fd6e5..fb53f4caf8 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -117,7 +117,7 @@ llvmGroupLlvmGens cmm = do -- Set function type let l' = case mapLookup (g_entry g) h of Nothing -> l - Just (Statics info_lbl _) -> info_lbl + Just (RawCmmStatics info_lbl _) -> info_lbl lml <- strCLabel_llvm l' funInsert lml =<< llvmFunTy live return Nothing @@ -131,7 +131,7 @@ llvmGroupLlvmGens cmm = do -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. -- -cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM () +cmmDataLlvmGens :: [(Section,RawCmmStatics)] -> LlvmM () cmmDataLlvmGens statics = do lmdatas <- mapM genLlvmData statics diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 41b7fcc562..0da437ef18 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -72,7 +72,7 @@ import qualified Data.List.NonEmpty as NE -- * Some Data Types -- -type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) +type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement) type LlvmBasicBlock = GenBasicBlock LlvmStatement -- | Global registers live on proc entry diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 46fb1afbcd..d44ecaea20 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -42,9 +42,9 @@ linkage lbl = if externallyVisibleCLabel lbl -- -- | Pass a CmmStatic section to an equivalent Llvm code. -genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData +genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData -- See note [emit-time elimination of static indirections] in CLabel. -genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +genLlvmData (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -67,7 +67,7 @@ genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) -genLlvmData (sec, Statics lbl xs) = do +genLlvmData (sec, RawCmmStatics lbl xs) = do label <- strCLabel_llvm lbl static <- mapM genData xs lmsec <- llvmSection sec diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 5fcc72f25a..576e84dda4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -45,8 +45,8 @@ pprLlvmCmmDecl (CmmData _ lmdata) pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) = do let lbl = case mb_info of - Nothing -> entry_lbl - Just (Statics info_lbl _) -> info_lbl + Nothing -> entry_lbl + Just (RawCmmStatics info_lbl _) -> info_lbl link = if externallyVisibleCLabel lbl then ExternallyVisible else Internal @@ -62,7 +62,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) -- generate the info table prefix <- case mb_info of Nothing -> return Nothing - Just (Statics _ statics) -> do + Just (RawCmmStatics _ statics) -> do infoStatics <- mapM genData statics let infoTy = LMStruct $ map getStatType infoStatics return $ Just $ LMStaticStruc infoStatics infoTy diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 823d3d75ff..0781b1a6d8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -69,6 +69,7 @@ import Ar import Bag ( unitBag ) import FastString ( mkFastString ) import GHC.Iface.Utils ( mkFullIface ) +import UpdateCafInfos ( updateModDetailsCafInfos ) import Exception import System.Directory @@ -228,8 +229,8 @@ compileOne' m_tc_result mHscMessage hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. - final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface - liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash mod_location + final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface Nothing + liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary) (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location @@ -1188,15 +1189,12 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do PipeState{hsc_env=hsc_env'} <- getPipeState - (outputFilename, mStub, foreign_files) <- liftIO $ + (outputFilename, mStub, foreign_files, caf_infos) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_location output_fn - final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface) - -- TODO(osa): ModIface and ModDetails need to be in sync, - -- but we only generate ModIface with the backend info. See - -- !2100 for more discussion on this. This will be fixed - -- with !1304 or !2100. - setIface final_iface mod_details + final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos)) + let final_mod_details = updateModDetailsCafInfos caf_infos mod_details + setIface final_iface final_mod_details -- See Note [Writing interface files] let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 5c5d01c546..be40ff9e2e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -427,6 +427,7 @@ data DumpFlag | Opt_D_dump_cmm_split | Opt_D_dump_cmm_info | Opt_D_dump_cmm_cps + | Opt_D_dump_srts -- end cmm subflags | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. | Opt_D_dump_asm @@ -3358,6 +3359,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_cmm_info) , make_ord_flag defGhcFlag "ddump-cmm-cps" (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-srts" + (setDumpFlag Opt_D_dump_srts) , make_ord_flag defGhcFlag "ddump-cfg-weights" (setDumpFlag Opt_D_dump_cfg_weights) , make_ord_flag defGhcFlag "ddump-core-stats" @@ -4791,20 +4794,6 @@ optLevelFlags -- see Note [Documenting optimisation flags] -- Static Argument Transformation needs investigation. See #9374 ] -{- Note [Eta-reduction in -O0] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#11562 showed an example which tripped an ASSERT in CoreToStg; a -function was marked as MayHaveCafRefs when in fact it obviously -didn't. Reason was: - * Eta reduction wasn't happening in the simplifier, but it was - happening in CorePrep, on - $fBla = MkDict (/\a. K a) - * Result: rhsIsStatic told GHC.Iface.Tidy that $fBla might have CAF refs - but the eta-reduced version (MkDict K) obviously doesn't -Simple solution: just let the simplifier do eta-reduction even in -O0. -After all, CorePrep does it unconditionally! Not a big deal, but -removes an assertion failure. -} - -- ----------------------------------------------------------------------------- -- Standard sets of warning options diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index 8caebfc556..064f96c33e 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -3,7 +3,8 @@ -- NB: this module is SOURCE-imported by DynFlags, and should primarily -- refer to *types*, rather than *code* -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, RankNTypes #-} + module Hooks ( Hooks , emptyHooks , lookupHook @@ -107,8 +108,8 @@ data Hooks = Hooks , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) , stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ()) - , cmmToRawCmmHook :: Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroup () - -> IO (Stream IO RawCmmGroup ())) + , cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a + -> IO (Stream IO RawCmmGroup a)) } getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 1c27542270..391b989915 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -133,6 +133,7 @@ import CostCentre import ProfInit import TyCon import Name +import NameSet import GHC.Cmm import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build @@ -173,6 +174,7 @@ import System.IO (fixIO) import qualified Data.Map as M import qualified Data.Set as S import Data.Set (Set) +import Data.Functor import Control.DeepSeq (force) import GHC.Iface.Ext.Ast ( mkHieFile ) @@ -1405,7 +1407,7 @@ hscWriteIface dflags iface no_change mod_location = do -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)]) + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. @@ -1464,11 +1466,11 @@ hscGenHardCode hsc_env cgguts location output_filename = do return a rawcmms1 = Stream.mapM dump rawcmms0 - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ()) + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos) <- {-# SCC "codeOutput" #-} codeOutput dflags this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1 - return (output_filename, stub_c_exists, foreign_fps) + return (output_filename, stub_c_exists, foreign_fps, caf_infos) hscInteractive :: HscEnv @@ -1514,7 +1516,16 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename cmm_mod = mkModule (thisPackage dflags) mod_name - (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm + + -- Compile decls in Cmm files one decl at a time, to avoid re-ordering + -- them in SRT analysis. + -- + -- Re-ordering here causes breakage when booting with C backend because + -- in C we must declare before use, but SRT algorithm is free to + -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A] + cmmgroup <- + concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm + unless (null cmmgroup) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr cmmgroup) @@ -1535,7 +1546,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [StgTopBinding] -> HpcInfo - -> IO (Stream IO CmmGroup ()) + -> IO (Stream IO CmmGroupSRTs NameSet) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. @@ -1565,18 +1576,15 @@ doCodeGen hsc_env this_mod data_tycons pipeline_stream = {-# SCC "cmmPipeline" #-} - let run_pipeline = cmmPipeline hsc_env - in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 + Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 + <&> (srtMapNonCAFs . moduleSRTMap) dump2 a = do unless (null a) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a) return a - ppr_stream2 = Stream.mapM dump2 pipeline_stream - - return ppr_stream2 - + return (Stream.mapM dump2 pipeline_stream) myCoreToStg :: DynFlags -> Module -> CoreProgram diff --git a/compiler/main/UpdateCafInfos.hs b/compiler/main/UpdateCafInfos.hs new file mode 100644 index 0000000000..c5e81150fe --- /dev/null +++ b/compiler/main/UpdateCafInfos.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-} + +module UpdateCafInfos + ( updateModDetailsCafInfos + ) where + +import GhcPrelude + +import CoreSyn +import HscTypes +import Id +import IdInfo +import InstEnv +import NameEnv +import NameSet +import Util +import Var +import Outputable + +#include "HsVersions.h" + +-- | Update CafInfos of all occurences (in rules, unfoldings, class instances) +updateModDetailsCafInfos + :: NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY. + -> ModDetails -- ^ ModDetails to update + -> ModDetails +updateModDetailsCafInfos non_cafs mod_details = + {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -} + let + ModDetails{ md_types = type_env -- for unfoldings + , md_insts = insts + , md_rules = rules + } = mod_details + + -- type TypeEnv = NameEnv TyThing + ~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env + -- Not strict! + + !insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts + !rules' = strictMap (updateRuleCafInfos type_env') rules + in + mod_details{ md_types = type_env' + , md_insts = insts' + , md_rules = rules' + } + +-------------------------------------------------------------------------------- +-- Rules +-------------------------------------------------------------------------------- + +updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule +updateRuleCafInfos _ rule@BuiltinRule{} = rule +updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. } + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst +updateInstCafInfos type_env non_cafs = + updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs) + +-------------------------------------------------------------------------------- +-- TyThings +-------------------------------------------------------------------------------- + +updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing + +updateTyThingCafInfos type_env non_cafs (AnId id) = + AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id)) + +updateTyThingCafInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom + +-------------------------------------------------------------------------------- +-- Unfoldings +-------------------------------------------------------------------------------- + +updateIdUnfolding :: TypeEnv -> Id -> Id +updateIdUnfolding type_env id = + case idUnfolding id of + CoreUnfolding{ .. } -> + setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. } + DFunUnfolding{ .. } -> + setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. } + _ -> id + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- + +updateIdCafInfo :: NameSet -> Id -> Id +updateIdCafInfo non_cafs id + | idName id `elemNameSet` non_cafs + = -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $ + id `setIdCafInfo` NoCafRefs + | otherwise + = id + +-------------------------------------------------------------------------------- + +updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr +-- Update occurrences of GlobalIds as directed by 'env' +-- The 'env' maps a GlobalId to a version with accurate CAF info +-- (and in due course perhaps other back-end-related info) +updateGlobalIds env e = go env e + where + go_id :: NameEnv TyThing -> Id -> Id + go_id env var = + case lookupNameEnv env (varName var) of + Nothing -> var + Just (AnId id) -> id + Just other -> pprPanic "UpdateCafInfos.updateGlobalIds" $ + text "Found a non-Id for Id Name" <+> ppr (varName var) $$ + nest 4 (text "Id:" <+> ppr var $$ + text "TyThing:" <+> ppr other) + + go :: NameEnv TyThing -> CoreExpr -> CoreExpr + go env (Var v) = Var (go_id env v) + go _ e@Lit{} = e + go env (App e1 e2) = App (go env e1) (go env e2) + go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e)) + go env (Let bs e) = Let (go_binds env bs) (go env e) + go env (Case e b ty alts) = + assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts)) + where + go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e) + go env (Cast e c) = Cast (go env e) c + go env (Tick t e) = Tick t (go env e) + go _ e@Type{} = e + go _ e@Coercion{} = e + + go_binds :: NameEnv TyThing -> CoreBind -> CoreBind + go_binds env (NonRec b e) = + assertNotInNameEnv env [b] (NonRec b (go env e)) + go_binds env (Rec prs) = + assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs)) + +-- In `updateGlobaLIds` Names of local binders should not shadow Name of +-- globals. This assertion is to check that. +assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b +assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index 4a38909e65..88f666c375 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -182,12 +182,12 @@ nativeCodeGen dflags this_mod modLoc h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" -x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) +x86NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics) X86.Instr.Instr X86.Instr.JumpDest x86NcgImpl dflags = (x86_64NcgImpl dflags) -x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) +x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics) X86.Instr.Instr X86.Instr.JumpDest x86_64NcgImpl dflags = NcgImpl { @@ -208,7 +208,7 @@ x86_64NcgImpl dflags } where platform = targetPlatform dflags -ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest +ppcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest ppcNcgImpl dflags = NcgImpl { cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen @@ -228,7 +228,7 @@ ppcNcgImpl dflags } where platform = targetPlatform dflags -sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest +sparcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest sparcNcgImpl dflags = NcgImpl { cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen @@ -748,7 +748,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count {-# SCC "invertCondBranches" #-} map invert sequenced where - invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr] + invertConds :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr] invertConds = invertCondBranches ncgImpl optimizedCFG invert top@CmmData {} = top diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 150bd8adba..ad4937bf08 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -46,14 +46,14 @@ noUsage = RU [] [] -- Type synonyms for Cmm populated with native code type NatCmm instr = GenCmmGroup - CmmStatics - (LabelMap CmmStatics) + RawCmmStatics + (LabelMap RawCmmStatics) (ListGraph instr) type NatCmmDecl statics instr = GenCmmDecl statics - (LabelMap CmmStatics) + (LabelMap RawCmmStatics) (ListGraph instr) diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index b963623535..849b3fe761 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -65,7 +65,7 @@ import Control.Monad ( ap ) import Instruction import Outputable (SDoc, pprPanic, ppr) -import GHC.Cmm (RawCmmDecl, CmmStatics) +import GHC.Cmm (RawCmmDecl, RawCmmStatics) import CFG data NcgImpl statics instr jumpDest = NcgImpl { @@ -83,13 +83,13 @@ data NcgImpl statics instr jumpDest = NcgImpl { -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]), -- ^ The list of block ids records the redirected jumps to allow us to update -- the CFG. - ncgMakeFarBranches :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr], + ncgMakeFarBranches :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr], extractUnwindPoints :: [instr] -> [UnwindPoint], -- ^ given the instruction sequence of a block, produce a list of -- the block's 'UnwindPoint's -- See Note [What is this unwinding business?] in Debug -- and Note [Unwinding information in the NCG] in this module. - invertCondBranches :: Maybe CFG -> LabelMap CmmStatics -> [NatBasicBlock instr] + invertCondBranches :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr] -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>` -- when possible. diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index e4aba00596..6e0708ab04 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -730,8 +730,8 @@ pprImportedSymbol _ _ _ initializePicBase_ppc :: Arch -> OS -> Reg - -> [NatCmmDecl CmmStatics PPC.Instr] - -> NatM [NatCmmDecl CmmStatics PPC.Instr] + -> [NatCmmDecl RawCmmStatics PPC.Instr] + -> NatM [NatCmmDecl RawCmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg (CmmProc info lab live (ListGraph blocks) : statics) @@ -805,8 +805,8 @@ initializePicBase_ppc _ _ _ _ initializePicBase_x86 :: Arch -> OS -> Reg - -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr] - -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] + -> [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] + -> NatM [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg (CmmProc info lab live (ListGraph blocks) : statics) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 4d9a38b9de..4374cbeb8d 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -74,7 +74,7 @@ import Util cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl CmmStatics Instr] + -> NatM [NatCmmDecl RawCmmStatics Instr] cmmTopCodeGen (CmmProc info lab live graph) = do let blocks = toBlockListEntryFirst graph @@ -115,7 +115,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: Block CmmNode C C -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl CmmStatics Instr]) + , [NatCmmDecl RawCmmStatics Instr]) basicBlockCodeGen block = do let (_, nodes, tail) = blockSplit block @@ -669,7 +669,7 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do let format = floatFormat frep code dst = LDATA (Section ReadOnlyData lbl) - (Statics lbl [CmmStaticLit (CmmFloat f frep)]) + (RawCmmStatics lbl [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD format dst addr) return (Any format code) @@ -690,7 +690,7 @@ getRegister' dflags (CmmLit lit) let rep = cmmLitType dflags lit format = cmmTypeFormat rep code dst = - LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit]) + LDATA (Section ReadOnlyData lbl) (RawCmmStatics lbl [CmmStaticLit lit]) `consOL` (addr_code `snocOL` LD format dst addr) return (Any format code) @@ -2095,7 +2095,7 @@ genSwitch dflags expr targets where (offset, ids) = switchTargetsToTable targets generateJumpTableForInstr :: DynFlags -> Instr - -> Maybe (NatCmmDecl CmmStatics Instr) + -> Maybe (NatCmmDecl RawCmmStatics Instr) generateJumpTableForInstr dflags (BCTR ids (Just lbl) _) = let jumpTable | (positionIndependent dflags) @@ -2108,7 +2108,7 @@ generateJumpTableForInstr dflags (BCTR ids (Just lbl) _) = = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 (wordWidth dflags)) where blockLabel = blockLbl blockid - in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable)) + in Just (CmmData (Section ReadOnlyData lbl) (RawCmmStatics lbl jumpTable)) generateJumpTableForInstr _ _ = Nothing -- ----------------------------------------------------------------------------- @@ -2337,7 +2337,7 @@ coerceInt2FP' ArchPPC fromRep toRep x = do Amode addr addr_code <- getAmode D dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA (Section ReadOnlyData lbl) $ Statics lbl + LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl [CmmStaticLit (CmmInt 0x43300000 W32), CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index f149c92c9d..2dff3349fb 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -190,7 +190,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section CmmStatics + | LDATA Section RawCmmStatics -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -682,7 +682,7 @@ ppc_takeRegRegMoveInstr _ = Nothing -- big, we have to work around this limitation. makeFarBranches - :: LabelMap CmmStatics + :: LabelMap RawCmmStatics -> [NatBasicBlock Instr] -> [NatBasicBlock Instr] makeFarBranches info_env blocks diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 9669076bef..5ede19bd5e 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -42,7 +42,7 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc +pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionAlign section $$ pprDatas dats @@ -59,7 +59,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = -- so label needed vcat (map (pprBasicBlock top_info) blocks) - Just (Statics info_lbl _) -> + Just (RawCmmStatics info_lbl _) -> sdocWithPlatform $ \platform -> pprSectionAlign (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform @@ -104,7 +104,7 @@ pprFunctionPrologue lab = pprGloblDecl lab $$ text "\t.localentry\t" <> ppr lab <> text ",.-" <> ppr lab -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc pprBasicBlock info_env (BasicBlock blockid instrs) = maybe_infotable $$ pprLabel (blockLbl blockid) $$ @@ -112,16 +112,16 @@ pprBasicBlock info_env (BasicBlock blockid instrs) where maybe_infotable = case mapLookup blockid info_env of Nothing -> empty - Just (Statics info_lbl info) -> + Just (RawCmmStatics info_lbl info) -> pprAlignForSection Text $$ vcat (map pprData info) $$ pprLabel info_lbl -pprDatas :: CmmStatics -> SDoc +pprDatas :: RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -130,7 +130,7 @@ pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) , alias `mayRedirectTo` ind' = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) +pprDatas (RawCmmStatics lbl dats) = vcat (pprLabel lbl : map pprData dats) pprData :: CmmStatic -> SDoc pprData (CmmString str) = pprBytes str diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index e99a69313e..c1a4e73e3d 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -47,9 +47,9 @@ shortcutJump _ other = other -- Here because it knows about JumpDest -shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics -shortcutStatics fn (Statics lbl statics) - = Statics lbl $ map (shortcutStatic fn) statics +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics fn (RawCmmStatics lbl statics) + = RawCmmStatics lbl $ map (shortcutStatic fn) statics -- we need to get the jump tables, so apply the mapping to the entries -- of a CmmData too. diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 44a7b359a8..cf17d149e9 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -176,7 +176,7 @@ data Liveness -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo = LiveInfo - (LabelMap CmmStatics) -- cmm info table static stuff + (LabelMap RawCmmStatics) -- cmm info table static stuff [BlockId] -- entry points (first one is the -- entry point for the proc). (BlockMap RegSet) -- argument locals live on entry to this block diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index d8cda40d1a..60cfd91de9 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -62,7 +62,7 @@ import Control.Monad ( mapAndUnzipM ) -- | Top level code generation cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl CmmStatics Instr] + -> NatM [NatCmmDecl RawCmmStatics Instr] cmmTopCodeGen (CmmProc info lab live graph) = do let blocks = toBlockListEntryFirst graph @@ -84,7 +84,7 @@ cmmTopCodeGen (CmmData sec dat) = do -- LDATAs here too. basicBlockCodeGen :: CmmBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl CmmStatics Instr]) + , [NatCmmDecl RawCmmStatics Instr]) basicBlockCodeGen block = do let (_, nodes, tail) = blockSplit block @@ -339,10 +339,10 @@ genSwitch dflags expr targets where (offset, ids) = switchTargetsToTable targets generateJumpTableForInstr :: DynFlags -> Instr - -> Maybe (NatCmmDecl CmmStatics Instr) + -> Maybe (NatCmmDecl RawCmmStatics Instr) generateJumpTableForInstr dflags (JMP_TBL _ ids label) = let jumpTable = map (jumpTableEntry dflags) ids - in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable)) + in Just (CmmData (Section ReadOnlyData label) (RawCmmStatics label jumpTable)) generateJumpTableForInstr _ _ = Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index a384e498d2..b6d78a9f79 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -23,7 +23,7 @@ import Outputable import OrdList -- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr +expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr expandTop top@(CmmData{}) = top diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index a4f6214edc..01f133ed8f 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -88,7 +88,7 @@ getRegister (CmmLit (CmmFloat f W32)) = do let code dst = toOL [ -- the data area - LDATA (Section ReadOnlyData lbl) $ Statics lbl + LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl [CmmStaticLit (CmmFloat f W32)], -- load the literal @@ -101,7 +101,7 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA (Section ReadOnlyData lbl) $ Statics lbl + LDATA (Section ReadOnlyData lbl) $ RawCmmStatics lbl [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 43edfc61f4..7b4935802b 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -117,7 +117,7 @@ data Instr -- some static data spat out during code generation. -- Will be extracted before pretty-printing. - | LDATA Section CmmStatics + | LDATA Section RawCmmStatics -- 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 7e40f0d60b..566f438403 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -52,7 +52,7 @@ import FastString -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc +pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionAlign section $$ pprDatas dats @@ -64,7 +64,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = pprLabel lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock top_info) blocks) - Just (Statics info_lbl _) -> + Just (RawCmmStatics info_lbl _) -> sdocWithPlatform $ \platform -> (if platformHasSubsectionsViaSymbols platform then pprSectionAlign dspSection $$ @@ -86,7 +86,7 @@ dspSection :: Section dspSection = Section Text $ panic "subsections-via-symbols doesn't combine with split-sections" -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc pprBasicBlock info_env (BasicBlock blockid instrs) = maybe_infotable $$ pprLabel (blockLbl blockid) $$ @@ -94,15 +94,15 @@ pprBasicBlock info_env (BasicBlock blockid instrs) where maybe_infotable = case mapLookup blockid info_env of Nothing -> empty - Just (Statics info_lbl info) -> + Just (RawCmmStatics info_lbl info) -> pprAlignForSection Text $$ vcat (map pprData info) $$ pprLabel info_lbl -pprDatas :: CmmStatics -> SDoc +pprDatas :: RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -111,7 +111,7 @@ pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) , alias `mayRedirectTo` ind' = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) +pprDatas (RawCmmStatics lbl dats) = vcat (pprLabel lbl : map pprData dats) pprData :: CmmStatic -> SDoc pprData (CmmString str) = pprBytes str diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 02d51de30f..35604b0b7e 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -43,9 +43,9 @@ shortcutJump _ other = other -shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics -shortcutStatics fn (Statics lbl statics) - = Statics lbl $ map (shortcutStatic fn) statics +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics fn (RawCmmStatics lbl statics) + = RawCmmStatics lbl $ map (shortcutStatic fn) statics -- we need to get the jump tables, so apply the mapping to the entries -- of a CmmData too. diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 8811385965..d60231f7b2 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -122,7 +122,7 @@ sse4_2Enabled = do cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] + -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr] cmmTopCodeGen (CmmProc info lab live graph) = do let blocks = toBlockListEntryFirst graph @@ -194,7 +194,7 @@ verifyBasicBlock instrs basicBlockCodeGen :: CmmBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl (Alignment, CmmStatics) Instr]) + , [NatCmmDecl (Alignment, RawCmmStatics) Instr]) basicBlockCodeGen block = do let (_, nodes, tail) = blockSplit block @@ -1482,7 +1482,7 @@ memConstant align lit = do return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA rosection (align, Statics lbl [CmmStaticLit lit]) + LDATA rosection (align, RawCmmStatics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -3305,7 +3305,7 @@ genSwitch dflags expr targets (offset, blockIds) = switchTargetsToTable targets ids = map (fmap DestBlockId) blockIds -generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr) +generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr) generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl) = let getBlockId (DestBlockId id) = id getBlockId _ = panic "Non-Label target in Jump Table" @@ -3314,7 +3314,7 @@ generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl) generateJumpTableForInstr _ _ = Nothing createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel - -> GenCmmDecl (Alignment, CmmStatics) h g + -> GenCmmDecl (Alignment, RawCmmStatics) h g createJumpTable dflags ids section lbl = let jumpTable | positionIndependent dflags = @@ -3326,7 +3326,7 @@ createJumpTable dflags ids section lbl where blockLabel = blockLbl blockid in map jumpTableEntryRel ids | otherwise = map (jumpTableEntry dflags) ids - in CmmData section (mkAlignment 1, Statics lbl jumpTable) + in CmmData section (mkAlignment 1, RawCmmStatics lbl jumpTable) extractUnwindPoints :: [Instr] -> [UnwindPoint] extractUnwindPoints instrs = diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 4591464671..422bb96de4 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -174,7 +174,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section (Alignment, CmmStatics) + | LDATA Section (Alignment, RawCmmStatics) -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -1017,9 +1017,9 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) 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) +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics) +shortcutStatics fn (align, RawCmmStatics lbl statics) + = (align, RawCmmStatics lbl $ map (shortcutStatic fn) statics) -- we need to get the jump tables, so apply the mapping to the entries -- of a CmmData too. diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index d857a952ce..8b73cdffc1 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -73,7 +73,7 @@ pprProcAlignment :: SDoc pprProcAlignment = sdocWithDynFlags $ \dflags -> (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags)) -pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc +pprNatCmmDecl :: NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionAlign section $$ pprDatas dats @@ -91,7 +91,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl lbl - Just (Statics info_lbl _) -> + Just (RawCmmStatics info_lbl _) -> sdocWithPlatform $ \platform -> pprSectionAlign (Section Text info_lbl) $$ pprProcAlignment $$ @@ -118,7 +118,7 @@ pprSizeDecl lbl then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl else empty -pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc pprBasicBlock info_env (BasicBlock blockid instrs) = sdocWithDynFlags $ \dflags -> maybe_infotable dflags $ @@ -130,7 +130,7 @@ pprBasicBlock info_env (BasicBlock blockid instrs) asmLbl = blockLbl blockid maybe_infotable dflags c = case mapLookup blockid info_env of Nothing -> c - Just (Statics infoLbl info) -> + Just (RawCmmStatics infoLbl info) -> pprAlignForSection Text $$ infoTableLoc $$ vcat (map pprData info) $$ @@ -145,9 +145,9 @@ pprBasicBlock info_env (BasicBlock blockid instrs) _other -> empty -pprDatas :: (Alignment, CmmStatics) -> SDoc +pprDatas :: (Alignment, RawCmmStatics) -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -157,7 +157,7 @@ pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _] = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (align, (Statics lbl dats)) +pprDatas (align, (RawCmmStatics lbl dats)) = vcat (pprAlign align : pprLabel lbl : map pprData dats) pprData :: CmmStatic -> SDoc diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index a8eb5ea471..41997178b4 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -80,7 +80,7 @@ module Util ( transitiveClosure, -- * Strictness - seqList, + seqList, strictMap, -- * Module names looksLikeModuleName, @@ -1008,6 +1008,14 @@ seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x `seq` seqList xs b +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x : xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' {- ************************************************************************ diff --git a/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-32 b/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-32 index b1f34757ee..884e8abcca 100644 --- a/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-32 +++ b/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-32 @@ -1,8 +1,3 @@ -[T14373d.lateDefault_entry() { // - switch [0 .. 15] - case 15 : goto - default: {goto - R1 = XYZ_closure+2; [T14373d.earlyDefault_entry() { // switch [1 .. 3] case 2 : goto @@ -17,3 +12,8 @@ case 15 : goto default: {goto R1 = XYZ_closure+2; +[T14373d.lateDefault_entry() { // + switch [0 .. 15] + case 15 : goto + default: {goto + R1 = XYZ_closure+2; diff --git a/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-64 b/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-64 index 15a63c9b9c..6258d38e4a 100644 --- a/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-64 +++ b/testsuite/tests/codeGen/should_compile/T14373d.stderr-ws-64 @@ -1,8 +1,3 @@ -[T14373d.lateDefault_entry() { // - switch [0 .. 15] - case 15 : goto - default: {goto - R1 = XYZ_closure+2; [T14373d.earlyDefault_entry() { // switch [1 .. 7] case 2 : goto @@ -17,3 +12,8 @@ case 15 : goto default: {goto R1 = XYZ_closure+2; +[T14373d.lateDefault_entry() { // + switch [0 .. 15] + case 15 : goto + default: {goto + R1 = XYZ_closure+2; diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 6073e67108..1846656635 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -17,47 +17,47 @@ T2431.$WRefl -- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0} absurd :: forall a. (Int :~: Bool) -> a -[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>b, Unf=OtherCon []] +[GblId, Arity=1, Str=<L,U>b, Unf=OtherCon []] absurd = \ (@a) (x :: Int :~: Bool) -> case x of { } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule2 = GHC.Types.TrNameS $trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule3 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule3 = "T2431"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule4 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule4 = GHC.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T2431.$trModule :: GHC.Types.Module -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] T2431.$trModule = GHC.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $krep :: GHC.Types.KindRep -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $krep = GHC.Types.KindRepVar 0# -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tc:~:1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc:~:1 = ":~:"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tc:~:2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc:~:2 = GHC.Types.TrNameS $tc:~:1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} @@ -74,14 +74,14 @@ T2431.$tc:~: -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} $krep1 :: [GHC.Types.KindRep] -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $krep1 = GHC.Types.: @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep) -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} $krep2 :: [GHC.Types.KindRep] -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $krep2 = GHC.Types.: @GHC.Types.KindRep $krep $krep1 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} @@ -91,12 +91,12 @@ $krep3 = GHC.Types.KindRepTyConApp T2431.$tc:~: $krep2 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tc'Refl1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc'Refl1 = "'Refl"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tc'Refl2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc'Refl2 = GHC.Types.TrNameS $tc'Refl1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/numeric/should_compile/T14170.stdout b/testsuite/tests/numeric/should_compile/T14170.stdout index 46a86214a5..1371831160 100644 --- a/testsuite/tests/numeric/should_compile/T14170.stdout +++ b/testsuite/tests/numeric/should_compile/T14170.stdout @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] NatVal.$trModule4 = "main"# @@ -14,7 +13,6 @@ NatVal.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -23,7 +21,6 @@ NatVal.$trModule3 = GHC.Types.TrNameS NatVal.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] NatVal.$trModule2 = "NatVal"# @@ -31,7 +28,6 @@ NatVal.$trModule2 = "NatVal"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -40,7 +36,6 @@ NatVal.$trModule1 = GHC.Types.TrNameS NatVal.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -50,7 +45,6 @@ NatVal.$trModule -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} foo :: Integer [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] foo = 0 diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout index 88ac5f70e0..f31f5a34f2 100644 --- a/testsuite/tests/numeric/should_compile/T14465.stdout +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} ten :: Natural [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] ten = 10 @@ -14,7 +13,6 @@ ten = 10 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} M.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] M.$trModule4 = "main"# @@ -22,7 +20,6 @@ M.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} M.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -31,7 +28,6 @@ M.$trModule3 = GHC.Types.TrNameS M.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} M.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] M.$trModule2 = "M"# @@ -39,7 +35,6 @@ M.$trModule2 = "M"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} M.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -48,7 +43,6 @@ M.$trModule1 = GHC.Types.TrNameS M.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} M.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -57,7 +51,6 @@ M.$trModule = GHC.Types.Module M.$trModule3 M.$trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} M.minusOne1 :: Natural [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] M.minusOne1 = 1 @@ -80,7 +73,6 @@ minusOne -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} twoTimesTwo :: Natural [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] twoTimesTwo = 4 @@ -89,7 +81,6 @@ twoTimesTwo = 4 plusOne :: Natural -> Natural [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,U>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 171d9bc7f4..6cf1040327 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7116.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T7116.$trModule4 = "main"# @@ -14,7 +13,6 @@ T7116.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7116.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -23,7 +21,6 @@ T7116.$trModule3 = GHC.Types.TrNameS T7116.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7116.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T7116.$trModule2 = "T7116"# @@ -31,7 +28,6 @@ T7116.$trModule2 = "T7116"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7116.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -40,7 +36,6 @@ T7116.$trModule1 = GHC.Types.TrNameS T7116.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T7116.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -51,7 +46,6 @@ T7116.$trModule dr :: Double -> Double [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -68,7 +62,6 @@ dr dl :: Double -> Double [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -81,7 +74,6 @@ dl = dr fr :: Float -> Float [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -100,7 +92,6 @@ fr fl :: Float -> Float [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T index a7dc06cf44..a0ae051e81 100644 --- a/testsuite/tests/numeric/should_compile/all.T +++ b/testsuite/tests/numeric/should_compile/all.T @@ -1,6 +1,6 @@ test('T7116', normal, makefile_test, ['T7116']) # These test Core output that depends upon integer-gmp -test('T14170', reqlib("integer-gmp"), makefile_test, ['T14170']) +test('T14170', normal, makefile_test, ['T14170']) test('T14465', reqlib("integer-gmp"), makefile_test, ['T14465']) test('T7895', normal, compile, ['']) test('T7881', normal, compile, ['']) diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index cbd0361d15..cf632f1cd5 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -98,9 +98,9 @@ compileCmmForRegAllocStats :: DynFlags -> FilePath -> (DynFlags -> - NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest) -> + NcgImpl (Alignment, RawCmmStatics) X86.Instr.Instr X86.Instr.JumpDest) -> UniqSupply -> - IO [( Maybe [Color.RegAllocStats (Alignment, CmmStatics) X86.Instr.Instr] + IO [( Maybe [Color.RegAllocStats (Alignment, RawCmmStatics) X86.Instr.Instr] , Maybe [Linear.RegAllocStats])] compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do let ncgImpl = ncgImplF dflags diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index e6017f9e7b..5004d1aacc 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -5,12 +5,12 @@ Result size of Tidy Core -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} convert1 :: Wrap Age -> Wrap Age -[GblId, Arity=1, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Arity=1, Unf=OtherCon []] convert1 = \ (ds :: Wrap Age) -> ds -- RHS size: {terms: 1, types: 0, coercions: 5, joins: 0/0} convert :: Wrap Age -> Int -[GblId, Arity=1, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Arity=1, Unf=OtherCon []] convert = convert1 `cast` (<Wrap Age>_R ->_R Roles13.N:Wrap[0] (Roles13.N:Age[0]) @@ -18,27 +18,27 @@ convert -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule2 = GHC.Types.TrNameS $trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule3 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule3 = "Roles13"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule4 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule4 = GHC.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Roles13.$trModule :: GHC.Types.Module -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] Roles13.$trModule = GHC.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} @@ -50,17 +50,17 @@ $krep -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $krep1 :: GHC.Types.KindRep -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $krep1 = GHC.Types.KindRepVar 0# -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tcAge1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tcAge1 = "Age"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tcAge2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tcAge2 = GHC.Types.TrNameS $tcAge1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} @@ -89,12 +89,12 @@ $krep3 = GHC.Types.KindRepFun $krep $krep2 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tc'MkAge1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc'MkAge1 = "'MkAge"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tc'MkAge2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc'MkAge2 = GHC.Types.TrNameS $tc'MkAge1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} @@ -111,12 +111,12 @@ Roles13.$tc'MkAge -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tcWrap1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tcWrap1 = "Wrap"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tcWrap2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tcWrap2 = GHC.Types.TrNameS $tcWrap1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} @@ -133,7 +133,7 @@ Roles13.$tcWrap -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} $krep4 :: [GHC.Types.KindRep] -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $krep4 = GHC.Types.: @GHC.Types.KindRep $krep1 (GHC.Types.[] @GHC.Types.KindRep) @@ -150,12 +150,12 @@ $krep6 = GHC.Types.KindRepFun $krep1 $krep5 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tc'MkWrap1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc'MkWrap1 = "'MkWrap"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tc'MkWrap2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $tc'MkWrap2 = GHC.Types.TrNameS $tc'MkWrap1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr index eb9622b16b..59f38d27bc 100644 --- a/testsuite/tests/simplCore/should_compile/T13143.stderr +++ b/testsuite/tests/simplCore/should_compile/T13143.stderr @@ -7,7 +7,7 @@ Rec { -- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0} T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker] :: forall a. GHC.Prim.Void# -> a -[GblId, Arity=1, Caf=NoCafRefs, Str=<B,A>b, Unf=OtherCon []] +[GblId, Arity=1, Str=<B,A>b, Unf=OtherCon []] T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.void# end Rec } @@ -15,7 +15,6 @@ end Rec } f [InlPrag=NOUSERINLINE[0]] :: forall a. Int -> a [GblId, Arity=1, - Caf=NoCafRefs, Str=<B,A>b, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -26,7 +25,6 @@ f = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.void# -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T13143.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T13143.$trModule4 = "main"# @@ -34,7 +32,6 @@ T13143.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T13143.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -43,7 +40,6 @@ T13143.$trModule3 = GHC.Types.TrNameS T13143.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T13143.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T13143.$trModule2 = "T13143"# @@ -51,7 +47,6 @@ T13143.$trModule2 = "T13143"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T13143.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -60,7 +55,6 @@ T13143.$trModule1 = GHC.Types.TrNameS T13143.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T13143.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index 45fdf89bb4..ca2158787c 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T3717.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T3717.$trModule4 = "main"# @@ -14,7 +13,6 @@ T3717.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3717.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -23,7 +21,6 @@ T3717.$trModule3 = GHC.Types.TrNameS T3717.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T3717.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T3717.$trModule2 = "T3717"# @@ -31,7 +28,6 @@ T3717.$trModule2 = "T3717"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3717.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -40,7 +36,6 @@ T3717.$trModule1 = GHC.Types.TrNameS T3717.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T3717.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -51,7 +46,7 @@ Rec { -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} T3717.$wfoo [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<S,1*U>, Unf=OtherCon []] T3717.$wfoo = \ (ww :: GHC.Prim.Int#) -> case ww of ds { @@ -64,7 +59,6 @@ end Rec } foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int [GblId, Arity=1, - Caf=NoCafRefs, Str=<S(S),1*U(1*U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index b19e5d047e..7ccb3f4852 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T3772.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T3772.$trModule4 = "main"# @@ -14,7 +13,6 @@ T3772.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3772.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -23,7 +21,6 @@ T3772.$trModule3 = GHC.Types.TrNameS T3772.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T3772.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T3772.$trModule2 = "T3772"# @@ -31,7 +28,6 @@ T3772.$trModule2 = "T3772"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3772.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -40,7 +36,6 @@ T3772.$trModule1 = GHC.Types.TrNameS T3772.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T3772.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -50,7 +45,7 @@ T3772.$trModule Rec { -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} $wxs :: GHC.Prim.Int# -> () -[GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<S,1*U>, Unf=OtherCon []] $wxs = \ (ww :: GHC.Prim.Int#) -> case ww of ds1 { @@ -61,7 +56,7 @@ end Rec } -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> () -[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<L,U>, Unf=OtherCon []] T3772.$wfoo = \ (ww :: GHC.Prim.Int#) -> case GHC.Prim.<# 0# ww of { @@ -73,7 +68,6 @@ T3772.$wfoo foo [InlPrag=NOUSERINLINE[0]] :: Int -> () [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,1*U(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index 560cd7b762..9eb50c4360 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/testsuite/tests/simplCore/should_compile/T4201.stdout @@ -1,3 +1,3 @@ - {- Arity: 1, HasNoCafRefs, Strictness: <S,1*H>, + {- HasNoCafRefs, Arity: 1, Strictness: <S,1*H>, Unfolding: InlineRule (0, True, True) bof `cast` (Sym (N:Foo[0]) ->_R <T>_R) -} diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 62f300e962..38777e526e 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T4908.$trModule4 :: Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T4908.$trModule4 = "main"# @@ -14,7 +13,6 @@ T4908.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4908.$trModule3 :: TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -23,7 +21,6 @@ T4908.$trModule3 = GHC.Types.TrNameS T4908.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T4908.$trModule2 :: Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T4908.$trModule2 = "T4908"# @@ -31,7 +28,6 @@ T4908.$trModule2 = "T4908"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4908.$trModule1 :: TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -40,7 +36,6 @@ T4908.$trModule1 = GHC.Types.TrNameS T4908.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T4908.$trModule :: Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -50,11 +45,7 @@ T4908.$trModule Rec { -- RHS size: {terms: 19, types: 5, coercions: 0, joins: 0/0} T4908.f_$s$wf [Occ=LoopBreaker] :: Int -> Int# -> Int# -> Bool -[GblId, - Arity=3, - Caf=NoCafRefs, - Str=<L,A><L,1*U><S,1*U>, - Unf=OtherCon []] +[GblId, Arity=3, Str=<L,A><L,1*U><S,1*U>, Unf=OtherCon []] T4908.f_$s$wf = \ (sc :: Int) (sc1 :: Int#) (sc2 :: Int#) -> case sc2 of ds { @@ -71,7 +62,6 @@ end Rec } T4908.$wf [InlPrag=NOUSERINLINE[2]] :: Int# -> (Int, Int) -> Bool [GblId, Arity=2, - Caf=NoCafRefs, Str=<S,1*U><L,1*U(A,1*U(1*U))>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}] @@ -94,7 +84,6 @@ T4908.$wf f [InlPrag=NOUSERINLINE[2]] :: Int -> (Int, Int) -> Bool [GblId, Arity=2, - Caf=NoCafRefs, Str=<S(S),1*U(1*U)><L,1*U(A,1*U(1*U))>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 07c2cee01b..534a43561d 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T4930.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T4930.$trModule4 = "main"# @@ -14,7 +13,6 @@ T4930.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4930.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -23,7 +21,6 @@ T4930.$trModule3 = GHC.Types.TrNameS T4930.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T4930.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T4930.$trModule2 = "T4930"# @@ -31,7 +28,6 @@ T4930.$trModule2 = "T4930"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4930.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -40,7 +36,6 @@ T4930.$trModule1 = GHC.Types.TrNameS T4930.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T4930.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -51,7 +46,7 @@ Rec { -- RHS size: {terms: 17, types: 3, coercions: 0, joins: 0/0} T4930.$wfoo [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<L,U>, Unf=OtherCon []] T4930.$wfoo = \ (ww :: GHC.Prim.Int#) -> case GHC.Prim.<# ww 5# of { @@ -64,7 +59,6 @@ end Rec } foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index c68b9d6bf3..687377bef0 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -20,7 +20,7 @@ T7360.$WFoo3 -- RHS size: {terms: 5, types: 2, coercions: 0, joins: 0/0} fun1 [InlPrag=NOINLINE] :: Foo -> () -[GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<S,1*U>, Unf=OtherCon []] fun1 = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Tuple.() } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} @@ -33,7 +33,6 @@ T7360.fun5 = fun1 T7360.Foo1 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.fun4 :: Int [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -70,7 +69,6 @@ fun2 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T7360.$trModule4 = "main"# @@ -78,7 +76,6 @@ T7360.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -87,7 +84,6 @@ T7360.$trModule3 = GHC.Types.TrNameS T7360.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T7360.$trModule2 = "T7360"# @@ -95,7 +91,6 @@ T7360.$trModule2 = "T7360"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -104,7 +99,6 @@ T7360.$trModule1 = GHC.Types.TrNameS T7360.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T7360.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -113,7 +107,7 @@ T7360.$trModule -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} $krep :: GHC.Types.KindRep -[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] +[GblId, Str=m1, Unf=OtherCon []] $krep = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) @@ -121,7 +115,6 @@ $krep -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T7360.$tcFoo2 = "Foo"# @@ -129,7 +122,6 @@ T7360.$tcFoo2 = "Foo"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -138,7 +130,6 @@ T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo :: GHC.Types.TyCon [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] @@ -153,7 +144,7 @@ T7360.$tcFoo -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} T7360.$tc'Foo4 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep -[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] +[GblId, Str=m1, Unf=OtherCon []] T7360.$tc'Foo4 = GHC.Types.KindRepTyConApp T7360.$tcFoo (GHC.Types.[] @GHC.Types.KindRep) @@ -161,7 +152,6 @@ T7360.$tc'Foo4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo6 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T7360.$tc'Foo6 = "'Foo1"# @@ -169,7 +159,6 @@ T7360.$tc'Foo6 = "'Foo1"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo5 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -178,7 +167,6 @@ T7360.$tc'Foo5 = GHC.Types.TrNameS T7360.$tc'Foo6 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo1 :: GHC.Types.TyCon [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] @@ -194,7 +182,6 @@ T7360.$tc'Foo1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo8 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T7360.$tc'Foo8 = "'Foo2"# @@ -202,7 +189,6 @@ T7360.$tc'Foo8 = "'Foo2"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo7 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -211,7 +197,6 @@ T7360.$tc'Foo7 = GHC.Types.TrNameS T7360.$tc'Foo8 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo2 :: GHC.Types.TyCon [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] @@ -226,13 +211,12 @@ T7360.$tc'Foo2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo9 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep -[GblId, Caf=NoCafRefs, Str=m4, Unf=OtherCon []] +[GblId, Str=m4, Unf=OtherCon []] T7360.$tc'Foo9 = GHC.Types.KindRepFun $krep T7360.$tc'Foo4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo11 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T7360.$tc'Foo11 = "'Foo3"# @@ -240,7 +224,6 @@ T7360.$tc'Foo11 = "'Foo3"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo10 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -249,7 +232,6 @@ T7360.$tc'Foo10 = GHC.Types.TrNameS T7360.$tc'Foo11 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo3 :: GHC.Types.TyCon [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index ad14ae8e09..9e3f4184ea 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -13,27 +13,27 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule1 :: Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule2 :: TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule2 = GHC.Types.TrNameS $trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule3 :: Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule3 = "T9400"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule4 :: TrName -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] $trModule4 = GHC.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T9400.$trModule :: Module -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] T9400.$trModule = GHC.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 22, types: 15, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr index 413a7a98e0..2b15450864 100644 --- a/testsuite/tests/simplCore/should_compile/noinline01.stderr +++ b/testsuite/tests/simplCore/should_compile/noinline01.stderr @@ -2,7 +2,7 @@ ==================== STG: ==================== Noinline01.f [InlPrag=INLINE (sat-args=1)] :: forall p. p -> GHC.Types.Bool -[GblId, Arity=1, Caf=NoCafRefs, Str=<L,A>, Unf=OtherCon []] = +[GblId, Arity=1, Str=<L,A>, Unf=OtherCon []] = \r [eta] GHC.Types.True []; Noinline01.g :: GHC.Types.Bool @@ -10,23 +10,23 @@ Noinline01.g :: GHC.Types.Bool \u [] Noinline01.f GHC.Types.False; Noinline01.$trModule4 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] = +[GblId, Unf=OtherCon []] = "main"#; Noinline01.$trModule3 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] = +[GblId, Str=m1, Unf=OtherCon []] = CCS_DONT_CARE GHC.Types.TrNameS! [Noinline01.$trModule4]; Noinline01.$trModule2 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] = +[GblId, Unf=OtherCon []] = "Noinline01"#; Noinline01.$trModule1 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] = +[GblId, Str=m1, Unf=OtherCon []] = CCS_DONT_CARE GHC.Types.TrNameS! [Noinline01.$trModule2]; Noinline01.$trModule :: GHC.Types.Module -[GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []] = +[GblId, Str=m, Unf=OtherCon []] = CCS_DONT_CARE GHC.Types.Module! [Noinline01.$trModule3 Noinline01.$trModule1]; diff --git a/testsuite/tests/simplCore/should_compile/par01.stderr b/testsuite/tests/simplCore/should_compile/par01.stderr index f85d96426f..98de76e1ca 100644 --- a/testsuite/tests/simplCore/should_compile/par01.stderr +++ b/testsuite/tests/simplCore/should_compile/par01.stderr @@ -6,7 +6,7 @@ Result size of CorePrep Rec { -- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0} Par01.depth [Occ=LoopBreaker] :: GHC.Types.Int -> GHC.Types.Int -[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<L,U>, Unf=OtherCon []] Par01.depth = \ (d :: GHC.Types.Int) -> case GHC.Prim.par# @GHC.Types.Int d of { __DEFAULT -> @@ -16,27 +16,27 @@ end Rec } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Par01.$trModule4 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] Par01.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Par01.$trModule3 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] +[GblId, Str=m1, Unf=OtherCon []] Par01.$trModule3 = GHC.Types.TrNameS Par01.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Par01.$trModule2 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] Par01.$trModule2 = "Par01"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Par01.$trModule1 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] +[GblId, Str=m1, Unf=OtherCon []] Par01.$trModule1 = GHC.Types.TrNameS Par01.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Par01.$trModule :: GHC.Types.Module -[GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []] +[GblId, Str=m, Unf=OtherCon []] Par01.$trModule = GHC.Types.Module Par01.$trModule3 Par01.$trModule1 diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 8c615305d5..7cfd4442b3 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -6,7 +6,6 @@ Result size of Tidy Core -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Roman.$trModule4 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] Roman.$trModule4 = "main"# @@ -14,7 +13,6 @@ Roman.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -23,7 +21,6 @@ Roman.$trModule3 = GHC.Types.TrNameS Roman.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Roman.$trModule2 :: GHC.Prim.Addr# [GblId, - Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] Roman.$trModule2 = "Roman"# @@ -31,7 +28,6 @@ Roman.$trModule2 = "Roman"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -40,7 +36,6 @@ Roman.$trModule1 = GHC.Types.TrNameS Roman.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Roman.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] @@ -49,7 +44,7 @@ Roman.$trModule -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} lvl :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Unf=OtherCon []] lvl = "spec-inline.hs:(19,5)-(29,25)|function go"# -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} @@ -62,7 +57,7 @@ Rec { -- RHS size: {terms: 40, types: 5, coercions: 0, joins: 0/0} Roman.foo_$s$wgo [Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=2, Caf=NoCafRefs, Str=<L,A><L,U>, Unf=OtherCon []] +[GblId, Arity=2, Str=<L,A><L,U>, Unf=OtherCon []] Roman.foo_$s$wgo = \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) -> case GHC.Prim.<=# sc1 0# of { @@ -136,7 +131,6 @@ Roman.foo_go -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.foo2 :: Int [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -145,7 +139,6 @@ Roman.foo2 = GHC.Types.I# 6# -- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} Roman.foo1 :: Maybe Int [GblId, - Caf=NoCafRefs, Str=m2, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] @@ -155,7 +148,6 @@ Roman.foo1 = GHC.Maybe.Just @Int Roman.foo2 foo :: Int -> Int [GblId, Arity=1, - Caf=NoCafRefs, Str=<S,1*U(U)>m, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/stranal/should_compile/T13031.stdout b/testsuite/tests/stranal/should_compile/T13031.stdout index 22ef963cea..efdbb60fe9 100644 --- a/testsuite/tests/stranal/should_compile/T13031.stdout +++ b/testsuite/tests/stranal/should_compile/T13031.stdout @@ -1,2 +1,2 @@ hello -[GblId, Arity=1, Caf=NoCafRefs, Unf=OtherCon []] +[GblId, Arity=1, Unf=OtherCon []] |