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
closureGoodStuffSize, closurePtrsSize,
slopSize,
- closureName, infoTableLabelFromCI,
+ infoTableLabelFromCI,
closureLabelFromCI,
- closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd,
+ isLFThunk, closureUpdReqd,
closureNeedsUpdSpace, closureIsThunk,
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
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
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
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}
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
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod _ 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
| n_args < arity = SlowCall -- Not enough args
| otherwise = DirectEntry (enterIdLabel name caf) arity
-getCallMethod _ 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 dflags 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 || 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
- -}
+ | 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 name caf 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 _ name _ (LFUnknown True) n_args
+getCallMethod _ _ _ (LFUnknown True) _
= SlowCall -- Might be a function
getCallMethod _ name _ (LFUnknown False) n_args
| otherwise
= EnterIt -- Not a function
-getCallMethod _ 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 _ name _ (LFLetNoEscape 0) n_args
+getCallMethod _ name _ (LFLetNoEscape 0) _
= JumpToIt (enterReturnPtLabel (nameUnique name))
getCallMethod _ name _ (LFLetNoEscape arity) n_args
-- 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
-> 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
= case lf_info of
LFReEntrant TopLevel _ _ _ -> True
LFThunk TopLevel _ _ _ _ -> True
- other -> False
+ _ -> False
isToplevClosure _ = False
\end{code}
\begin{code}
infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel
infoTableLabelFromCI (ClosureInfo { closureName = name,
- closureLFInfo = lf_info,
- closureSMRep = rep }) caf
+ closureLFInfo = lf_info }) caf
= case lf_info of
LFBlackHole info -> info
LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf
- other -> panic "infoTableLabelFromCI"
+ _ -> panic "infoTableLabelFromCI"
infoTableLabelFromCI (ConInfo { closureCon = con,
closureSMRep = rep }) caf
name = dataConName con
-- ClosureInfo for a closure (as opposed to a constructor) is always local
+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 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 thunk_id _ (SelectorThunk offset) upd_flag
+thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
= enterSelectorLabel upd_flag offset
-thunkEntryLabel thunk_id caf _ is_updatable
+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 :: 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,
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}