module GHC.Cmm.Info (
mkEmptyContInfoTable,
cmmToRawCmm,
srtEscape,
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.Data.Maybe
import GHC.Driver.Session
import GHC.Utils.Error (withTimingSilent)
import GHC.Utils.Panic
import GHC.Types.Unique.Supply
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 :: DynFlags -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i'
; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl])
do_one uniqs cmm =
withTimingSilent dflags (text "Cmm -> Raw Cmm")
forceRes $
case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
(b,uniqs') -> return (uniqs',b)
; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)
}
where forceRes (uniqs, rawcmms) =
uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms
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 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` bITMAP_BITS_SHIFT dflags)
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)
wordAligned :: DynFlags -> CmmExpr -> CmmExpr
wordAligned dflags e
| gopt Opt_AlignmentSanitisation dflags
= CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]
| otherwise
= e
where platform = targetPlatform dflags
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
closureInfoPtr dflags e =
CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags))
entryCode :: Platform -> CmmExpr -> CmmExpr
entryCode platform e =
if platformTablesNextToCode platform
then e
else CmmLoad e (bWord platform)
getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
getConstrTag dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
platform = targetPlatform dflags
cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
cmmGetClosureType dflags closure_ptr
= CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
platform = targetPlatform dflags
infoTable :: DynFlags -> CmmExpr -> CmmExpr
infoTable dflags info_ptr
| platformTablesNextToCode platform = cmmOffsetB platform info_ptr ( stdInfoTableSizeB dflags)
| otherwise = cmmOffsetW platform info_ptr 1
where platform = targetPlatform dflags
infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
infoTableConstrTag = infoTableSrtBitmap
infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
infoTableSrtBitmap dflags info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform)
where platform = targetPlatform dflags
infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
infoTableClosureType dflags info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform)
where platform = targetPlatform dflags
infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs dflags info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform)
where platform = targetPlatform dflags
infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs dflags info_tbl
= CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform)
where platform = targetPlatform dflags
funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
funInfoTable dflags info_ptr
| platformTablesNextToCode platform
= cmmOffsetB platform info_ptr ( stdInfoTableSizeB dflags sIZEOF_StgFunInfoExtraRev dflags)
| otherwise
= cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)
where
platform = targetPlatform dflags
funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
funInfoArity dflags iptr
= cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))
where
platform = targetPlatform dflags
fun_info = funInfoTable dflags iptr
rep = cmmBits (widthFromBytes rep_bytes)
tablesNextToCode = platformTablesNextToCode platform
(rep_bytes, offset)
| tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc
, oFFSET_StgFunInfoExtraRev_arity dflags )
| otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc
, oFFSET_StgFunInfoExtraFwd_arity dflags )
pc = platformConstants dflags
stdInfoTableSizeW :: DynFlags -> WordOff
stdInfoTableSizeW dflags
= fixedInfoTableSizeW
+ if sccProfilingEnabled dflags
then profInfoTableSizeW
else 0
fixedInfoTableSizeW :: WordOff
fixedInfoTableSizeW = 2
profInfoTableSizeW :: WordOff
profInfoTableSizeW = 2
maxStdInfoTableSizeW :: WordOff
maxStdInfoTableSizeW =
1
+ fixedInfoTableSizeW
+ profInfoTableSizeW
maxRetInfoTableSizeW :: WordOff
maxRetInfoTableSizeW =
maxStdInfoTableSizeW
+ 1
stdInfoTableSizeB :: DynFlags -> ByteOff
stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform
where platform = targetPlatform dflags
stdSrtBitmapOffset :: DynFlags -> ByteOff
stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags halfWordSize platform
where platform = targetPlatform dflags
stdClosureTypeOffset :: DynFlags -> ByteOff
stdClosureTypeOffset dflags = stdInfoTableSizeB dflags platformWordSizeInBytes platform
where platform = targetPlatform dflags
stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
stdPtrsOffset dflags = stdInfoTableSizeB dflags 2 * platformWordSizeInBytes platform
where platform = targetPlatform dflags
stdNonPtrsOffset dflags = stdInfoTableSizeB dflags 2 * platformWordSizeInBytes platform + halfWordSize platform
where platform = targetPlatform dflags
conInfoTableSizeB :: DynFlags -> Int
conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform
where platform = targetPlatform dflags