X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FClosureInfo.lhs;h=df32299c2a4e3065bc9f1f62803b6b58bd9af748;hp=d537a7b3d9e990c24d9381e6938e9edf72d6a772;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=6015a94f9108a502150565577b66c23650796639 diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index d537a7b..df32299 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -12,6 +12,13 @@ Much of the rationale for these things is in the ``details'' part of the STG paper. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module ClosureInfo ( ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but StandardFormInfo(..), -- mkCmmInfo looks inside @@ -30,7 +37,7 @@ module ClosureInfo ( slopSize, closureName, infoTableLabelFromCI, - closureLabelFromCI, closureSRT, + closureLabelFromCI, closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, closureNeedsUpdSpace, closureIsThunk, closureSingleEntry, closureReEntrant, isConstrClosure_maybe, @@ -51,7 +58,7 @@ module ClosureInfo ( closureValDescr, closureTypeDescr, -- profiling isStaticClosure, - cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, + cafBlackHoleClosureInfo, staticClosureNeedsLink, ) where @@ -69,6 +76,7 @@ import Packages import PackageConfig import StaticFlags import Id +import IdInfo import DataCon import Name import OccName @@ -117,8 +125,7 @@ data ClosureInfo -- the constructor's info table), and they don't have an SRT. | ConInfo { closureCon :: !DataCon, - closureSMRep :: !SMRep, - closureDllCon :: !Bool -- is in a separate DLL + closureSMRep :: !SMRep } -- C_SRT is what StgSyn.SRT gets translated to... @@ -133,7 +140,7 @@ needsSRT NoC_SRT = False needsSRT (C_SRT _ _ _) = True instance Outputable C_SRT where - ppr (NoC_SRT) = ptext SLIT("_no_srt_") + ppr (NoC_SRT) = ptext (sLit "_no_srt_") ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap)) \end{code} @@ -341,15 +348,13 @@ 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 :: PackageId - -> Bool -- Is static +mkConInfo :: Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo this_pkg is_static data_con tot_wds ptr_wds +mkConInfo is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, - closureCon = data_con, - closureDllCon = isDllName this_pkg (dataConName data_con) } + closureCon = data_con } where sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds \end{code} @@ -571,31 +576,32 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: PackageId - -> Name -- Function being applied +getCallMethod :: Name -- Function being applied + -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod this_pkg 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 this_pkg name (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 this_pkg name) arity + | otherwise = DirectEntry (enterIdLabel name caf) arity -getCallMethod this_pkg name (LFCon con) n_args +getCallMethod name _ (LFCon con) n_args = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod this_pkg name (LFThunk _ _ updatable std_form_info is_fun) n_args - | is_fun -- *Might* be a function, so we must "call" it (which is always safe) +getCallMethod 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] @@ -616,24 +622,28 @@ getCallMethod this_pkg 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 this_pkg name std_form_info updatable) + JumpToIt (thunkEntryLabel name caf std_form_info updatable) + +getCallMethod name _ (LFUnknown True) n_args + = SlowCall -- Might be a function -getCallMethod this_pkg name (LFUnknown True) n_args - = SlowCall -- might be a function +getCallMethod name _ (LFUnknown False) n_args + | n_args > 0 + = WARN( True, ppr name <+> ppr n_args ) + SlowCall -- Note [Unsafe coerce complications] -getCallMethod this_pkg name (LFUnknown False) n_args - = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) - EnterIt -- Not a function + | otherwise + = EnterIt -- Not a function -getCallMethod this_pkg 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 this_pkg name (LFLetNoEscape 0) n_args +getCallMethod name _ (LFLetNoEscape 0) n_args = JumpToIt (enterReturnPtLabel (nameUnique name)) -getCallMethod this_pkg name (LFLetNoEscape arity) n_args +getCallMethod name _ (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -673,6 +683,29 @@ isKnownFun (LFLetNoEscape _) = True isKnownFun _ = False \end{code} +Note [Unsafe coerce complications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some (badly-optimised) DPH code we see this + Module X: rr :: Int = error Int "Urk" + Module Y: ...((X.rr |> g) True) ... + where g is an (unsafe) coercion of kind (Int ~ Bool->Bool), say + +It's badly optimised, because knowing that 'X.rr' is bottom, we should +have dumped the application to True. But it should still work. These +strange unsafe coercions arise from the case-of-error transformation: + (case (error Int "foo") of { ... }) True +---> (error Int "foo" |> g) True + +Anyway, the net effect is that in STG-land, when casts are discarded, +we *can* see a value of type Int applied to an argument. This only happens +if (a) the programmer made a mistake, or (b) the value of type Int is +actually bottom. + +So it's wrong to trigger an ASSERT failure in this circumstance. Instead +we now emit a WARN -- mainly to draw attention to a probably-badly-optimised +program fragment -- and do the conservative thing which is SlowCall. + + ----------------------------------------------------------------------------- SRT-related stuff @@ -851,10 +884,10 @@ isToplevClosure _ = False Label generation. \begin{code} -infoTableLabelFromCI :: ClosureInfo -> CLabel +infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel infoTableLabelFromCI (ClosureInfo { closureName = name, closureLFInfo = lf_info, - closureSMRep = rep }) + closureSMRep = rep }) caf = case lf_info of LFBlackHole info -> info @@ -864,33 +897,32 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name + LFThunk{} -> mkLocalInfoTableLabel name caf - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name + LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf other -> panic "infoTableLabelFromCI" infoTableLabelFromCI (ConInfo { closureCon = con, - closureSMRep = rep, - closureDllCon = dll }) - | isStaticRep rep = mkStaticInfoTableLabel name dll - | otherwise = mkConInfoTableLabel name dll + closureSMRep = rep }) caf + | isStaticRep rep = mkStaticInfoTableLabel name caf + | otherwise = mkConInfoTableLabel name caf where name = dataConName con -- ClosureInfo for a closure (as opposed to a constructor) is always local -closureLabelFromCI (ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm -closureLabelFromCI _ = panic "closureLabelFromCI" +closureLabelFromCI (ClosureInfo { closureName = nm }) caf = mkLocalClosureLabel nm caf +closureLabelFromCI _ _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. -thunkEntryLabel this_pkg thunk_id (ApThunk arity) is_updatable +thunkEntryLabel thunk_id _ (ApThunk arity) is_updatable = enterApLabel is_updatable arity -thunkEntryLabel this_pkg thunk_id (SelectorThunk offset) upd_flag +thunkEntryLabel thunk_id _ (SelectorThunk offset) upd_flag = enterSelectorLabel upd_flag offset -thunkEntryLabel this_pkg thunk_id _ is_updatable - = enterIdLabel this_pkg thunk_id +thunkEntryLabel thunk_id caf _ is_updatable + = enterIdLabel thunk_id caf enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity @@ -900,9 +932,9 @@ enterSelectorLabel upd_flag offset | tablesNextToCode = mkSelectorInfoLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -enterIdLabel this_pkg id - | tablesNextToCode = mkInfoTableLabel this_pkg id - | otherwise = mkEntryLabel this_pkg id +enterIdLabel id + | tablesNextToCode = mkInfoTableLabel id + | otherwise = mkEntryLabel id enterLocalIdLabel id | tablesNextToCode = mkLocalInfoTableLabel id @@ -929,16 +961,6 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureType = ty, closureDescr = "" } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" - -seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) - = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel, - closureSMRep = BlackHoleRep, - closureSRT = NoC_SRT, - closureType = ty, - closureDescr = "" } -seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo" \end{code} %************************************************************************ @@ -976,7 +998,6 @@ getTyDescription ty AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon - NoteTy (FTVNote _) ty -> getTyDescription ty PredTy sty -> getPredTyDescription sty ForAllTy _ ty -> getTyDescription ty }