%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.54 2002/12/11 15:36:28 simonmar Exp $
+% $Id: ClosureInfo.lhs,v 1.61 2003/11/17 14:23:31 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
- UpdateFlag,
closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureReEntrant, closureSemiTag,
closureFunInfo, isStandardFormThunk,
- GenStgArg,
isToplevClosure,
closureTypeDescr, -- profiling
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isNullaryDataCon, dataConName
)
-import Name ( Name, nameUnique, getOccName, getName )
+import Name ( Name, nameUnique, getOccName, getName, getOccString )
import OccName ( occNameUserString )
-import PprType ( getTyDescription )
import PrimRep
import SMRep -- all of it
import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
+import TcType ( tcSplitSigmaTy )
import TyCon ( isFunTyCon )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName )
import Util ( mapAccumL, listLengthCmp, lengthIs )
import FastString
import Outputable
import Literal
import Constants
-import BitSet
+import Bitmap
import Maybe ( isJust )
-import DATA_WORD
import DATA_BITS
+
+import TypeRep -- TEMP
\end{code}
%************************************************************************
getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType
getClosureType is_static tot_wds ptr_wds lf_info
= case lf_info of
- LFCon con | is_static && ptr_wds == 0 -> CONSTR_NOCAF
- | otherwise -> CONSTR
- LFReEntrant _ _ _ _ -> FUN
- LFThunk _ _ _ (SelectorThunk _) _ -> THUNK_SELECTOR
- LFThunk _ _ _ _ _ -> THUNK
+ LFCon con | is_static && ptr_wds == 0 -> ConstrNoCaf
+ | otherwise -> Constr
+ LFReEntrant _ _ _ _ -> Fun
+ LFThunk _ _ _ (SelectorThunk _) _ -> ThunkSelector
+ LFThunk _ _ _ _ _ -> Thunk
_ -> panic "getClosureType"
\end{code}
where
not_nocaf_constr =
case sm_rep of
- GenericRep _ _ _ CONSTR_NOCAF -> False
- _other -> True
+ GenericRep _ _ _ ConstrNoCaf -> False
+ _other -> True
\end{code}
Avoiding generating entries and info tables
= getTyDescription ty
closureTypeDescr (ConInfo { closureCon = data_con })
= occNameUserString (getOccName (dataConTyCon data_con))
+
+getTyDescription :: Type -> String
+getTyDescription ty
+ = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ FunTy _ res -> '-' : '>' : fun_result res
+ NewTcApp tycon _ -> getOccString tycon
+ TyConApp tycon _ -> getOccString tycon
+ NoteTy (FTVNote _) ty -> getTyDescription ty
+ NoteTy (SynNote ty1) _ -> getTyDescription ty1
+ PredTy sty -> getPredTyDescription sty
+ ForAllTy _ ty -> getTyDescription ty
+ }
+ where
+ 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)
\end{code}
%************************************************************************
argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness
where bitmap = argBits reps
lbl = mkBitmapLabel name
- liveness = Liveness lbl (length bitmap)
- (map chunkToLiveness (mkChunks bitmap))
+ liveness = Liveness lbl (length bitmap) (mkBitmap bitmap)
argBits [] = []
argBits (rep : args)
| isFollowableRep rep = False : argBits args
| otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
-
-mkChunks [] = []
-mkChunks stuff = chunk : mkChunks rest
- where (chunk, rest) = splitAt 32 stuff
-
-chunkToLiveness chunk = mkBS [ n | (True,n) <- zip chunk [0..] ]
\end{code}
represented by a label+offset expression).
\begin{code}
-#if SIZEOF_HSWORD == 4
-type StgWord = Word32
-#define HALF_WORD 16
-#elif SIZEOF_HSWORD == 8
-type StgWord = Word64
-#define HALF_WORD 32
-#endif
-
mkInfoTable :: ClosureInfo -> [CAddrMode]
mkInfoTable cl_info
- | opt_Unregisterised = std_info ++ extra_bits
- | otherwise = extra_bits ++ std_info
+ | tablesNextToCode = extra_bits ++ std_info
+ | otherwise = std_info ++ extra_bits
where
std_info = mkStdInfoTable entry_amode
ty_descr_amode cl_descr_amode cl_type srt_len layout_amode
is_con = isJust semi_tag
(srt_label,srt_len)
- | Just tag <- semi_tag = (mkIntCLit 0, tag) -- constructor
+ | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor
| otherwise =
case srt of
NoC_SRT -> (mkIntCLit 0, 0)
- C_SRT lbl off len ->
+ C_SRT lbl off bitmap ->
(CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
- len)
+ bitmap)
ptrs = closurePtrsSize cl_info
nptrs = size - ptrs
layout_info :: StgWord
#ifdef WORDS_BIGENDIAN
- layout_info = (fromIntegral ptrs `shiftL` HALF_WORD) .|. fromIntegral nptrs
+ layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs
#else
- layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` HALF_WORD)
+ layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD)
#endif
- layout_amode = CLit (MachWord (fromIntegral layout_info))
+ layout_amode = mkWordCLit layout_info
extra_bits
| is_fun = fun_extra_bits
(Just (arity, arg_descr)) = maybe_fun_stuff
fun_extra_bits
- | opt_Unregisterised = reverse reg_fun_extra_bits
- | otherwise = reg_fun_extra_bits
+ | tablesNextToCode = reg_fun_extra_bits
+ | otherwise = reverse reg_fun_extra_bits
reg_fun_extra_bits
| ArgGen slow_lbl liveness <- arg_descr
CLbl slow_lbl CodePtrRep,
livenessToAddrMode liveness,
srt_label,
- mkIntCLit fun_desc
+ fun_amode
]
- | needs_srt = [srt_label, mkIntCLit fun_desc]
- | otherwise = [mkIntCLit fun_desc]
+ | needs_srt = [srt_label, fun_amode]
+ | otherwise = [fun_amode]
#ifdef WORDS_BIGENDIAN
- fun_desc = (fromIntegral fun_type `shiftL` HALF_WORD) .|. fromIntegral arity
+ fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity
#else
- fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` HALF_WORD)
-#endif
+ fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` hALF_WORD)
+#endif
+
+ fun_amode = mkWordCLit fun_desc
fun_type = case arg_descr of
ArgSpec n -> n
-> [CAddrMode]
-> [CAddrMode]
mkBitmapInfoTable entry_amode srt liveness vector
- | opt_Unregisterised = std_info ++ extra_bits
- | otherwise = extra_bits ++ std_info
+ | tablesNextToCode = extra_bits ++ std_info
+ | otherwise = std_info ++ extra_bits
where
std_info = mkStdInfoTable entry_amode zero_amode zero_amode
cl_type srt_len liveness_amode
liveness_amode = livenessToAddrMode liveness
-
+
(srt_label,srt_len) =
case srt of
NoC_SRT -> (mkIntCLit 0, 0)
- C_SRT lbl off len ->
- (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
- len)
+ C_SRT lbl off bitmap ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ bitmap)
cl_type = case (null vector, isBigLiveness liveness) of
(True, True) -> rET_BIG
srt_bit | needsSRT srt || not (null vector) = [srt_label]
| otherwise = []
- extra_bits | opt_Unregisterised = srt_bit ++ vector
- | otherwise = reverse vector ++ srt_bit
+ extra_bits | tablesNextToCode = reverse vector ++ srt_bit
+ | otherwise = srt_bit ++ vector
-- The standard bits of an info table. This part of the info table
-- corresponds to the StgInfoTable type defined in InfoTables.h.
-> CAddrMode -- closure type descr (profiling)
-> CAddrMode -- closure descr (profiling)
-> Int -- closure type
- -> Int -- SRT length
+ -> StgHalfWord -- SRT length
-> CAddrMode -- layout field
-> [CAddrMode]
mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode
= std_info
where
std_info
- | opt_Unregisterised = entry_lbl : std_info'
- | otherwise = std_info'
+ | tablesNextToCode = std_info'
+ | otherwise = entry_lbl : std_info'
std_info' =
-- par info
-- ToDo: do this using .byte and .word directives.
type_info :: StgWord
#ifdef WORDS_BIGENDIAN
- type_info = (fromIntegral cl_type `shiftL` HALF_WORD) .|.
+ type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|.
(fromIntegral srt_len)
#else
type_info = (fromIntegral cl_type) .|.
- (fromIntegral srt_len `shiftL` HALF_WORD)
+ (fromIntegral srt_len `shiftL` hALF_WORD)
#endif
isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
| size <= mAX_SMALL_BITMAP_SIZE = small
| otherwise = CLbl lbl DataPtrRep
where
- small = mkIntCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
+ small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
small_bits = case bits of
[] -> 0
- [b] -> intBS b
+ [b] -> fromIntegral b
_ -> panic "livenessToAddrMode"
-mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
-
zero_amode = mkIntCLit 0
+
+-- IA64 mangler doesn't place tables next to code
+tablesNextToCode :: Bool
+#ifdef ia64_TARGET_ARCH
+tablesNextToCode = False
+#else
+tablesNextToCode = not opt_Unregisterised
+#endif
\end{code}
projects / ghc-hetmet.git / blobdiff