X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmInfo.hs;h=3f458b53518f199912a59c505792c0e4844120a9;hp=ab46f1e58deddc96ab7f5463869814983f10d375;hb=f47653a986cd329dc9159906432f2ed7819a4043;hpb=1f46671fe24c7155ee64091b71b77dd66909e7a0 diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index ab46f1e..3f458b5 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,4 +1,5 @@ module CmmInfo ( + cmmToRawCmm, mkInfoTable ) where @@ -6,102 +7,155 @@ module CmmInfo ( 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 +-- +-- +-- +-- +-- Without tablesNextToCode, the layout of an info table is +-- +-- +-- +-- +-- See includes/InfoTables.h +-- +-- For return-points these are as follows +-- +-- Tables next to code: +-- +-- +-- +-- ret-addr --> +-- +-- Not tables-next-to-code: +-- +-- ret-addr --> +-- +-- +-- +-- * 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 @@ -113,27 +167,108 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks [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