X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FClosureInfo.lhs;h=8c36ab2e9f5b1b32e7e7064eb20a64ccac0beda8;hp=d137d4d3ca004a7129da7ffb025db8be5e8654fc;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index d137d4d..8c36ab2 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The Univserity of Glasgow 1992-2004 % @@ -12,8 +13,9 @@ the STG paper. \begin{code} module ClosureInfo ( - ClosureInfo, LambdaFormInfo, SMRep, -- all abstract - StandardFormInfo, + ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but + StandardFormInfo(..), -- mkCmmInfo looks inside + SMRep, ArgDescr(..), Liveness(..), C_SRT(..), needsSRT, @@ -21,18 +23,19 @@ module ClosureInfo ( mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, - mkClosureInfo, mkConInfo, + mkClosureInfo, mkConInfo, maybeIsLFCon, closureSize, closureNonHdrSize, closureGoodStuffSize, closurePtrsSize, slopSize, - closureName, infoTableLabelFromCI, - closureLabelFromCI, closureSRT, - closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, + infoTableLabelFromCI, + closureLabelFromCI, + isLFThunk, closureUpdReqd, closureNeedsUpdSpace, closureIsThunk, closureSingleEntry, closureReEntrant, isConstrClosure_maybe, closureFunInfo, isStandardFormThunk, isKnownFun, + funTag, funTagLFInfo, tagForArity, enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, @@ -48,7 +51,7 @@ module ClosureInfo ( closureValDescr, closureTypeDescr, -- profiling isStaticClosure, - cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, + cafBlackHoleClosureInfo, staticClosureNeedsLink, ) where @@ -56,28 +59,29 @@ module ClosureInfo ( #include "../includes/MachDeps.h" #include "HsVersions.h" +--import CgUtils import StgSyn -import SMRep -- all of it +import SMRep import CLabel -import Packages ( isDllName ) -import PackageConfig ( PackageId ) -import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, - opt_Parallel, opt_DoTickyProfiling ) -import Id ( Id, idType, idArity, idName ) -import DataCon ( DataCon, dataConTyCon, isNullaryRepDataCon, dataConName ) -import Name ( Name, nameUnique, getOccName, getOccString ) -import OccName ( occNameString ) -import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe ) -import TcType ( tcSplitSigmaTy ) -import TyCon ( isFunTyCon, isAbstractTyCon ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName ) +import Unique +import StaticFlags +import Var +import Id +import IdInfo +import DataCon +import Name +import OccName +import Type +import TypeRep +import TcType +import TyCon +import BasicTypes import FastString import Outputable import Constants - -import TypeRep -- TEMP +import DynFlags \end{code} @@ -115,8 +119,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... @@ -124,10 +127,15 @@ data ClosureInfo data C_SRT = NoC_SRT | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} + deriving (Eq) needsSRT :: C_SRT -> Bool needsSRT NoC_SRT = False needsSRT (C_SRT _ _ _) = True + +instance Outputable C_SRT where + 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} %************************************************************************ @@ -185,7 +193,7 @@ data LambdaFormInfo data ArgDescr = ArgSpec -- Fits one of the standard patterns - !Int -- RTS type identifier ARG_P, ARG_N, ... + !StgHalfWord -- RTS type identifier ARG_P, ARG_N, ... | ArgGen -- General case Liveness -- Details about the arguments @@ -250,20 +258,21 @@ mkLFReEntrant :: TopLevelFlag -- True of top level mkLFReEntrant top fvs args arg_descr = LFReEntrant top (length args) (null fvs) arg_descr +mkLFThunk :: Type -> TopLevelFlag -> [Var] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag - = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) ) + = ASSERT2( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty), ppr thunk_ty $$ ppr fvs ) LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk (might_be_a_function thunk_ty) might_be_a_function :: Type -> Bool +-- Return False only if we are *sure* it's a data type +-- Look through newtypes etc as much as poss might_be_a_function ty - | Just (tc,_) <- splitTyConApp_maybe (repType ty), - not (isFunTyCon tc) && not (isAbstractTyCon tc) = False - -- don't forget to check for abstract types, which might - -- be functions too. - | otherwise = True + = case splitTyConApp_maybe (repType ty) of + Just (tc, _) -> not (isDataTyCon tc) + Nothing -> True \end{code} @mkConLFInfo@ is similar, for constructors. @@ -272,10 +281,16 @@ might_be_a_function ty mkConLFInfo :: DataCon -> LambdaFormInfo mkConLFInfo con = LFCon con +maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon +maybeIsLFCon (LFCon con) = Just con +maybeIsLFCon _ = Nothing + +mkSelectorLFInfo :: Id -> WordOff -> Bool -> LambdaFormInfo mkSelectorLFInfo id offset updatable = LFThunk NotTopLevel False updatable (SelectorThunk offset) (might_be_a_function (idType id)) +mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) (might_be_a_function (idType id)) @@ -284,15 +299,17 @@ mkApLFInfo id upd_flag arity Miscellaneous LF-infos. \begin{code} +mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id = LFUnknown (might_be_a_function (idType id)) +mkLFLetNoEscape :: Int -> LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id = case idArity id of n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0 - other -> mkLFArgument id -- Not sure of exact arity + _ -> mkLFArgument id -- Not sure of exact arity \end{code} \begin{code} @@ -330,15 +347,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} @@ -390,6 +405,7 @@ Slop Requirements: every thunk gets an extra padding word in the header, which takes the the updated value. \begin{code} +slopSize :: ClosureInfo -> WordOff slopSize cl_info = computeSlopSize payload_size cl_info where payload_size = closureGoodStuffSize cl_info @@ -404,6 +420,7 @@ computeSlopSize payload_size cl_info -- or (b) it is a static thunk. This is because a static thunk needs -- a static link field in a predictable place (after the slop), regardless -- of whether it is updatable or not. +closureNeedsUpdSpace :: ClosureInfo -> Bool closureNeedsUpdSpace (ClosureInfo { closureLFInfo = LFThunk TopLevel _ _ _ _ }) = True closureNeedsUpdSpace cl_info = closureUpdReqd cl_info @@ -452,7 +469,7 @@ chooseSMRep is_static lf_info tot_wds ptr_wds getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType getClosureType is_static ptr_wds lf_info = case lf_info of - LFCon con | is_static && ptr_wds == 0 -> ConstrNoCaf + LFCon _ | is_static && ptr_wds == 0 -> ConstrNoCaf | otherwise -> Constr LFReEntrant _ _ _ _ -> Fun LFThunk _ _ _ (SelectorThunk _) _ -> ThunkSelector @@ -504,7 +521,7 @@ nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _) -- or profiling (in which case we need to recover the cost centre -- from inside it) -nodeMustPointToIt (LFThunk _ no_fvs updatable some_standard_form_thunk _) +nodeMustPointToIt (LFThunk _ _ _ _ _) = True -- Node must point to any standard-form thunk nodeMustPointToIt (LFUnknown _) = True @@ -560,74 +577,91 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: PackageId - -> 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 this_pkg name lf_info n_args +getCallMethod _ _ _ lf_info _ | 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 _ _ _ (LFCon con) n_args + | opt_SccProfilingOn -- when profiling, we must always enter + = EnterIt -- a closure when we use it, so that the closure + -- can be recorded as used for LDV profiling. + | otherwise = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod this_pkg 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 +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] - | updatable || opt_DoTickyProfiling -- to catch double entry + -- Since is_fun is False, we are *definitely* looking at a data value + | 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 of jumping directly to the entry code is still valid. --SDM -} - = ASSERT( n_args == 0 ) EnterIt + = EnterIt + -- We used to have ASSERT( n_args == 0 ), but actually it is + -- possible for the optimiser to generate + -- let bot :: Int = error Int "urk" + -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3 + -- This happens as a result of the case-of-error transformation + -- So the right thing to do is just to enter the thing | 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 this_pkg name (LFUnknown True) n_args - = SlowCall -- might be a function +getCallMethod _ _ _ (LFUnknown True) _ + = SlowCall -- Might be a function -getCallMethod this_pkg name (LFUnknown False) n_args - = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) - EnterIt -- Not 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 (LFBlackHole _) n_args + | otherwise + = EnterIt -- Not a function + +getCallMethod _ _ _ (LFBlackHole _) _ = 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) _ = 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) -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 @@ -638,16 +672,16 @@ 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. - other -> panic "blackHoleOnEntry" -- Should never happen + _ -> panic "blackHoleOnEntry" -- Should never happen isStandardFormThunk :: LambdaFormInfo -> Bool isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True -isStandardFormThunk other_lf_info = False +isStandardFormThunk _ = False isKnownFun :: LambdaFormInfo -> Bool isKnownFun (LFReEntrant _ _ _ _) = True @@ -655,6 +689,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 @@ -677,6 +734,30 @@ staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con }) _other -> True \end{code} +Note [Entering error thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + + fail :: Int + fail = error Int "Urk" + + foo :: Bool -> Bool + foo True y = (fail `cast` Bool -> Bool) y + foo False y = False + +This looks silly, but it can arise from case-of-error. Even if it +does, we'd usually see that 'fail' is a bottoming function and would +discard the extra argument 'y'. But even if that does not occur, +this program is still OK. We will enter 'fail', which never returns. + +The WARN is just to alert me to the fact that we aren't spotting that +'fail' is bottoming. + +(We are careful never to make a funtion value look like a data type, +because we can't enter a function closure -- but that is not the +problem here.) + + Avoiding generating entries and info tables ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At present, for every function we generate all of the following, @@ -744,13 +825,13 @@ staticClosureRequired -> StgBinderInfo -> LambdaFormInfo -> Bool -staticClosureRequired binder bndr_info +staticClosureRequired _ bndr_info (LFReEntrant top_level _ _ _) -- It's a function = ASSERT( isTopLevel top_level ) -- Assumption: it's a top-level, no-free-var binding not (satCallsOnly bndr_info) -staticClosureRequired binder other_binder_info other_lf_info = True +staticClosureRequired _ _ _ = True \end{code} %************************************************************************ @@ -781,21 +862,43 @@ closureIsThunk ConInfo{} = False closureSingleEntry :: ClosureInfo -> Bool closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd -closureSingleEntry other_closure = False +closureSingleEntry _ = False closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True -closureReEntrant other_closure = False +closureReEntrant _ = False isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con isConstrClosure_maybe _ = Nothing closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) -closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc}) - = Just (arity, arg_desc) -closureFunInfo _ - = Nothing +closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info +closureFunInfo _ = Nothing + +lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr) +lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) +lfFunInfo _ = Nothing + +funTag :: ClosureInfo -> Int +funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info +funTag _ = 0 + +-- maybe this should do constructor tags too? +funTagLFInfo :: LambdaFormInfo -> Int +funTagLFInfo lf + -- A function is tagged with its arity + | Just (arity,_) <- lfFunInfo lf, + Just tag <- tagForArity arity + = tag + + -- other closures (and unknown ones) are not tagged + | otherwise + = 0 + +tagForArity :: Int -> Maybe Int +tagForArity i | i <= mAX_PTR_TAG = Just i + | otherwise = Nothing \end{code} \begin{code} @@ -804,17 +907,16 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of LFReEntrant TopLevel _ _ _ -> True LFThunk TopLevel _ _ _ _ -> True - other -> False + _ -> False isToplevClosure _ = False \end{code} Label generation. \begin{code} -infoTableLabelFromCI :: ClosureInfo -> CLabel +infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel infoTableLabelFromCI (ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureSMRep = rep }) + closureLFInfo = lf_info }) caf = case lf_info of LFBlackHole info -> info @@ -824,50 +926,56 @@ 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" + _ -> 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 -> CafInfo -> CLabel +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 :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel +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 :: Bool -> Int -> CLabel enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity | otherwise = mkApEntryLabel is_updatable arity +enterSelectorLabel :: Bool -> Int -> CLabel 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 :: Name -> CafInfo -> CLabel +enterIdLabel id + | tablesNextToCode = mkInfoTableLabel id + | otherwise = mkEntryLabel id +enterLocalIdLabel :: Name -> CafInfo -> CLabel enterLocalIdLabel id | tablesNextToCode = mkLocalInfoTableLabel id | otherwise = mkLocalEntryLabel id +enterReturnPtLabel :: Unique -> CLabel enterReturnPtLabel name | tablesNextToCode = mkReturnInfoLabel name | otherwise = mkReturnPtLabel name @@ -880,6 +988,7 @@ ways to build an LFBlackHole, maintaining the invariant that it really is a black hole and not something else. \begin{code} +cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureType = ty }) = ClosureInfo { closureName = nm, @@ -889,16 +998,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} %************************************************************************ @@ -936,7 +1035,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 } @@ -944,8 +1042,8 @@ getTyDescription ty fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other -getPredTyDescription (ClassP cl tys) = getOccString cl -getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip) +getPredTyDescription :: PredType -> String +getPredTyDescription (ClassP cl _) = getOccString cl +getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) +getPredTyDescription (EqPred _ _) = panic "getPredTyDescription EqPred" \end{code} - -