X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmClosure.hs;h=d6177438a41639a2d7e03f4a54f6e97abcb7b877;hp=c32d7cd8579c7a0cc3d841149d8e44ac65df01c9;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c32d7cd..d617743 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -11,7 +11,6 @@ -- ----------------------------------------------------------------------------- - module StgCmmClosure ( SMRep, DynTag, tagForCon, isSmallFamily, @@ -58,7 +57,7 @@ module StgCmmClosure ( closureValDescr, closureTypeDescr, -- profiling isStaticClosure, - cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, + cafBlackHoleClosureInfo, staticClosureNeedsLink, clHasCafRefs ) where @@ -73,7 +72,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..)) import StgSyn import SMRep -import Cmm ( ClosureTypeInfo(..) ) +import CmmDecl ( ClosureTypeInfo(..), ConstrDescription ) import CmmExpr import CLabel @@ -82,7 +81,6 @@ import Id import IdInfo import DataCon import Name -import OccName import Type import TypeRep import TcType @@ -90,7 +88,7 @@ import TyCon import BasicTypes import Outputable import Constants - +import DynFlags ----------------------------------------------------------------------------- -- Representations @@ -236,7 +234,7 @@ mkLFLetNoEscape = LFLetNoEscape ------------- mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars + -> [Id] -- Free vars -> [Id] -- Args -> ArgDescr -- Argument descriptor -> LambdaFormInfo @@ -306,13 +304,15 @@ type DynTag = Int -- The tag on a *pointer* {- Note [Data constructor dynamic tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors) -can be either: +The family size of a data type (the number of constructors +or the arity of a function) can be either: * small, if the family size < 2**tag_bits * big, otherwise. Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -} +Big families only use the tag value 1 to represent evaluatedness. +We don't have very many tag bits: for example, we have 2 bits on +x86-32 and 3 bits on x86-64. -} isSmallFamily :: Int -> Bool isSmallFamily fam_size = fam_size <= mAX_PTR_TAG @@ -335,6 +335,8 @@ tagForArity arity | isSmallFamily arity = arity | otherwise = 0 lfDynTag :: LambdaFormInfo -> DynTag +-- Return the tag in the low order bits of a variable bound +-- to this LambdaForm lfDynTag (LFCon con) = tagForCon con lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity lfDynTag _other = 0 @@ -489,38 +491,39 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: Name -- Function being applied +getCallMethod :: DynFlags + -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod _name _ lf_info _n_args +getCallMethod _ _name _ lf_info _n_args | nodeMustPointToIt lf_info && opt_Parallel = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. EnterIt -getCallMethod name caf (LFReEntrant _ arity _ _) n_args +getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args | n_args == 0 = ASSERT( arity /= 0 ) ReturnIt -- No args at all | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel name caf) arity -getCallMethod _name _ LFUnLifted n_args +getCallMethod _ _name _ LFUnLifted n_args = ASSERT( n_args == 0 ) ReturnIt -getCallMethod _name _ (LFCon _) n_args +getCallMethod _ _name _ (LFCon _) n_args = ASSERT( n_args == 0 ) ReturnIt -getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args +getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args | is_fun -- it *might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || opt_DoTickyProfiling -- to catch double entry + | updatable || doingTickyProfiling dflags -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation @@ -538,19 +541,19 @@ getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args = ASSERT( n_args == 0 ) DirectEntry (thunkEntryLabel name caf std_form_info updatable) 0 -getCallMethod _name _ (LFUnknown True) _n_args +getCallMethod _ _name _ (LFUnknown True) _n_args = SlowCall -- might be a function -getCallMethod name _ (LFUnknown False) n_args +getCallMethod _ name _ (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod _name _ (LFBlackHole _) _n_args +getCallMethod _ _name _ (LFBlackHole _) _n_args = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it -getCallMethod _name _ LFLetNoEscape _n_args +getCallMethod _ _name _ LFLetNoEscape _n_args = JumpToIt isStandardFormThunk :: LambdaFormInfo -> Bool @@ -675,7 +678,8 @@ data ClosureInfo closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String -- closure description (for profiling) + closureDescr :: !String, -- closure description (for profiling) + closureCafs :: !CafInfo -- whether the closure may have CAFs } -- Constructor closures don't have a unique info table label (they use @@ -720,7 +724,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSMRep = sm_rep, closureSRT = srt_info, closureType = idType id, - closureDescr = descr } + closureDescr = descr, + closureCafs = idCafInfo id } where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -743,39 +748,37 @@ mkConInfo is_static data_con tot_wds ptr_wds cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) + closureType = ty, + closureCafs = cafs }) = ClosureInfo { closureName = nm, closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureCafs = cafs } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" -seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo -seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) - = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel, - closureSMRep = BlackHoleRep, - closureSRT = NoC_SRT, - closureType = ty, - closureDescr = "" } -seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo" -------------------------------------- -- Extracting ClosureTypeInfo -------------------------------------- -closureTypeInfo :: ClosureInfo -> ClosureTypeInfo -closureTypeInfo cl_info +-- JD: I've added the continuation arguments not for fun but because +-- I don't want to pipe the monad in here (circular module dependencies), +-- and I don't want to pull this code out of this module, which would +-- require us to expose a bunch of abstract types. + +closureTypeInfo :: + ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) -> + (ClosureTypeInfo -> a) -> a +closureTypeInfo cl_info k_with_con_name k_simple = case cl_info of ConInfo { closureCon = con } - -> ConstrInfo (ptrs, nptrs) - (fromIntegral (dataConTagZ con)) - con_name + -> k_with_con_name (ConstrInfo (ptrs, nptrs) + (fromIntegral (dataConTagZ con))) con info_lbl where - con_name = panic "closureTypeInfo" + --con_name = panic "closureTypeInfo" -- Was: -- cstr <- mkByteStringCLit $ dataConIdentity con -- con_name = makeRelativeRefTo info_lbl cstr @@ -783,23 +786,23 @@ closureTypeInfo cl_info ClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ arity _ arg_descr, closureSRT = srt } - -> FunInfo (ptrs, nptrs) - srt - (fromIntegral arity) - arg_descr - (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info))) + -> k_simple $ FunInfo (ptrs, nptrs) + srt + (fromIntegral arity) + arg_descr + (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info))) ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _, closureSRT = srt } - -> ThunkSelectorInfo (fromIntegral offset) srt + -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt ClosureInfo { closureLFInfo = LFThunk {}, closureSRT = srt } - -> ThunkInfo (ptrs, nptrs) srt + -> k_simple $ ThunkInfo (ptrs, nptrs) srt _ -> panic "unexpected lambda form in mkCmmInfo" where --- info_lbl = infoTableLabelFromCI cl_info + info_lbl = infoTableLabelFromCI cl_info ptrs = fromIntegral $ closurePtrsSize cl_info size = fromIntegral $ closureNonHdrSize cl_info nptrs = size - ptrs @@ -885,15 +888,15 @@ minPayloadSize smrep updatable -- Other functions over ClosureInfo -------------------------------------- -blackHoleOnEntry :: ClosureInfo -> Bool +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 ConInfo{} = False -blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep }) +blackHoleOnEntry _ ConInfo{} = False +blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep }) | isStaticRep rep = False -- Never black-hole a static closure @@ -904,7 +907,7 @@ blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep }) LFThunk _ no_fvs updatable _ _ -> if updatable then not opt_OmitBlackHoling - else opt_DoTickyProfiling || not no_fvs + else doingTickyProfiling dflags || not no_fvs -- the former to catch double entry, -- and the latter to plug space-leaks. KSW/SDM 1999-04. @@ -1092,9 +1095,7 @@ getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk? -- SRTs/CAFs -------------------------------------- --- This is horrible, but we need to know whether a closure may have CAFs. +-- We need to know whether a closure may have CAFs. clHasCafRefs :: ClosureInfo -> CafInfo -clHasCafRefs (ClosureInfo {closureSRT = srt}) = - case srt of NoC_SRT -> NoCafRefs - _ -> MayHaveCafRefs +clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs clHasCafRefs (ConInfo {}) = NoCafRefs