projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
9b78a8e
)
Fix warnings in ClosureInfo
author
Ian Lynagh
<igloo@earth.li>
Mon, 29 Dec 2008 16:46:18 +0000
(16:46 +0000)
committer
Ian Lynagh
<igloo@earth.li>
Mon, 29 Dec 2008 16:46:18 +0000
(16:46 +0000)
compiler/codeGen/ClosureInfo.lhs
patch
|
blob
|
history
diff --git
a/compiler/codeGen/ClosureInfo.lhs
b/compiler/codeGen/ClosureInfo.lhs
index
d819873
..
bc7dfec
100644
(file)
--- a/
compiler/codeGen/ClosureInfo.lhs
+++ b/
compiler/codeGen/ClosureInfo.lhs
@@
-12,13
+12,6
@@
Much of the rationale for these things is in the ``details'' part of
the STG paper.
\begin{code}
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
module ClosureInfo (
ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but
StandardFormInfo(..), -- mkCmmInfo looks inside
@@
-36,9
+29,9
@@
module ClosureInfo (
closureGoodStuffSize, closurePtrsSize,
slopSize,
closureGoodStuffSize, closurePtrsSize,
slopSize,
- closureName, infoTableLabelFromCI,
+ infoTableLabelFromCI,
closureLabelFromCI,
closureLabelFromCI,
- closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd,
+ isLFThunk, closureUpdReqd,
closureNeedsUpdSpace, closureIsThunk,
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
closureNeedsUpdSpace, closureIsThunk,
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
@@
-72,9
+65,9
@@
import SMRep
import CLabel
import CLabel
-import Packages
-import PackageConfig
+import Unique
import StaticFlags
import StaticFlags
+import Var
import Id
import IdInfo
import DataCon
import Id
import IdInfo
import DataCon
@@
-265,6
+258,7
@@
mkLFReEntrant :: TopLevelFlag -- True of top level
mkLFReEntrant top fvs args arg_descr
= LFReEntrant top (length args) (null fvs) arg_descr
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) )
LFThunk top (null fvs)
mkLFThunk thunk_ty top fvs upd_flag
= ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) )
LFThunk top (null fvs)
@@
-291,10
+285,12
@@
maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
maybeIsLFCon (LFCon con) = Just con
maybeIsLFCon _ = Nothing
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))
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))
mkApLFInfo id upd_flag arity
= LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
(might_be_a_function (idType id))
@@
-303,15
+299,17
@@
mkApLFInfo id upd_flag arity
Miscellaneous LF-infos.
\begin{code}
Miscellaneous LF-infos.
\begin{code}
+mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id = LFUnknown (might_be_a_function (idType id))
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
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}
\end{code}
\begin{code}
@@
-407,6
+405,7
@@
Slop Requirements: every thunk gets an extra padding word in the
header, which takes the the updated value.
\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
slopSize cl_info = computeSlopSize payload_size cl_info
where payload_size = closureGoodStuffSize cl_info
@@
-421,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.
-- 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
closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
LFThunk TopLevel _ _ _ _ }) = True
closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
@@
-469,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
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
| otherwise -> Constr
LFReEntrant _ _ _ _ -> Fun
LFThunk _ _ _ (SelectorThunk _) _ -> ThunkSelector
@@
-521,7
+521,7
@@
nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
-- or profiling (in which case we need to recover the cost centre
-- from inside it)
-- 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
= True -- Node must point to any standard-form thunk
nodeMustPointToIt (LFUnknown _) = True
@@
-584,7
+584,7
@@
getCallMethod :: DynFlags
-> Int -- Number of available arguments
-> CallMethod
-> 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
| 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
@@
-597,7
+597,7
@@
getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
| n_args < arity = SlowCall -- Not enough args
| otherwise = DirectEntry (enterIdLabel name caf) arity
| n_args < arity = SlowCall -- Not enough args
| otherwise = DirectEntry (enterIdLabel name caf) arity
-getCallMethod _ name _ (LFCon con) n_args
+getCallMethod _ _ _ (LFCon con) n_args
= ASSERT( n_args == 0 )
ReturnCon con
= ASSERT( n_args == 0 )
ReturnCon con
@@
-626,7
+626,7
@@
getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg
= ASSERT( n_args == 0 )
JumpToIt (thunkEntryLabel name caf std_form_info updatable)
= ASSERT( n_args == 0 )
JumpToIt (thunkEntryLabel name caf std_form_info updatable)
-getCallMethod _ name _ (LFUnknown True) n_args
+getCallMethod _ _ _ (LFUnknown True) _
= SlowCall -- Might be a function
getCallMethod _ name _ (LFUnknown False) n_args
= SlowCall -- Might be a function
getCallMethod _ name _ (LFUnknown False) n_args
@@
-637,12
+637,12
@@
getCallMethod _ name _ (LFUnknown False) n_args
| otherwise
= EnterIt -- Not a function
| 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
= 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
= JumpToIt (enterReturnPtLabel (nameUnique name))
getCallMethod _ name _ (LFLetNoEscape arity) n_args
@@
-672,12
+672,12
@@
blackHoleOnEntry dflags (ClosureInfo { closureLFInfo = lf_info, closureSMRep = r
-- the former to catch double entry,
-- and the latter to plug space-leaks. KSW/SDM 1999-04.
-- 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 :: LambdaFormInfo -> Bool
isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
-isStandardFormThunk other_lf_info = False
+isStandardFormThunk _ = False
isKnownFun :: LambdaFormInfo -> Bool
isKnownFun (LFReEntrant _ _ _ _) = True
isKnownFun :: LambdaFormInfo -> Bool
isKnownFun (LFReEntrant _ _ _ _) = True
@@
-821,13
+821,13
@@
staticClosureRequired
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
-> 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)
(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}
%************************************************************************
\end{code}
%************************************************************************
@@
-858,11
+858,11
@@
closureIsThunk ConInfo{} = False
closureSingleEntry :: ClosureInfo -> Bool
closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
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 :: 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 :: ClosureInfo -> Maybe DataCon
isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con
@@
-903,7
+903,7
@@
isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
= case lf_info of
LFReEntrant TopLevel _ _ _ -> True
LFThunk TopLevel _ _ _ _ -> True
= case lf_info of
LFReEntrant TopLevel _ _ _ -> True
LFThunk TopLevel _ _ _ _ -> True
- other -> False
+ _ -> False
isToplevClosure _ = False
\end{code}
isToplevClosure _ = False
\end{code}
@@
-912,8
+912,7
@@
Label generation.
\begin{code}
infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel
infoTableLabelFromCI (ClosureInfo { closureName = name,
\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
= case lf_info of
LFBlackHole info -> info
@@
-927,7
+926,7
@@
infoTableLabelFromCI (ClosureInfo { closureName = name,
LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf
LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf
- other -> panic "infoTableLabelFromCI"
+ _ -> panic "infoTableLabelFromCI"
infoTableLabelFromCI (ConInfo { closureCon = con,
closureSMRep = rep }) caf
infoTableLabelFromCI (ConInfo { closureCon = con,
closureSMRep = rep }) caf
@@
-937,35
+936,42
@@
infoTableLabelFromCI (ConInfo { closureCon = con,
name = dataConName con
-- ClosureInfo for a closure (as opposed to a constructor) is always local
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.
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
+thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
+thunkEntryLabel _thunk_id _ (ApThunk arity) is_updatable
= enterApLabel is_updatable arity
= enterApLabel is_updatable arity
-thunkEntryLabel thunk_id _ (SelectorThunk offset) upd_flag
+thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag
= enterSelectorLabel upd_flag offset
= enterSelectorLabel upd_flag offset
-thunkEntryLabel thunk_id caf _ is_updatable
+thunkEntryLabel thunk_id caf _ _is_updatable
= enterIdLabel thunk_id caf
= enterIdLabel thunk_id caf
+enterApLabel :: Bool -> Int -> CLabel
enterApLabel is_updatable arity
| tablesNextToCode = mkApInfoTableLabel is_updatable arity
| otherwise = mkApEntryLabel is_updatable arity
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
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
enterIdLabel id
| tablesNextToCode = mkInfoTableLabel id
| otherwise = mkEntryLabel id
+enterLocalIdLabel :: Name -> CafInfo -> CLabel
enterLocalIdLabel id
| tablesNextToCode = mkLocalInfoTableLabel id
| otherwise = mkLocalEntryLabel id
enterLocalIdLabel id
| tablesNextToCode = mkLocalInfoTableLabel id
| otherwise = mkLocalEntryLabel id
+enterReturnPtLabel :: Unique -> CLabel
enterReturnPtLabel name
| tablesNextToCode = mkReturnInfoLabel name
| otherwise = mkReturnPtLabel name
enterReturnPtLabel name
| tablesNextToCode = mkReturnInfoLabel name
| otherwise = mkReturnPtLabel name
@@
-978,6
+984,7
@@
ways to build an LFBlackHole, maintaining the invariant that it really
is a black hole and not something else.
\begin{code}
is a black hole and not something else.
\begin{code}
+cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
closureType = ty })
= ClosureInfo { closureName = nm,
cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
closureType = ty })
= ClosureInfo { closureName = nm,
@@
-1031,6
+1038,8
@@
getTyDescription ty
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
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}
\end{code}