module GHC.Cmm.Info (
mkEmptyContInfoTable,
cmmToRawCmm,
srtEscape,
PtrOpts (..),
closureInfoPtr,
entryCode,
getConstrTag,
cmmGetClosureType,
infoTable,
infoTableConstrTag,
infoTableSrtBitmap,
infoTableClosureType,
infoTablePtrs,
infoTableNonPtrs,
funInfoTable,
funInfoArity,
stdInfoTableSizeW,
fixedInfoTableSizeW,
profInfoTableSizeW,
maxStdInfoTableSizeW,
maxRetInfoTableSizeW,
stdInfoTableSizeB,
conInfoTableSizeB,
stdSrtBitmapOffset,
stdClosureTypeOffset,
stdPtrsOffset, stdNonPtrsOffset,
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
import GHC.Data.Bitmap
import GHC.Data.Stream (Stream)
import qualified GHC.Data.Stream as Stream
import GHC.Cmm.Dataflow.Collections
import GHC.Platform
import GHC.Platform.Profile
import GHC.Data.Maybe
import GHC.Driver.Session
import GHC.Utils.Error (withTimingSilent)
import GHC.Utils.Panic
import GHC.Types.Unique.Supply
import GHC.Utils.Logger
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
import Data.ByteString (ByteString)
import Data.Bits
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
mkEmptyContInfoTable info_lbl
= CmmInfoTable { cit_lbl = info_lbl
, cit_rep = mkStackRep []
, cit_prof = NoProfilingInfo
, cit_srt = Nothing
, cit_clo = Nothing }
cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm logger dflags cmms
= do {
; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]
do_one cmm = do
uniqs <- mkSplitUniqSupply 'i'
withTimingSilent logger dflags (text "Cmm -> Raw Cmm")
(\x -> seqList x ())
(return $ initUs_ uniqs $ concatMapM (mkInfoTable dflags) cmm)
; return (Stream.mapM do_one cmms)
}
mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]
mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
| not (platformTablesNextToCode (targetPlatform dflags))
= case topInfoTable proc of
Nothing ->
return [CmmProc mapEmpty entry_lbl live blocks]
Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags info Nothing
let
rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits
return (top_decls ++
[CmmProc mapEmpty entry_lbl live blocks,
mkRODataLits info_lbl
(CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
| otherwise
= do
(top_declss, raw_infos) <-
unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
return (concat top_declss ++
[CmmProc (mapFromList raw_infos) entry_lbl live blocks])
where
platform = targetPlatform dflags
do_one_info (lbl,itbl) = do
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags itbl Nothing
let
info_lbl = cit_lbl itbl
rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info
rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits
return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info))
type InfoTableContents = ( [CmmLit]
, [CmmLit] )
mkInfoTableContents :: DynFlags
-> CmmInfoTable
-> Maybe Int
-> UniqSM ([RawCmmDecl],
InfoTableContents)
mkInfoTableContents dflags
info@(CmmInfoTable { cit_lbl = info_lbl
, cit_rep = smrep
, cit_prof = prof
, cit_srt = srt })
mb_rts_tag
| RTSRep rts_tag rep <- smrep
= mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
| StackRep frame <- smrep
= do { (prof_lits, prof_data) <- mkProfLits platform prof
; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
; let
std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
rts_tag | Just tag <- mb_rts_tag = tag
| null liveness_data = rET_SMALL
| otherwise = rET_BIG
; return (prof_data ++ liveness_data, (std_info, srt_label)) }
| HeapRep _ ptrs nonptrs closure_type <- smrep
= do { let layout = packIntsCLit platform ptrs nonptrs
; (prof_lits, prof_data) <- mkProfLits platform prof
; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
; let std_info = mkStdInfoTable dflags prof_lits
(mb_rts_tag `orElse` rtsClosureType smrep)
(mb_srt_field `orElse` srt_bitmap)
(mb_layout `orElse` layout)
; return (prof_data ++ ct_data, (std_info, extra_bits)) }
where
platform = targetPlatform dflags
mk_pieces :: ClosureTypeInfo -> [CmmLit]
-> UniqSM ( Maybe CmmLit
, Maybe CmmLit
, [CmmLit]
, [RawCmmDecl])
mk_pieces (Constr con_tag con_descr) _no_srt
= do { (descr_lit, decl) <- newStringLit con_descr
; return ( Just (CmmInt (fromIntegral con_tag)
(halfWordWidth platform))
, Nothing, [descr_lit], [decl]) }
mk_pieces Thunk srt_label
= return (Nothing, Nothing, srt_label, [])
mk_pieces (ThunkSelector offset) _no_srt
= return (Just (CmmInt 0 (halfWordWidth platform)),
Just (mkWordCLit platform (fromIntegral offset)), [], [])
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
= do { let extra_bits = packIntsCLit platform fun_type arity : srt_label
; return (Nothing, Nothing, extra_bits, []) }
mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
= do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
; let fun_type | null liveness_data = aRG_GEN
| otherwise = aRG_GEN_BIG
extra_bits = [ packIntsCLit platform fun_type arity ]
++ (if inlineSRT platform then [] else [ srt_lit ])
++ [ liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) }
where
slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)
srt_lit = case srt_label of
[] -> mkIntCLit platform 0
(lit:_rest) -> ASSERT( null _rest ) lit
mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
mkInfoTableContents _ _ _ = panic "mkInfoTableContents"
packIntsCLit :: Platform -> Int -> Int -> CmmLit
packIntsCLit platform a b = packHalfWordsCLit platform
(toStgHalfWord platform (fromIntegral a))
(toStgHalfWord platform (fromIntegral b))
mkSRTLit :: Platform
-> CLabel
-> Maybe CLabel
-> ([CmmLit],
CmmLit)
mkSRTLit platform info_lbl (Just lbl)
| inlineSRT platform
= ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth platform))
mkSRTLit platform _ Nothing = ([], CmmInt 0 (halfWordWidth platform))
mkSRTLit platform _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth platform))
inlineSRT :: Platform -> Bool
inlineSRT platform = platformArch platform == ArchX86_64
&& platformTablesNextToCode platform
makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo platform info_lbl lit
= if platformTablesNextToCode platform
then case lit of
CmmLabel lbl -> CmmLabelDiffOff lbl info_lbl 0 (wordWidth platform)
CmmLabelOff lbl off -> CmmLabelDiffOff lbl info_lbl off (wordWidth platform)
_ -> lit
else lit
mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
mkLivenessBits dflags liveness
| n_bits > mAX_SMALL_BITMAP_SIZE platform
= do { uniq <- getUniqueM
; let bitmap_lbl = mkBitmapLabel uniq
; return (CmmLabel bitmap_lbl,
[mkRODataLits bitmap_lbl lits]) }
| otherwise
= return (mkStgWordCLit platform bitmap_word, [])
where
platform = targetPlatform dflags
n_bits = length liveness
bitmap :: Bitmap
bitmap = mkBitmap platform liveness
small_bitmap = case bitmap of
[] -> toStgWord platform 0
[b] -> b
_ -> panic "mkLiveness"
bitmap_word = toStgWord platform (fromIntegral n_bits)
.|. (small_bitmap `shiftL` pc_BITMAP_BITS_SHIFT (platformConstants platform))
lits = mkWordCLit platform (fromIntegral n_bits)
: map (mkStgWordCLit platform) bitmap
mkStdInfoTable
:: DynFlags
-> (CmmLit,CmmLit)
-> Int
-> CmmLit
-> CmmLit
-> [CmmLit]
mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
=
prof_info
++ [layout_lit, tag, srt]
where
platform = targetPlatform dflags
prof_info
| sccProfilingEnabled dflags = [type_descr, closure_descr]
| otherwise = []
tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)
mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), [])
mkProfLits _ (ProfilingInfo td cd)
= do { (td_lit, td_decl) <- newStringLit td
; (cd_lit, cd_decl) <- newStringLit cd
; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit bytes
= do { uniq <- getUniqueM
; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
srtEscape :: Platform -> StgHalfWord
srtEscape platform = toStgHalfWord platform (1)
data PtrOpts = PtrOpts
{ po_profile :: !Profile
, po_align_check :: !Bool
}
wordAligned :: PtrOpts -> CmmExpr -> CmmExpr
wordAligned opts e
| po_align_check opts
= CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]
| otherwise
= e
where platform = profilePlatform (po_profile opts)
closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr
closureInfoPtr opts e =
CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts)))
entryCode :: Platform -> CmmExpr -> CmmExpr
entryCode platform e =
if platformTablesNextToCode platform
then e
else CmmLoad e (bWord platform)
getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr
getConstrTag opts closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table]
where
info_table = infoTable profile (closureInfoPtr opts closure_ptr)
platform = profilePlatform profile
profile = po_profile opts
cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr
cmmGetClosureType opts closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table]
where
info_table = infoTable profile (closureInfoPtr opts closure_ptr)
platform = profilePlatform profile
profile = po_profile opts
infoTable :: Profile -> CmmExpr -> CmmExpr
infoTable profile info_ptr
| platformTablesNextToCode platform = cmmOffsetB platform info_ptr ( stdInfoTableSizeB profile)
| otherwise = cmmOffsetW platform info_ptr 1
where platform = profilePlatform profile
infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr
infoTableConstrTag = infoTableSrtBitmap
infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr
infoTableSrtBitmap profile info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)
where platform = profilePlatform profile
infoTableClosureType :: Profile -> CmmExpr -> CmmExpr
infoTableClosureType profile info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)
where platform = profilePlatform profile
infoTablePtrs :: Profile -> CmmExpr -> CmmExpr
infoTablePtrs profile info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)
where platform = profilePlatform profile
infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr
infoTableNonPtrs profile info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)
where platform = profilePlatform profile
funInfoTable :: Profile -> CmmExpr -> CmmExpr
funInfoTable profile info_ptr
| platformTablesNextToCode platform
= cmmOffsetB platform info_ptr ( stdInfoTableSizeB profile pc_SIZEOF_StgFunInfoExtraRev (platformConstants platform))
| otherwise
= cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW profile)
where
platform = profilePlatform profile
funInfoArity :: Profile -> CmmExpr -> CmmExpr
funInfoArity profile iptr
= cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))
where
platform = profilePlatform profile
fun_info = funInfoTable profile iptr
rep = cmmBits (widthFromBytes rep_bytes)
tablesNextToCode = platformTablesNextToCode platform
(rep_bytes, offset)
| tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc
, pc_OFFSET_StgFunInfoExtraRev_arity pc )
| otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc
, pc_OFFSET_StgFunInfoExtraFwd_arity pc )
pc = platformConstants platform
stdInfoTableSizeW :: Profile -> WordOff
stdInfoTableSizeW profile
= fixedInfoTableSizeW
+ if profileIsProfiling profile
then profInfoTableSizeW
else 0
fixedInfoTableSizeW :: WordOff
fixedInfoTableSizeW = 2
profInfoTableSizeW :: WordOff
profInfoTableSizeW = 2
maxStdInfoTableSizeW :: WordOff
maxStdInfoTableSizeW =
1
+ fixedInfoTableSizeW
+ profInfoTableSizeW
maxRetInfoTableSizeW :: WordOff
maxRetInfoTableSizeW =
maxStdInfoTableSizeW
+ 1
stdInfoTableSizeB :: Profile -> ByteOff
stdInfoTableSizeB profile = stdInfoTableSizeW profile * profileWordSizeInBytes profile
stdSrtBitmapOffset :: Profile -> ByteOff
stdSrtBitmapOffset profile = stdInfoTableSizeB profile halfWordSize (profilePlatform profile)
stdClosureTypeOffset :: Profile -> ByteOff
stdClosureTypeOffset profile = stdInfoTableSizeB profile profileWordSizeInBytes profile
stdPtrsOffset :: Profile -> ByteOff
stdPtrsOffset profile = stdInfoTableSizeB profile 2 * profileWordSizeInBytes profile
stdNonPtrsOffset :: Profile -> ByteOff
stdNonPtrsOffset profile = stdInfoTableSizeB profile 2 * profileWordSizeInBytes profile
+ halfWordSize (profilePlatform profile)
conInfoTableSizeB :: Profile -> Int
conInfoTableSizeB profile = stdInfoTableSizeB profile + profileWordSizeInBytes profile