module CmmInfo (
+ cmmToRawCmm,
mkInfoTable
) where
import Cmm
import CmmUtils
+import PprCmm
import CLabel
+import MachOp
import Bitmap
import ClosureInfo
import CgInfoTbls
import CgCallConv
import CgUtils
+import SMRep
import Constants
import StaticFlags
+import DynFlags
import Unique
+import UniqSupply
import Panic
import Data.Bits
+cmmToRawCmm :: [Cmm] -> IO [RawCmm]
+cmmToRawCmm cmm = do
+ info_tbl_uniques <- mkSplitUniqSupply 'i'
+ return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
+ where
+ raw_cmm uniq_supply (Cmm procs) =
+ Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs
+
+-- Make a concrete info table, represented as a list of CmmStatic
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+--
+-- With tablesNextToCode, the layout is
+-- <reversed variable part>
+-- <normal forward StgInfoTable, but without
+-- an entry point at the front>
+-- <code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+-- <entry label>
+-- <normal forward rest of StgInfoTable>
+-- <forward variable part>
+--
+-- See includes/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+-- <srt slot>
+-- <standard info table>
+-- ret-addr --> <entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+-- ret-addr --> <ptr to entry code>
+-- <standard info table>
+-- <srt slot>
+--
+-- * The SRT slot is only there if there is SRT info to record
+
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
case info of
+ -- | Code without an info table. Easy.
CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
+
+ -- | A function entry point.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
- (FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry) ->
- mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
+ (FunInfo (ptrs, nptrs) srt fun_type fun_arity
+ pap_bitmap slow_entry) ->
+ mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
+ arguments blocks
where
fun_extra_bits =
[packHalfWordsCLit fun_type fun_arity] ++
- srt_label ++
case pap_bitmap of
ArgGen liveness ->
+ (if null srt_label then [mkIntCLit 0] else srt_label) ++
[makeRelativeRefTo info_label $ mkLivenessCLit liveness,
- makeRelativeRefTo info_label (CmmLabel slow_entry)]
- _ -> []
+ makeRelativeRefTo info_label slow_entry]
+ _ -> srt_label
std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
info_label = entryLblToInfoLbl entry_label
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ (srt_label, srt_bitmap) = mkSRTLit info_label srt
layout = packHalfWordsCLit ptrs nptrs
+ -- | A constructor.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ConstrInfo (ptrs, nptrs) con_tag descr) ->
- mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info [con_name] entry_label
+ arguments blocks
where
std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
info_label = entryLblToInfoLbl entry_label
con_name = makeRelativeRefTo info_label descr
layout = packHalfWordsCLit ptrs nptrs
+ -- | A thunk.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ThunkInfo (ptrs, nptrs) srt) ->
- mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info srt_label entry_label
+ arguments blocks
where
std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
info_label = entryLblToInfoLbl entry_label
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ (srt_label, srt_bitmap) = mkSRTLit info_label srt
layout = packHalfWordsCLit ptrs nptrs
+ -- | A selector thunk.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ThunkSelectorInfo offset srt) ->
- mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
+ arguments blocks
where
- std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset)
+ std_info = mkStdInfoTable ty_prof cl_prof type_tag 0 (mkWordCLit offset)
info_label = entryLblToInfoLbl entry_label
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ -- A continuation/return-point.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
liveness_data ++
- mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info srt_label entry_label
+ arguments blocks
where
- std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit
+ std_info = mkStdInfoTable ty_prof cl_prof maybe_big_type_tag srt_bitmap
+ (makeRelativeRefTo info_label liveness_lit)
info_label = entryLblToInfoLbl entry_label
- (liveness_lit, liveness_data) = mkLiveness uniq stack_layout
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ (liveness_lit, liveness_data, liveness_tag) =
+ mkLiveness uniq stack_layout
+ maybe_big_type_tag = if type_tag == rET_SMALL
+ then liveness_tag
+ else type_tag
+ (srt_label, srt_bitmap) = mkSRTLit info_label srt
+-- Handle the differences between tables-next-to-code
+-- and not tables-next-to-code
+mkInfoTableAndCode :: CLabel
+ -> [CmmLit]
+ -> [CmmLit]
+ -> CLabel
+ -> CmmFormals
+ -> [CmmBasicBlock]
+ -> [RawCmmTop]
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
- = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks]
+ = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
+ entry_lbl args blocks]
| null blocks -- No actual code; only the info table is significant
= -- Use a zero place-holder in place of the
[mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits),
CmmProc [] entry_lbl args blocks]
+mkSRTLit :: CLabel
+ -> C_SRT
+ -> ([CmmLit], -- srt_label
+ StgHalfWord) -- srt_bitmap
+mkSRTLit info_label NoC_SRT = ([], 0)
+mkSRTLit info_label (C_SRT lbl off bitmap) =
+ ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
+
+-------------------------------------------------------------------------
+--
+-- Build a liveness mask for the stack layout
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+-- - pointer variables (bound in the environment)
+-- - non-pointer variables (bound in the environment)
+-- - free slots (recorded in the stack free list)
+-- - non-pointer data slots (recorded in the stack free list)
+--
+-- The first two are represented with a 'Just' of a 'LocalReg'.
+-- The last two with one or more 'Nothing' constructors.
+-- Each 'Nothing' represents one used word.
+--
+-- The head of the stack layout is the top of the stack and
+-- the least-significant bit.
+
-- TODO: refactor to use utility functions
-mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt])
-mkLiveness uniq live
- = if length live > mAX_SMALL_BITMAP_SIZE
- then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word
- else (mkWordCLit small_liveness, []) -- fits in one word
+-- TODO: combine with CgCallConv.mkLiveness (see comment there)
+mkLiveness :: Unique
+ -> [Maybe LocalReg]
+ -> (CmmLit, -- ^ The bitmap (literal value or label)
+ [RawCmmTop], -- ^ Large bitmap CmmData if needed
+ ClosureTypeTag) -- ^ rET_SMALL or rET_BIG
+mkLiveness uniq live =
+ if length bits > mAX_SMALL_BITMAP_SIZE
+ -- does not fit in one word
+ then (CmmLabel big_liveness, [data_lits], rET_BIG)
+ -- fits in one word
+ else (mkWordCLit small_liveness, [], rET_SMALL)
where
- size = length live
+ mkBits [] = []
+ mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
+ sizeW = case reg of
+ Nothing -> 1
+ Just r -> machRepByteWidth (localRegRep r) `quot` wORD_SIZE
+ bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
- bits = mkBitmap (map is_non_ptr live)
is_non_ptr Nothing = True
- is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True
- is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False
+ is_non_ptr (Just reg) =
+ case localRegGCFollow reg of
+ KindNonPtr -> True
+ KindPtr -> False
- big_liveness = mkBitmapLabel uniq
- data_lits = mkRODataLits big_liveness lits
- lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits
-
- small_liveness =
- fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
- small_bits = case bits of
+ bits :: [Bool]
+ bits = mkBits live
+
+ bitmap :: Bitmap
+ bitmap = mkBitmap bits
+
+ small_bitmap = case bitmap of
[] -> 0
[b] -> fromIntegral b
_ -> panic "mkLiveness"
+ small_liveness =
+ fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
+
+ big_liveness = mkBitmapLabel uniq
+ lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
+ data_lits = mkRODataLits big_liveness lits
+
+-------------------------------------------------------------------------
+--
+-- Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table. This part of the info table
+-- corresponds to the StgInfoTable type defined in InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+ :: CmmLit -- closure type descr (profiling)
+ -> CmmLit -- closure descr (profiling)
+ -> StgHalfWord -- closure type
+ -> StgHalfWord -- SRT length
+ -> CmmLit -- layout field
+ -> [CmmLit]
+
+mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
+ = -- Parallel revertible-black hole field
+ prof_info
+ -- Ticky info (none at present)
+ -- Debug info (none at present)
+ ++ [layout_lit, type_lit]
+
+ where
+ prof_info
+ | opt_SccProfilingOn = [type_descr, closure_descr]
+ | otherwise = []
+
+ type_lit = packHalfWordsCLit cl_type srt_len
projects / ghc-hetmet.git / blobdiff