X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmInfo.hs;h=438f1227349c7009e76904ae672784c8e935c8a7;hp=80c892f96ae0ecbd047aa0f6f15177837a1e1fcb;hb=e6243a818496aad82b6f47511d3bd9bc800f747d;hpb=a91ec5663d1fe3b8198896b93df84abf6471ee30 diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 80c892f..438f122 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,5 +1,15 @@ +{-# 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 CmmInfo ( - mkInfoTable + emptyContInfoTable, + cmmToRawCmm, + mkInfoTable, + mkBareInfoTable ) where #include "HsVersions.h" @@ -14,113 +24,275 @@ import ClosureInfo import CgInfoTbls import CgCallConv import CgUtils +import SMRep +import ZipCfgCmmRep import Constants +import Outputable import StaticFlags import Unique +import UniqSupply import Panic import Data.Bits +-- When we split at proc points, we need an empty info table. +emptyContInfoTable :: CmmInfo +emptyContInfoTable = + CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL + (ContInfo [] NoC_SRT)) + where zero = CmmInt 0 wordWidth + +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) = +mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = case info of - CmmNonInfo -> [CmmProc [] entry_label arguments blocks] - 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 - where - fun_extra_bits = - [packHalfWordsCLit fun_type fun_arity] ++ - srt_label ++ - case pap_bitmap of + -- Code without an info table. Easy. + CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks] + + CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> + let info_label = entryLblToInfoLbl entry_label + ty_prof' = makeRelativeRefTo info_label ty_prof + cl_prof' = makeRelativeRefTo info_label cl_prof + in case type_info of + -- A function entry point. + FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry -> + mkInfoTableAndCode info_label std_info fun_extra_bits entry_label + arguments blocks + where + fun_type = argDescrType pap_bitmap + fun_extra_bits = + [packHalfWordsCLit fun_type fun_arity] ++ + 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)] - _ -> [] - 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) - layout = packHalfWordsCLit ptrs nptrs - - 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 - where - std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout - info_label = entryLblToInfoLbl entry_label - con_name = makeRelativeRefTo info_label (CmmLabel descr) - layout = packHalfWordsCLit ptrs nptrs - - CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag - (ThunkInfo (ptrs, nptrs) srt) -> - 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) - layout = packHalfWordsCLit ptrs nptrs - - 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 - where - std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap 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) + makeRelativeRefTo info_label slow_entry] + _ -> srt_label + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap + layout + (srt_label, srt_bitmap) = mkSRTLit info_label srt + layout = packHalfWordsCLit ptrs nptrs + + -- A constructor. + ConstrInfo (ptrs, nptrs) con_tag descr -> + mkInfoTableAndCode info_label std_info [con_name] entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout + con_name = makeRelativeRefTo info_label descr + layout = packHalfWordsCLit ptrs nptrs + -- A thunk. + ThunkInfo (ptrs, nptrs) srt -> + mkInfoTableAndCode info_label std_info srt_label entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout + (srt_label, srt_bitmap) = mkSRTLit info_label srt + layout = packHalfWordsCLit ptrs nptrs + + -- A selector thunk. + ThunkSelectorInfo offset srt -> + mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset) + + -- A continuation/return-point. + ContInfo stack_layout srt -> + liveness_data ++ + mkInfoTableAndCode info_label std_info srt_label entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap + (makeRelativeRefTo info_label liveness_lit) + (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 +-- Generate a bare info table, not attached to any procedure. +mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ] +mkBareInfoTable lbl uniq info = + case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of + [CmmProc d _ _ _] -> + ASSERT (tablesNextToCode) + [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])] + [CmmData d s] -> [CmmData d s] + _ -> panic "mkBareInfoTable expected to produce only data" + + +-- Handle the differences between tables-next-to-code +-- and not tables-next-to-code +mkInfoTableAndCode :: CLabel + -> [CmmLit] + -> [CmmLit] + -> CLabel + -> CmmFormals + -> ListGraph CmmStmt + -> [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 + | ListGraph [] <- blocks -- No code; only the info table is significant = -- Use a zero place-holder in place of the -- entry-label in the info table [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)] | otherwise -- Separately emit info table (with the function entry = -- point as first entry) and the entry code - [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits), - CmmProc [] entry_lbl args blocks] + [CmmProc [] entry_lbl args blocks, + mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)] + +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, [RawCmmTop], ClosureTypeTag) + -- ^ Returns: + -- 1. The bitmap (literal value or label) + -- 2. Large bitmap CmmData if needed + -- 3. 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 -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1) + `quot` wORD_SIZE + -- number of words, rounded up + 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 Nothing = True + is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg) - 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 +