\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,
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,
closureValDescr, closureTypeDescr, -- profiling
isStaticClosure,
- cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
+ cafBlackHoleClosureInfo,
staticClosureNeedsLink,
) where
#include "../includes/MachDeps.h"
#include "HsVersions.h"
+--import CgUtils
import StgSyn
import SMRep
import CLabel
-import Packages
-import PackageConfig
+import Unique
import StaticFlags
+import Var
import Id
+import IdInfo
import DataCon
import Name
-import OccName
import Type
import TypeRep
import TcType
import FastString
import Outputable
import Constants
+import DynFlags
\end{code}
-- 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...
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}
%************************************************************************
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
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
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))
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}
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}
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
-- 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
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
-- 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
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 -- *Might* be a function, so we must "call" it (which is always safe)
+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
- {- 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
- -}
+ | otherwise
= EnterIt
-- We used to have ASSERT( n_args == 0 ), but actually it is
-- possible for the optimiser to generate
-- 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)
+-- Old version:
+-- | updatable || doingTickyProfiling dflags -- to catch double entry
+-- = EnterIt
+-- | otherwise -- Jump direct to code for single-entry thunks
+-- = JumpToIt (thunkEntryLabel name caf std_form_info updatable)
+--
+-- Now we never use JumpToIt, even if the thunk is single-entry, since
+-- the thunk may have already been entered and blackholed by another
+-- processor.
+
-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]
+
+ | otherwise
+ = EnterIt -- Not a function
-getCallMethod this_pkg name (LFBlackHole _) n_args
+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
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
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
_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,
-> 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}
%************************************************************************
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}
= 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
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
+{- UNUSED:
+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
+-}
+{- UNUSED:
+enterApLabel :: Bool -> Int -> CLabel
enterApLabel is_updatable arity
| tablesNextToCode = mkApInfoTableLabel is_updatable arity
| otherwise = mkApEntryLabel is_updatable arity
+-}
+{- UNUSED:
+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
is a black hole and not something else.
\begin{code}
+cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
closureType = ty })
= 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}
%************************************************************************
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
}
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}
-
-
projects / ghc-hetmet.git / blobdiff