%
+% (c) The University of Glasgow 2006
% (c) The Univserity of Glasgow 1992-2004
%
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, 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,
closureNeedsUpdSpace, closureIsThunk,
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
+ funTag, funTagLFInfo, tagForArity,
enterIdLabel, enterLocalIdLabel, enterReturnPtLabel,
#include "../includes/MachDeps.h"
#include "HsVersions.h"
+--import CgUtils
import StgSyn
-import SMRep -- all of it
+import SMRep
import CLabel
-import Constants ( mIN_PAYLOAD_SIZE )
-import Packages ( isDllName, HomeModules )
-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 Packages
+import PackageConfig
+import StaticFlags
+import Id
+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
\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
(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.
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con = LFCon con
+maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
+maybeIsLFCon (LFCon con) = Just con
+maybeIsLFCon _ = Nothing
+
mkSelectorLFInfo id offset updatable
= LFThunk NotTopLevel False updatable (SelectorThunk offset)
(might_be_a_function (idType id))
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
-mkConInfo :: HomeModules
- -> Bool -- Is static
+mkConInfo :: Bool -- Is static
-> DataCon
-> Int -> Int -- Total and pointer words
-> ClosureInfo
-mkConInfo hmods 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 hmods (dataConName data_con) }
+ closureCon = data_con }
where
sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
\end{code}
CLabel -- The code label
Int -- Its arity
-getCallMethod :: HomeModules
- -> Name -- Function being applied
+getCallMethod :: Name -- Function being applied
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod hmods 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 hmods name (LFReEntrant _ arity _ _) n_args
+getCallMethod name (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 hmods name) arity
+ | otherwise = DirectEntry (enterIdLabel name) arity
-getCallMethod hmods name (LFCon con) n_args
+getCallMethod name (LFCon con) n_args
= ASSERT( n_args == 0 )
ReturnCon con
-getCallMethod hmods 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 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)
+ = 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
-}
- = 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 hmods name std_form_info updatable)
+ JumpToIt (thunkEntryLabel name std_form_info updatable)
-getCallMethod hmods name (LFUnknown True) n_args
+getCallMethod name (LFUnknown True) n_args
= SlowCall -- might be a function
-getCallMethod hmods name (LFUnknown False) n_args
+getCallMethod name (LFUnknown False) n_args
= ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
EnterIt -- Not a function
-getCallMethod hmods 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 hmods name (LFLetNoEscape 0) n_args
+getCallMethod name (LFLetNoEscape 0) n_args
= JumpToIt (enterReturnPtLabel (nameUnique name))
-getCallMethod hmods 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)
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}
other -> panic "infoTableLabelFromCI"
infoTableLabelFromCI (ConInfo { closureCon = con,
- closureSMRep = rep,
- closureDllCon = dll })
- | isStaticRep rep = mkStaticInfoTableLabel name dll
- | otherwise = mkConInfoTableLabel name dll
+ closureSMRep = rep })
+ | isStaticRep rep = mkStaticInfoTableLabel name
+ | otherwise = mkConInfoTableLabel name
where
name = dataConName con
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getCallMethod.
-thunkEntryLabel hmods thunk_id (ApThunk arity) is_updatable
+thunkEntryLabel thunk_id (ApThunk arity) is_updatable
= enterApLabel is_updatable arity
-thunkEntryLabel hmods thunk_id (SelectorThunk offset) upd_flag
+thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
= enterSelectorLabel upd_flag offset
-thunkEntryLabel hmods thunk_id _ is_updatable
- = enterIdLabel hmods thunk_id
+thunkEntryLabel thunk_id _ is_updatable
+ = enterIdLabel thunk_id
enterApLabel is_updatable arity
| tablesNextToCode = mkApInfoTableLabel is_updatable arity
| tablesNextToCode = mkSelectorInfoLabel upd_flag offset
| otherwise = mkSelectorEntryLabel upd_flag offset
-enterIdLabel hmods id
- | tablesNextToCode = mkInfoTableLabel hmods id
- | otherwise = mkEntryLabel hmods id
+enterIdLabel id
+ | tablesNextToCode = mkInfoTableLabel id
+ | otherwise = mkEntryLabel id
enterLocalIdLabel id
| tablesNextToCode = mkLocalInfoTableLabel id
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
}
getPredTyDescription (ClassP cl tys) = getOccString cl
getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff