module CmmInfo (
+ emptyContInfoTable,
cmmToRawCmm,
- mkInfoTable
+ mkInfoTable,
+ mkBareInfoTable
) where
#include "HsVersions.h"
import Cmm
import CmmUtils
-import PprCmm
import CLabel
-import MachOp
import Bitmap
import ClosureInfo
import CgCallConv
import CgUtils
import SMRep
+import ZipCfgCmmRep
import Constants
+import Panic
import StaticFlags
-import DynFlags
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'
-- <normal forward rest of StgInfoTable>
-- <forward variable part>
--
--- See includes/InfoTables.h
+-- See includes/rts/storage/InfoTables.h
--
-- For return-points these are as follows
--
-- * 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 _ (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
case info of
- -- | Code without an info table. Easy.
+ -- Code without an info table. Easy.
CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
- -- | A function entry point.
- CmmInfoTable (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] ++
- case pap_bitmap of
+ 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 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) = mkSRTLit info_label srt
- layout = packHalfWordsCLit ptrs nptrs
-
- -- | A constructor.
- CmmInfoTable (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 descr
- layout = packHalfWordsCLit ptrs nptrs
-
- -- | A thunk.
- CmmInfoTable (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) = mkSRTLit info_label srt
- layout = packHalfWordsCLit ptrs nptrs
-
- -- | A selector thunk.
- CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
- (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)
- info_label = entryLblToInfoLbl entry_label
-
- -- A continuation/return-point.
- CmmInfoTable (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 maybe_big_type_tag srt_bitmap
- (makeRelativeRefTo info_label liveness_lit)
- info_label = entryLblToInfoLbl entry_label
- (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
+ 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
-> [CmmLit]
-> CLabel
-> CmmFormals
- -> [CmmBasicBlock]
+ -> 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]
- | 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)]
-> C_SRT
-> ([CmmLit], -- srt_label
StgHalfWord) -- srt_bitmap
-mkSRTLit info_label NoC_SRT = ([], 0)
+mkSRTLit _ NoC_SRT = ([], 0)
mkSRTLit info_label (C_SRT lbl off bitmap) =
([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
-- 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
+ -> (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)
+ else (mkWordCLit small_liveness, [], rET_SMALL)
where
mkBits [] = []
mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
sizeW = case reg of
Nothing -> 1
- Just r -> (machRepByteWidth (localRegRep r) + wORD_SIZE - 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
- is_non_ptr Nothing = True
- is_non_ptr (Just reg) =
- case localRegGCFollow reg of
- KindNonPtr -> True
- KindPtr -> False
+ is_non_ptr Nothing = True
+ is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
bits :: [Bool]
bits = mkBits live
| otherwise = []
type_lit = packHalfWordsCLit cl_type srt_len
+
projects / ghc-hetmet.git / blobdiff