+\begin{code}
+-- bring in ARG_P, ARG_N, etc.
+#include "../includes/StgFun.h"
+
+data ArgDescr
+ = ArgSpec
+ !Int -- ARG_P, ARG_N, ...
+ | ArgGen
+ CLabel -- label for a slow-entry point
+ Liveness -- the arg bitmap: describes pointedness of arguments
+
+mkArgDescr :: Name -> [Id] -> ArgDescr
+mkArgDescr nm args = argDescr nm (filter nonVoidRep (map idPrimRep args))
+ where nonVoidRep VoidRep = False
+ nonVoidRep _ = True
+
+argDescr nm [PtrRep] = ArgSpec ARG_P
+argDescr nm [FloatRep] = ArgSpec ARG_F
+argDescr nm [DoubleRep] = ArgSpec ARG_D
+argDescr nm [r] | is64BitRep r = ArgSpec ARG_L
+argDescr nm [r] | isNonPtrRep r = ArgSpec ARG_N
+
+argDescr nm [r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NN
+argDescr nm [r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NP
+argDescr nm [PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PN
+argDescr nm [PtrRep,PtrRep] = ArgSpec ARG_PP
+
+argDescr nm [r1,r2,r3] | isNonPtrRep r1 && isNonPtrRep r2 && isNonPtrRep r3 = ArgSpec ARG_NNN
+argDescr nm [r1,r2,PtrRep] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NNP
+argDescr nm [r1,PtrRep,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NPN
+argDescr nm [r1,PtrRep,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NPP
+argDescr nm [PtrRep,r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_PNN
+argDescr nm [PtrRep,r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_PNP
+argDescr nm [PtrRep,PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PPN
+argDescr nm [PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPP
+
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPP
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPP
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP
+
+argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness
+ where bitmap = argBits reps
+ lbl = mkBitmapLabel name
+ liveness = Liveness lbl (length bitmap) (mkBitmap bitmap)
+
+argBits [] = []
+argBits (rep : args)
+ | isFollowableRep rep = False : argBits args
+ | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Generating info tables}
+%* *
+%************************************************************************
+
+Here we make a concrete info table, represented as a list of CAddrMode
+(it can't be simply a list of Word, because the SRT field is
+represented by a label+offset expression).
+
+\begin{code}
+mkInfoTable :: ClosureInfo -> [CAddrMode]
+mkInfoTable cl_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
+
+ entry_amode = CLbl (entryLabelFromCI cl_info) CodePtrRep
+
+ closure_descr =
+ case cl_info of
+ ClosureInfo { closureDescr = descr } -> descr
+ ConInfo { closureCon = con } -> occNameUserString (getOccName con)
+
+ ty_descr_amode = CLit (MachStr (mkFastString (closureTypeDescr cl_info)))
+ cl_descr_amode = CLit (MachStr (mkFastString closure_descr))
+
+ cl_type = getSMRepClosureTypeInt (closureSMRep cl_info)
+
+ srt = closureSRT cl_info
+ needs_srt = needsSRT srt
+
+ semi_tag = closureSemiTag cl_info
+ is_con = isJust semi_tag
+
+ (srt_label,srt_len)
+ | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor
+ | otherwise =
+ case srt of
+ NoC_SRT -> (mkIntCLit 0, 0)
+ C_SRT lbl off bitmap ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ bitmap)
+
+ ptrs = closurePtrsSize cl_info
+ nptrs = size - ptrs
+ size = closureNonHdrSize cl_info
+
+ layout_info :: StgWord
+#ifdef WORDS_BIGENDIAN
+ layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs
+#else
+ layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD)
+#endif
+
+ layout_amode = mkWordCLit layout_info
+
+ extra_bits
+ | is_fun = fun_extra_bits
+ | is_con = []
+ | needs_srt = [srt_label]
+ | otherwise = []
+
+ maybe_fun_stuff = closureFunInfo cl_info
+ is_fun = isJust maybe_fun_stuff
+ (Just (arity, arg_descr)) = maybe_fun_stuff
+
+ 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,
+ fun_amode
+ ]
+ | needs_srt = [srt_label, fun_amode]
+ | otherwise = [fun_amode]
+
+#ifdef WORDS_BIGENDIAN
+ fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity
+#else
+ 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
+ ArgGen _ (Liveness _ size _)
+ | size <= mAX_SMALL_BITMAP_SIZE -> ARG_GEN
+ | otherwise -> ARG_GEN_BIG
+
+-- Return info tables come in two flavours: direct returns and
+-- vectored returns.
+
+mkRetInfoTable :: CLabel -> C_SRT -> Liveness -> [CAddrMode]
+mkRetInfoTable entry_lbl srt liveness
+ = mkBitmapInfoTable (CLbl entry_lbl CodePtrRep) srt liveness []
+
+mkVecInfoTable :: [CAddrMode] -> C_SRT -> Liveness -> [CAddrMode]
+mkVecInfoTable vector srt liveness
+ = mkBitmapInfoTable zero_amode srt liveness vector
+
+mkBitmapInfoTable
+ :: CAddrMode
+ -> C_SRT -> Liveness
+ -> [CAddrMode]
+ -> [CAddrMode]
+mkBitmapInfoTable entry_amode srt liveness vector
+ | 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 bitmap ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ bitmap)
+
+ cl_type = case (null vector, isBigLiveness liveness) of
+ (True, True) -> rET_BIG
+ (True, False) -> rET_SMALL
+ (False, True) -> rET_VEC_BIG
+ (False, False) -> rET_VEC_SMALL
+
+ srt_bit | needsSRT srt || not (null vector) = [srt_label]
+ | otherwise = []
+
+ 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.
+
+mkStdInfoTable
+ :: CAddrMode -- entry label
+ -> CAddrMode -- closure type descr (profiling)
+ -> CAddrMode -- closure descr (profiling)
+ -> Int -- closure type
+ -> 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
+ | tablesNextToCode = std_info'
+ | otherwise = entry_lbl : std_info'
+
+ std_info' =
+ -- par info
+ prof_info ++
+ -- ticky info
+ -- debug info
+ [layout_amode] ++
+ CLit (MachWord (fromIntegral type_info)) :
+ []
+
+ prof_info
+ | opt_SccProfilingOn = [ type_descr, closure_descr ]
+ | otherwise = []
+
+ -- sigh: building up the info table is endian-dependent.
+ -- ToDo: do this using .byte and .word directives.
+ type_info :: StgWord
+#ifdef WORDS_BIGENDIAN
+ type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|.
+ (fromIntegral srt_len)
+#else
+ type_info = (fromIntegral cl_type) .|.
+ (fromIntegral srt_len `shiftL` hALF_WORD)
+#endif
+
+isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
+
+livenessToAddrMode :: Liveness -> CAddrMode
+livenessToAddrMode (Liveness lbl size bits)
+ | size <= mAX_SMALL_BITMAP_SIZE = small
+ | otherwise = CLbl lbl DataPtrRep
+ where
+ small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
+ small_bits = case bits of
+ [] -> 0
+ [b] -> fromIntegral b
+ _ -> panic "livenessToAddrMode"
+
+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