X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=a5362e60e09b20bc5bb0fc3a281858cf5a51dccc;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=423f429ded06ed6726c0646a0549d19e29f6f76e;hpb=effd3425cfd597b1f0e71f7486ae2cffcbf081a7;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 423f429..a5362e6 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -62,15 +62,14 @@ import SMRep -- all of it import CLabel import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) -import Packages ( isDllName ) -import DynFlags ( DynFlags ) +import Packages ( isDllName, HomeModules ) import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) import Id ( Id, idType, idArity, idName ) import DataCon ( DataCon, dataConTyCon, isNullaryRepDataCon, dataConName ) import Name ( Name, nameUnique, getOccName, getOccString ) -import OccName ( occNameUserString ) +import OccName ( occNameString ) import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe ) import TcType ( tcSplitSigmaTy ) import TyCon ( isFunTyCon, isAbstractTyCon ) @@ -332,15 +331,15 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds -mkConInfo :: DynFlags +mkConInfo :: HomeModules -> Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo dflags is_static data_con tot_wds ptr_wds +mkConInfo hmods is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, closureCon = data_con, - closureDllCon = isDllName dflags (dataConName data_con) } + closureDllCon = isDllName hmods (dataConName data_con) } where sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds \end{code} @@ -572,30 +571,30 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: DynFlags +getCallMethod :: HomeModules -> Name -- Function being applied -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod dflags name lf_info n_args +getCallMethod hmods 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 dflags name (LFReEntrant _ arity _ _) n_args +getCallMethod hmods name (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 dflags name) arity + | otherwise = DirectEntry (enterIdLabel hmods name) arity -getCallMethod dflags name (LFCon con) n_args +getCallMethod hmods name (LFCon con) n_args = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod dflags name (LFThunk _ _ updatable std_form_info is_fun) n_args +getCallMethod hmods name (LFThunk _ _ updatable std_form_info is_fun) n_args | is_fun -- Must always "call" a function-typed = SlowCall -- thing, cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] @@ -608,24 +607,24 @@ getCallMethod dflags name (LFThunk _ _ updatable std_form_info is_fun) n_args | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - JumpToIt (thunkEntryLabel dflags name std_form_info updatable) + JumpToIt (thunkEntryLabel hmods name std_form_info updatable) -getCallMethod dflags name (LFUnknown True) n_args +getCallMethod hmods name (LFUnknown True) n_args = SlowCall -- might be a function -getCallMethod dflags name (LFUnknown False) n_args +getCallMethod hmods name (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod dflags name (LFBlackHole _) n_args +getCallMethod hmods 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 dflags name (LFLetNoEscape 0) n_args +getCallMethod hmods name (LFLetNoEscape 0) n_args = JumpToIt (enterReturnPtLabel (nameUnique name)) -getCallMethod dflags name (LFLetNoEscape arity) n_args +getCallMethod hmods name (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -855,12 +854,12 @@ closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. -thunkEntryLabel dflags thunk_id (ApThunk arity) is_updatable +thunkEntryLabel hmods thunk_id (ApThunk arity) is_updatable = enterApLabel is_updatable arity -thunkEntryLabel dflags thunk_id (SelectorThunk offset) upd_flag +thunkEntryLabel hmods thunk_id (SelectorThunk offset) upd_flag = enterSelectorLabel upd_flag offset -thunkEntryLabel dflags thunk_id _ is_updatable - = enterIdLabel dflags thunk_id +thunkEntryLabel hmods thunk_id _ is_updatable + = enterIdLabel hmods thunk_id enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity @@ -870,9 +869,9 @@ enterSelectorLabel upd_flag offset | tablesNextToCode = mkSelectorInfoLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -enterIdLabel dflags id - | tablesNextToCode = mkInfoTableLabel dflags id - | otherwise = mkEntryLabel dflags id +enterIdLabel hmods id + | tablesNextToCode = mkInfoTableLabel hmods id + | otherwise = mkEntryLabel hmods id enterLocalIdLabel id | tablesNextToCode = mkLocalInfoTableLabel id @@ -931,12 +930,12 @@ closureValDescr, closureTypeDescr :: ClosureInfo -> String closureValDescr (ClosureInfo {closureDescr = descr}) = descr closureValDescr (ConInfo {closureCon = con}) - = occNameUserString (getOccName con) + = occNameString (getOccName con) closureTypeDescr (ClosureInfo { closureType = ty }) = getTyDescription ty closureTypeDescr (ConInfo { closureCon = data_con }) - = occNameUserString (getOccName (dataConTyCon data_con)) + = occNameString (getOccName (dataConTyCon data_con)) getTyDescription :: Type -> String getTyDescription ty @@ -947,7 +946,6 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty - NoteTy (SynNote ty1) _ -> getTyDescription ty1 PredTy sty -> getPredTyDescription sty ForAllTy _ ty -> getTyDescription ty }