module CmmInfo (
emptyContInfoTable,
cmmToRawCmm,
mkInfoTable,
mkBareInfoTable
) where
#include "HsVersions.h"
import Cmm
import CmmUtils
import CLabel
import Bitmap
import ClosureInfo
import CgInfoTbls
import CgCallConv
import CgUtils
import SMRep
import ZipCfgCmmRep
import Constants
import Panic
import StaticFlags
import Unique
import UniqSupply
import Data.Bits
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
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable _ (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
case info of
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
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
(srt_label, srt_bitmap) = mkSRTLit info_label srt
layout = packHalfWordsCLit ptrs nptrs
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
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
ThunkSelectorInfo offset _srt ->
mkInfoTableAndCode info_label std_info [] entry_label
arguments blocks
where
std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset)
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
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"
mkInfoTableAndCode :: CLabel
-> [CmmLit]
-> [CmmLit]
-> CLabel
-> CmmFormals
-> ListGraph CmmStmt
-> [RawCmmTop]
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
| tablesNextToCode
= [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
entry_lbl args blocks]
| ListGraph [] <- blocks
=
[mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]
| otherwise
=
[CmmProc [] entry_lbl args blocks,
mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
mkSRTLit :: CLabel
-> C_SRT
-> ([CmmLit],
StgHalfWord)
mkSRTLit _ NoC_SRT = ([], 0)
mkSRTLit info_label (C_SRT lbl off bitmap) =
([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
mkLiveness :: Unique
-> [Maybe LocalReg]
-> (CmmLit, [RawCmmTop], ClosureTypeTag)
mkLiveness uniq live =
if length bits > mAX_SMALL_BITMAP_SIZE
then (CmmLabel big_liveness, [data_lits], rET_BIG)
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 -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE 1)
`quot` wORD_SIZE
bits = repeat $ is_non_ptr reg
is_non_ptr Nothing = True
is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
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
mkStdInfoTable
:: CmmLit
-> CmmLit
-> StgHalfWord
-> StgHalfWord
-> CmmLit
-> [CmmLit]
mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
=
prof_info
++ [layout_lit, type_lit]
where
prof_info
| opt_SccProfilingOn = [type_descr, closure_descr]
| otherwise = []
type_lit = packHalfWordsCLit cl_type srt_len