From 1c2f89535394958f75cfb15c8c5e0433a20953ed Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 24 Aug 2011 16:15:50 +0100 Subject: refactoring and fixing the stage 2 compilation --- compiler/cmm/CLabel.hs | 77 ++++++------ compiler/cmm/CmmBuildInfoTables.hs | 4 +- compiler/cmm/CmmInfo.hs | 2 +- compiler/codeGen/CgClosure.lhs | 40 ++---- compiler/codeGen/ClosureInfo.lhs | 51 +++++--- compiler/codeGen/StgCmmBind.hs | 30 +---- compiler/codeGen/StgCmmClosure.hs | 245 ++++++++++++++++--------------------- compiler/codeGen/StgCmmLayout.hs | 2 +- compiler/ghci/ByteCodeAsm.lhs | 1 + compiler/ghci/ByteCodeGen.lhs | 1 + compiler/ghci/ByteCodeInstr.lhs | 1 + compiler/ghci/ByteCodeItbls.lhs | 2 +- compiler/main/StaticFlags.hs | 6 +- 13 files changed, 200 insertions(+), 262 deletions(-) diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 14aa1837c7..e1893836ab 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -22,7 +22,7 @@ module CLabel ( mkSRTLabel, mkInfoTableLabel, mkEntryLabel, - mkSlowEntryLabel, slowEntryFromInfoLabel, + mkSlowEntryLabel, mkConEntryLabel, mkStaticConEntryLabel, mkRednCountsLabel, @@ -100,11 +100,12 @@ module CLabel ( mkHpcTicksLabel, hasCAF, - cvtToClosureLbl, - needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, + needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, - infoLblToEntryLbl, entryLblToInfoLbl, + + -- * Conversions + toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, toRednCountsLbl, pprCLabel ) where @@ -359,7 +360,6 @@ data DynamicLinkerLabelInfo -- Constructing IdLabels -- These are always local: mkSlowEntryLabel name c = IdLabel name c Slow -slowEntryFromInfoLabel (IdLabel n c _) = IdLabel n c Slow mkSRTLabel name c = IdLabel name c SRT mkRednCountsLabel name c = IdLabel name c RednCounts @@ -506,39 +506,40 @@ mkPlainModuleInitLabel :: Module -> CLabel mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- ----------------------------------------------------------------------------- --- Brutal method of obtaining a closure label - -cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c LocalInfoTable) = IdLabel n c Closure -- XXX? -cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c LocalEntry) = IdLabel n c Closure -- XXX? -cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure -cvtToClosureLbl l@(IdLabel n c Closure) = l -cvtToClosureLbl l - = pprPanic "cvtToClosureLbl" (pprCLabel l) - -infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry -infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry -infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry -infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -infoLblToEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry -infoLblToEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet -infoLblToEntryLbl _ - = panic "CLabel.infoLblToEntryLbl" - -entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable -entryLblToInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable -entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable -entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo -entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo -entryLblToInfoLbl l - = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) +-- Convert between different kinds of label + +toClosureLbl :: CLabel -> CLabel +toClosureLbl (IdLabel n c _) = IdLabel n c Closure +toClosureLbl l = pprPanic "toClosureLbl" (pprCLabel l) + +toSlowEntryLbl :: CLabel -> CLabel +toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow +toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (pprCLabel l) + +toRednCountsLbl :: CLabel -> CLabel +toRednCountsLbl (IdLabel n c _) = IdLabel n c RednCounts +toRednCountsLbl l = pprPanic "toRednCountsLbl" (pprCLabel l) + +toEntryLbl :: CLabel -> CLabel +toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry +toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry +toEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry +toEntryLbl (IdLabel n c _) = IdLabel n c Entry +toEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt +toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry +toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet +toEntryLbl l = pprPanic "toEntryLbl" (pprCLabel l) + +toInfoLbl :: CLabel -> CLabel +toInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable +toInfoLbl (IdLabel n c LocalEntry) = IdLabel n c LocalInfoTable +toInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable +toInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable +toInfoLbl (IdLabel n c _) = IdLabel n c InfoTable +toInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo +toInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo +toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo +toInfoLbl l = pprPanic "CLabel.toInfoLbl" (pprCLabel l) -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 3e54aacc77..699f1003b6 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -203,7 +203,7 @@ cafTransfers = mkBTransfer3 first middle last CmmLit (CmmLabelOff c _) -> add c set CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set _ -> set - add l s = if hasCAF l then Map.insert (cvtToClosureLbl l) () s else s + add l s = if hasCAF l then Map.insert (toClosureLbl l) () s else s cafAnal :: CmmGraph -> FuelUniqSM CAFEnv cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers @@ -341,7 +341,7 @@ localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = case info_tbl top_info of CmmInfoTable { cit_rep = rep } | not (isStaticRep rep) - -> Just (cvtToClosureLbl top_l, + -> Just (toClosureLbl top_l, expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) _ -> Nothing diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index c270e01706..a11b61cb91 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -156,7 +156,7 @@ mkInfoTableContents info@(CmmInfoTable { cit_lbl = info_lbl , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where - slow_entry = CmmLabel (slowEntryFromInfoLabel info_lbl) + slow_entry = CmmLabel (toSlowEntryLbl info_lbl) srt_lit = case srt_label of [] -> mkIntCLit 0 (lit:_rest) -> ASSERT( null _rest ) lit diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index d158bf78ab..ffaa5eec8b 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -449,38 +449,14 @@ blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) emitBlackHoleCode :: Bool -> Code emitBlackHoleCode is_single_entry = do - - dflags <- getDynFlags - - -- If we wanted to do eager blackholing with slop filling, - -- we'd need to do it at the *end* of a basic block, otherwise - -- we overwrite the free variables in the thunk that we still - -- need. We have a patch for this from Andy Cheadle, but not - -- incorporated yet. --SDM [6/2004] - -- - -- Profiling needs slop filling (to support LDV profiling), so - -- currently eager blackholing doesn't work with profiling. - -- - -- Previously, eager blackholing was enabled when ticky-ticky - -- was on. But it didn't work, and it wasn't strictly necessary - -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING - -- is unconditionally disabled. -- krc 1/2007 - - let eager_blackholing = not opt_SccProfilingOn - && dopt Opt_EagerBlackHoling dflags - - if eager_blackholing - then do - tickyBlackHole (not is_single_entry) - let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo) - stmtsC [ - CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) - (CmmReg (CmmGlobal CurrentTSO)), - CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmUnsafe CmmMayReturn, - CmmStore (CmmReg nodeReg) bh_info - ] - else - nopC + tickyBlackHole (not is_single_entry) + let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo) + stmtsC [ + CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) + (CmmReg (CmmGlobal CurrentTSO)), + CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmUnsafe CmmMayReturn, + CmmStore (CmmReg nodeReg) bh_info + ] \end{code} \begin{code} diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index c55a9f936f..de4318afb0 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -33,7 +33,7 @@ module ClosureInfo ( isLFThunk, closureUpdReqd, closureNeedsUpdSpace, closureIsThunk, closureSingleEntry, closureReEntrant, isConstrClosure_maybe, - closureFunInfo, isStandardFormThunk, isKnownFun, + closureFunInfo, isKnownFun, funTag, funTagLFInfo, tagForArity, clHasCafRefs, enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, @@ -118,7 +118,7 @@ data ClosureInfo closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below) closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure - closureType :: !Type, -- Type of closure (ToDo: remove) + closureType :: !Type, -- Type of closure (ToDo: remove) closureDescr :: !String, -- closure description (for profiling) closureInfLcl :: Bool -- can the info pointer be a local symbol? } @@ -707,35 +707,48 @@ getCallMethod _ name _ (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) -blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool + +-- Eager blackholing is normally disabled, but can be turned on with +-- -feager-blackholing. When it is on, we replace the info pointer of +-- the thunk with stg_EAGER_BLACKHOLE_info on entry. + +-- If we wanted to do eager blackholing with slop filling, +-- we'd need to do it at the *end* of a basic block, otherwise +-- we overwrite the free variables in the thunk that we still +-- need. We have a patch for this from Andy Cheadle, but not +-- incorporated yet. --SDM [6/2004] +-- +-- +-- Previously, eager blackholing was enabled when ticky-ticky +-- was on. But it didn't work, and it wasn't strictly necessary +-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING +-- is unconditionally disabled. -- krc 1/2007 + -- Static closures are never themselves black-holed. --- Updatable ones will be overwritten with a CAFList cell, which points to a --- black hole; --- Single-entry ones have no fvs to plug, and we trust they don't form part --- of a loop. +blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool blackHoleOnEntry _ ConInfo{} = False -blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep }) - | isStaticRep rep +blackHoleOnEntry dflags cl_info + | isStaticRep (closureSMRep cl_info) = False -- Never black-hole a static closure | otherwise - = case lf_info of + = case closureLFInfo cl_info of LFReEntrant _ _ _ _ -> False - LFLetNoEscape _ -> False + LFLetNoEscape _ -> False LFThunk _ no_fvs updatable _ _ - -> if updatable - then not opt_OmitBlackHoling - else doingTickyProfiling dflags || not no_fvs + | eager_blackholing -> doingTickyProfiling dflags || not no_fvs -- the former to catch double entry, -- and the latter to plug space-leaks. KSW/SDM 1999-04. + | otherwise -> False - _ -> panic "blackHoleOnEntry" -- Should never happen + where eager_blackholing = not opt_SccProfilingOn + && dopt Opt_EagerBlackHoling dflags + -- Profiling needs slop filling (to support + -- LDV profiling), so currently eager + -- blackholing doesn't work with profiling. -isStandardFormThunk :: LambdaFormInfo -> Bool -isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True -isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True -isStandardFormThunk _ = False + _other -> panic "blackHoleOnEntry" -- Should never happen isKnownFun :: LambdaFormInfo -> Bool isKnownFun (LFReEntrant _ _ _ _) = True diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 9afdf02a90..ade0be1a94 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -502,34 +502,14 @@ blackHoleIt :: ClosureInfo -> FCode () blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) emitBlackHoleCode :: Bool -> FCode () -emitBlackHoleCode is_single_entry - | eager_blackholing = do - tickyBlackHole (not is_single_entry) - emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO))) - emitPrimCall [] MO_WriteBarrier [] - emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl))) - | otherwise = - nopC +emitBlackHoleCode is_single_entry = do + tickyBlackHole (not is_single_entry) + emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO))) + emitPrimCall [] MO_WriteBarrier [] + emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl))) where bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info") | otherwise = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info") - - -- If we wanted to do eager blackholing with slop filling, - -- we'd need to do it at the *end* of a basic block, otherwise - -- we overwrite the free variables in the thunk that we still - -- need. We have a patch for this from Andy Cheadle, but not - -- incorporated yet. --SDM [6/2004] - -- - -- Profiling needs slop filling (to support LDV profiling), so - -- currently eager blackholing doesn't work with profiling. - -- - -- Previously, eager blackholing was enabled when ticky-ticky - -- was on. But it didn't work, and it wasn't strictly necessary - -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING - -- is unconditionally disabled. -- krc 1/2007 - - eager_blackholing = False - setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), -- so that the cost centre in the original closure can still be diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 9447edfad9..300606eb7e 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -7,8 +7,6 @@ -- -- Nothing monadic in here! -- --- (c) The University of Glasgow 2004-2006 --- ----------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} @@ -19,8 +17,8 @@ module StgCmmClosure ( isVoidRep, isGcPtrRep, addIdReps, addArgReps, argPrimRep, - ----------------------------------- - LambdaFormInfo, -- Abstract + -- * LambdaFormInfo + LambdaFormInfo, -- Abstract StandardFormInfo, -- ...ditto... mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, @@ -28,33 +26,37 @@ module StgCmmClosure ( lfDynTag, maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, - ----------------------------------- + nodeMustPointToIt, + CallMethod(..), getCallMethod, + + isKnownFun, funTag, tagForArity, + + -- * ClosureInfo ClosureInfo, mkClosureInfo, mkCmmInfo, - closureSize, closureName, + -- ** Inspection + closureLFInfo, closureName, - closureEntryLabel, closureInfoTableLabel, staticClosureLabel, + -- ** Labels + -- These just need the info table label + closureInfoLabel, staticClosureLabel, closureRednCountsLabel, closureSlowEntryLabel, closureLocalEntryLabel, - closureLFInfo, + -- ** Predicates + -- These are really just functions on LambdaFormInfo closureUpdReqd, closureSingleEntry, - closureReEntrant, closureFunInfo, isStandardFormThunk, - isKnownFun, funTag, tagForArity, - - nodeMustPointToIt, - CallMethod(..), getCallMethod, - - blackHoleOnEntry, + closureReEntrant, closureFunInfo, + isToplevClosure, - isToplevClosure, - isStaticClosure, - - staticClosureNeedsLink, + blackHoleOnEntry, -- Needs LambdaFormInfo and SMRep + isStaticClosure, -- Needs SMPre + -- * InfoTables mkDataConInfoTable, - cafBlackHoleInfoTable + cafBlackHoleInfoTable, + staticClosureNeedsLink, ) where #include "../includes/MachDeps.h" @@ -85,6 +87,8 @@ import DynFlags -- Representations ----------------------------------------------------------------------------- +-- Why are these here? + addIdReps :: [Id] -> [(PrimRep, Id)] addIdReps ids = [(idPrimRep id, id) | id <- ids] @@ -153,36 +157,6 @@ data LambdaFormInfo -- allocDynClosure needs a LambdaFormInfo -------------------------- --- An ArgDsecr describes the argument pattern of a function - -{- XXX -- imported from old ClosureInfo for now -data ArgDescr - = ArgSpec -- Fits one of the standard patterns - !StgHalfWord -- RTS type identifier ARG_P, ARG_N, ... - - | ArgGen -- General case - Liveness -- Details about the arguments --} - -{- XXX -- imported from old ClosureInfo for now -------------------------- --- We represent liveness bitmaps as a Bitmap (whose internal --- representation really is a bitmap). These are pinned onto case return --- vectors to indicate the state of the stack for the garbage collector. --- --- In the compiled program, liveness bitmaps that fit inside a single --- word (StgWord) are stored as a single word, while larger bitmaps are --- stored as a pointer to an array of words. - -data Liveness - = SmallLiveness -- Liveness info that fits in one word - StgWord -- Here's the bitmap - - | BigLiveness -- Liveness info witha a multi-word bitmap - CLabel -- Label for the bitmap --} - ------------------------- -- StandardFormInfo tells whether this thunk has one of -- a small number of standard forms @@ -543,11 +517,6 @@ getCallMethod _ _name _ LFBlackHole _n_args getCallMethod _ _name _ LFLetNoEscape _n_args = JumpToIt -isStandardFormThunk :: LambdaFormInfo -> Bool -isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True -isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True -isStandardFormThunk _other_lf_info = False - isKnownFun :: LambdaFormInfo -> Bool isKnownFun (LFReEntrant _ _ _ _) = True isKnownFun LFLetNoEscape = True @@ -640,53 +609,50 @@ staticClosureRequired binder other_binder_info other_lf_info = True -} ----------------------------------------------------------------------------- --- Data types for closure information} +-- Data types for closure information ----------------------------------------------------------------------------- -{- Information about a closure, from the code generator's point of view. +{- ClosureInfo: information about a binding -A ClosureInfo decribes the info pointer of a closure. It has -enough information - a) to construct the info table itself - b) to allocate a closure containing that info pointer (i.e. - it knows the info table label) + We make a ClosureInfo for each let binding (both top level and not), + but not bindings for data constructors: for those we build a CmmInfoTable + directly (see mkDataConInfoTable). -We make a ClosureInfo for each let binding (both top level and not), -but not bindings for data constructors. - -Note [Closure CAF info] -~~~~~~~~~~~~~~~~~~~~~~~ -The closureCafs field is relevant for *static closures only*. It -records whether a CAF is reachable from the code for the closure It is -initialised simply from the idCafInfo of the Id. + To a first approximation: + ClosureInfo = (LambdaFormInfo, CmmInfoTable) + A ClosureInfo has enough information + a) to construct the info table itself, and build other things + related to the binding (e.g. slow entry points for a function) + b) to allocate a closure containing that info pointer (i.e. + it knows the info table label) -} data ClosureInfo = ClosureInfo { - -- these three are for making labels related to this closure: - closureName :: !Name, -- The thing bound to this closure - closureCafs :: !CafInfo, -- used for making labels only - closureLocal :: !Bool, -- make local labels? - - -- this tells us about what the closure contains: - closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon - - -- these fields tell us about the representation of the closure, - -- and are used for making an info table: - closureSMRep :: !SMRep, -- representation used by storage mgr - closureSRT :: !C_SRT, -- What SRT applies to this closure - closureProf :: !ProfilingInfo + closureName :: !Name, -- The thing bound to this closure + -- we don't really need this field: it's only used in generating + -- code for ticky and profiling, and we could pass the information + -- around separately, but it doesn't do much harm to keep it here. + + closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon + -- this tells us about what the closure contains: it's right-hand-side. + + -- the rest is just an unpacked CmmInfoTable. + closureInfoLabel :: !CLabel, + closureSMRep :: !SMRep, -- representation used by storage mgr + closureSRT :: !C_SRT, -- What SRT applies to this closure + closureProf :: !ProfilingInfo } -- | Convert from 'ClosureInfo' to 'CmmInfoTable'. mkCmmInfo :: ClosureInfo -> CmmInfoTable -mkCmmInfo cl_info - = CmmInfoTable { cit_lbl = closureInfoTableLabel cl_info, - cit_rep = closureSMRep cl_info, - cit_prof = closureProf cl_info, - cit_srt = closureSRT cl_info } +mkCmmInfo ClosureInfo {..} + = CmmInfoTable { cit_lbl = closureInfoLabel + , cit_rep = closureSMRep + , cit_prof = closureProf + , cit_srt = closureSRT } -------------------------------------- @@ -701,60 +667,64 @@ mkClosureInfo :: Bool -- Is static -> String -- String descriptor -> ClosureInfo mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info val_descr - = ClosureInfo { closureName = name, - closureCafs = cafs, - closureLocal = is_local, - closureLFInfo = lf_info, - closureSMRep = sm_rep, -- These four fields are a - closureSRT = srt_info, -- CmmInfoTable - closureProf = prof } -- --- + = ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureInfoLabel = info_lbl, + closureSMRep = sm_rep, -- These four fields are a + closureSRT = srt_info, -- CmmInfoTable + closureProf = prof } -- --- where name = idName id sm_rep = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info) prof = mkProfilingInfo id val_descr nonptr_wds = tot_wds - ptr_wds - cafs = idCafInfo id - is_local = isDataConWorkId id - -- Make the _info pointer for the implicit datacon worker - -- binding local. The reason we can do this is that importing - -- code always either uses the _closure or _con_info. By the - -- invariants in CorePrep anything else gets eta expanded. + info_lbl = mkClosureInfoTableLabel id lf_info -------------------------------------- --- Functions about closure *sizes* +-- Other functions over ClosureInfo -------------------------------------- -closureSize :: ClosureInfo -> WordOff -closureSize cl_info = heapClosureSize (closureSMRep cl_info) +-- Eager blackholing is normally disabled, but can be turned on with +-- -feager-blackholing. When it is on, we replace the info pointer of +-- the thunk with stg_EAGER_BLACKHOLE_info on entry. --------------------------------------- --- Other functions over ClosureInfo --------------------------------------- +-- If we wanted to do eager blackholing with slop filling, +-- we'd need to do it at the *end* of a basic block, otherwise +-- we overwrite the free variables in the thunk that we still +-- need. We have a patch for this from Andy Cheadle, but not +-- incorporated yet. --SDM [6/2004] +-- +-- +-- Previously, eager blackholing was enabled when ticky-ticky +-- was on. But it didn't work, and it wasn't strictly necessary +-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING +-- is unconditionally disabled. -- krc 1/2007 -blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool -- Static closures are never themselves black-holed. --- Updatable ones will be overwritten with a CAFList cell, which points to a --- black hole; --- Single-entry ones have no fvs to plug, and we trust they don't form part --- of a loop. -blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep }) - | isStaticRep rep +blackHoleOnEntry :: DynFlags -> ClosureInfo -> Bool +blackHoleOnEntry dflags cl_info + | isStaticRep (closureSMRep cl_info) = False -- Never black-hole a static closure | otherwise - = case lf_info of + = case closureLFInfo cl_info of LFReEntrant _ _ _ _ -> False LFLetNoEscape -> False - LFThunk _ no_fvs updatable _ _ - -> if updatable - then not opt_OmitBlackHoling - else doingTickyProfiling dflags || not no_fvs + LFThunk _ no_fvs _updatable _ _ + | eager_blackholing -> doingTickyProfiling dflags || not no_fvs -- the former to catch double entry, -- and the latter to plug space-leaks. KSW/SDM 1999-04. + | otherwise -> False - _other -> panic "blackHoleOnEntry" -- Should never happen + where eager_blackholing = not opt_SccProfilingOn + && dopt Opt_EagerBlackHoling dflags + -- Profiling needs slop filling (to support + -- LDV profiling), so currently eager + -- blackholing doesn't work with profiling. + + _other -> panic "blackHoleOnEntry" -- Should never happen isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -798,27 +768,22 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) -- Label generation -------------------------------------- -closureEntryLabel :: ClosureInfo -> CLabel -closureEntryLabel = infoLblToEntryLbl . closureInfoTableLabel - staticClosureLabel :: ClosureInfo -> CLabel -staticClosureLabel = cvtToClosureLbl . closureInfoTableLabel +staticClosureLabel = toClosureLbl . closureInfoLabel closureRednCountsLabel :: ClosureInfo -> CLabel -closureRednCountsLabel ClosureInfo{..} = mkRednCountsLabel closureName closureCafs +closureRednCountsLabel = toRednCountsLbl . closureInfoLabel closureSlowEntryLabel :: ClosureInfo -> CLabel -closureSlowEntryLabel ClosureInfo{..} = mkSlowEntryLabel closureName closureCafs +closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel closureLocalEntryLabel :: ClosureInfo -> CLabel -closureLocalEntryLabel ClosureInfo{..} = enterLocalIdLabel closureName closureCafs - +closureLocalEntryLabel + | tablesNextToCode = toInfoLbl . closureInfoLabel + | otherwise = toEntryLbl . closureInfoLabel -closureInfoTableLabel :: ClosureInfo -> CLabel -closureInfoTableLabel ClosureInfo { closureName = name - , closureCafs = cafs - , closureLocal = is_local - , closureLFInfo = lf_info } +mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel +mkClosureInfoTableLabel id lf_info = case lf_info of LFBlackHole -> mkCAFBlackHoleInfoTableLabel @@ -833,9 +798,18 @@ closureInfoTableLabel ClosureInfo { closureName = name _other -> panic "closureInfoTableLabel" where + name = idName id + std_mk_lbl | is_local = mkLocalInfoTableLabel | otherwise = mkInfoTableLabel + cafs = idCafInfo id + is_local = isDataConWorkId id + -- Make the _info pointer for the implicit datacon worker + -- binding local. The reason we can do this is that importing + -- code always either uses the _closure or _con_info. By the + -- invariants in CorePrep anything else gets eta expanded. + thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel -- thunkEntryLabel is a local help function, not exported. It's used from @@ -862,11 +836,6 @@ enterIdLabel id c | tablesNextToCode = mkInfoTableLabel id c | otherwise = mkEntryLabel id c -enterLocalIdLabel :: Name -> CafInfo -> CLabel -enterLocalIdLabel id c - | tablesNextToCode = mkLocalInfoTableLabel id c - | otherwise = mkLocalEntryLabel id c - -------------------------------------- -- Profiling diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 8b94abf828..58d858f729 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -396,7 +396,7 @@ emitClosureAndInfoTable :: CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () emitClosureAndInfoTable info_tbl conv args body = do { blks <- getCode body - ; let entry_lbl = infoLblToEntryLbl (cit_lbl info_tbl) + ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) ; emitProcWithConvention conv info_tbl entry_lbl args blks } diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 2ec6555a54..2920b84822 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -30,6 +30,7 @@ import PrimOp import Constants import FastString import SMRep +import ClosureInfo -- CgRep stuff import DynFlags import Outputable import Platform diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index e8df54c7c6..8cbf5d0310 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -39,6 +39,7 @@ import Unique import FastString import Panic import SMRep +import ClosureInfo import Bitmap import OrdList import Constants diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 49c5488efa..c7ff1a41e9 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -26,6 +26,7 @@ import DataCon import VarSet import PrimOp import SMRep +import ClosureInfo -- CgRep stuff import Module (Module) import GHC.Exts diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 943c9e9992..78b06e77a8 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -21,7 +21,7 @@ module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls import Name ( Name, getName ) import NameEnv -import SMRep ( typeCgRep ) +import ClosureInfo import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 307f6f104a..d225e39743 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -77,8 +77,7 @@ module StaticFlags ( opt_GranMacros, opt_HiVersion, opt_HistorySize, - opt_OmitBlackHoling, - opt_Unregisterised, + opt_Unregisterised, v_Ld_inputs, tablesNextToCode, opt_StubDeadValues, @@ -321,9 +320,6 @@ opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer opt_HistorySize :: Int opt_HistorySize = lookup_def_int "-fhistory-size" 20 -opt_OmitBlackHoling :: Bool -opt_OmitBlackHoling = lookUp (fsLit "-dno-black-holing") - opt_StubDeadValues :: Bool opt_StubDeadValues = lookUp (fsLit "-dstub-dead-values") -- cgit v1.2.1