module GHC.Cmm.Info (
  mkEmptyContInfoTable,
  cmmToRawCmm,
  srtEscape,

  -- info table accessors
  closureInfoPtr,
  entryCode,
  getConstrTag,
  cmmGetClosureType,
  infoTable,
  infoTableConstrTag,
  infoTableSrtBitmap,
  infoTableClosureType,
  infoTablePtrs,
  infoTableNonPtrs,
  funInfoTable,
  funInfoArity,

  -- info table sizes and offsets
  stdInfoTableSizeW,
  fixedInfoTableSizeW,
  profInfoTableSizeW,
  maxStdInfoTableSizeW,
  maxRetInfoTableSizeW,
  stdInfoTableSizeB,
  conInfoTableSizeB,
  stdSrtBitmapOffset,
  stdClosureTypeOffset,
  stdPtrsOffset, stdNonPtrsOffset,
) where

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.Utils.Error (withTimingSilent)
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
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)

-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
mkEmptyContInfoTable CLabel
info_lbl
  = CmmInfoTable { cit_lbl :: CLabel
cit_lbl  = CLabel
info_lbl
                 , cit_rep :: SMRep
cit_rep  = [Bool] -> SMRep
mkStackRep []
                 , cit_prof :: ProfilingInfo
cit_prof = ProfilingInfo
NoProfilingInfo
                 , cit_srt :: Maybe CLabel
cit_srt  = Maybe CLabel
forall a. Maybe a
Nothing
                 , cit_clo :: Maybe (Id, CostCentreStack)
cit_clo  = Maybe (Id, CostCentreStack)
forall a. Maybe a
Nothing }

cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a
            -> IO (Stream IO RawCmmGroup a)
cmmToRawCmm :: forall a.
Logger
-> Profile
-> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm Logger
logger Profile
profile Stream IO CmmGroupSRTs a
cmms
  = do {
       ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]
             do_one :: CmmGroupSRTs -> IO RawCmmGroup
do_one CmmGroupSRTs
cmm = do
               UniqSupply
uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'i'
               -- NB. strictness fixes a space leak.  DO NOT REMOVE.
               Logger
-> SDoc -> (RawCmmGroup -> ()) -> IO RawCmmGroup -> IO RawCmmGroup
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger (String -> SDoc
text String
"Cmm -> Raw Cmm") (\RawCmmGroup
x -> RawCmmGroup -> () -> ()
forall a b. [a] -> b -> b
seqList RawCmmGroup
x ())
                  -- TODO: It might be better to make `mkInfoTable` run in
                  -- IO as well so we don't have to pass around
                  -- a UniqSupply (see #16843)
                 (RawCmmGroup -> IO RawCmmGroup
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmGroup -> IO RawCmmGroup) -> RawCmmGroup -> IO RawCmmGroup
forall a b. (a -> b) -> a -> b
$ UniqSupply -> UniqSM RawCmmGroup -> RawCmmGroup
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
uniqs (UniqSM RawCmmGroup -> RawCmmGroup)
-> UniqSM RawCmmGroup -> RawCmmGroup
forall a b. (a -> b) -> a -> b
$ (CmmDeclSRTs -> UniqSM RawCmmGroup)
-> CmmGroupSRTs -> UniqSM RawCmmGroup
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Profile -> CmmDeclSRTs -> UniqSM RawCmmGroup
mkInfoTable Profile
profile) CmmGroupSRTs
cmm)
       ; Stream IO RawCmmGroup a -> IO (Stream IO RawCmmGroup a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CmmGroupSRTs -> IO RawCmmGroup)
-> Stream IO CmmGroupSRTs a -> Stream IO RawCmmGroup a
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM CmmGroupSRTs -> IO RawCmmGroup
do_one Stream IO CmmGroupSRTs a
cmms)
       }


-- 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
--      <reversed variable part>
--      <normal forward StgInfoTable, but without
--              an entry point at the front>
--      <code>
--
-- Without tablesNextToCode, the layout of an info table is
--      <entry label>
--      <normal forward rest of StgInfoTable>
--      <forward variable part>
--
--      See rts/include/rts/storage/InfoTables.h
--
-- For return-points these are as follows
--
-- Tables next to code:
--
--                      <srt slot>
--                      <standard info table>
--      ret-addr -->    <entry code (if any)>
--
-- Not tables-next-to-code:
--
--      ret-addr -->    <ptr to entry code>
--                      <standard info table>
--                      <srt slot>
--
--  * The SRT slot is only there if there is SRT info to record

mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl]
mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM RawCmmGroup
mkInfoTable Profile
_ (CmmData Section
sec RawCmmStatics
dat) = RawCmmGroup -> UniqSM RawCmmGroup
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Section
-> RawCmmStatics
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
dat]

mkInfoTable Profile
profile proc :: CmmDeclSRTs
proc@(CmmProc CmmTopInfo
infos CLabel
entry_lbl [GlobalReg]
live CmmGraph
blocks)
  --
  -- in the non-tables-next-to-code case, procs can have at most a
  -- single info table associated with the entry label of the proc.
  --
  | Bool -> Bool
not (Platform -> Bool
platformTablesNextToCode Platform
platform)
  = case CmmDeclSRTs -> Maybe CmmInfoTable
forall a (n :: Extensibility -> Extensibility -> *).
GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable CmmDeclSRTs
proc of   --  must be at most one
      -- no info table
      Maybe CmmInfoTable
Nothing ->
         RawCmmGroup -> UniqSM RawCmmGroup
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty CLabel
entry_lbl [GlobalReg]
live CmmGraph
blocks]

      Just info :: CmmInfoTable
info@CmmInfoTable { cit_lbl :: CmmInfoTable -> CLabel
cit_lbl = CLabel
info_lbl } -> do
        (RawCmmGroup
top_decls, ([CmmLit]
std_info, [CmmLit]
extra_bits)) <-
             Profile
-> CmmInfoTable
-> Maybe WordOff
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents Profile
profile CmmInfoTable
info Maybe WordOff
forall a. Maybe a
Nothing
        let
          rel_std_info :: [CmmLit]
rel_std_info   = (CmmLit -> CmmLit) -> [CmmLit] -> [CmmLit]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo Platform
platform CLabel
info_lbl) [CmmLit]
std_info
          rel_extra_bits :: [CmmLit]
rel_extra_bits = (CmmLit -> CmmLit) -> [CmmLit] -> [CmmLit]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo Platform
platform CLabel
info_lbl) [CmmLit]
extra_bits
        --
        -- Separately emit info table (with the function entry
        -- point as first entry) and the entry code
        --
        RawCmmGroup -> UniqSM RawCmmGroup
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmGroup
top_decls RawCmmGroup -> RawCmmGroup -> RawCmmGroup
forall a. [a] -> [a] -> [a]
++
                [LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
forall a. LabelMap a
forall (map :: * -> *) a. IsMap map => map a
mapEmpty CLabel
entry_lbl [GlobalReg]
live CmmGraph
blocks,
                 CLabel
-> [CmmLit]
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall (raw :: Bool) info stmt.
CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkRODataLits CLabel
info_lbl
                    (CLabel -> CmmLit
CmmLabel CLabel
entry_lbl CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
: [CmmLit]
rel_std_info [CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit]
rel_extra_bits)])

  --
  -- With tables-next-to-code, we can have many info tables,
  -- associated with some of the BlockIds of the proc.  For each info
  -- table we need to turn it into CmmStatics, and collect any new
  -- CmmDecls that arise from doing so.
  --
  | Bool
otherwise
  = do
    ([RawCmmGroup]
top_declss, [(Label, RawCmmStatics)]
raw_infos) <-
       [(RawCmmGroup, (Label, RawCmmStatics))]
-> ([RawCmmGroup], [(Label, RawCmmStatics)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(RawCmmGroup, (Label, RawCmmStatics))]
 -> ([RawCmmGroup], [(Label, RawCmmStatics)]))
-> UniqSM [(RawCmmGroup, (Label, RawCmmStatics))]
-> UniqSM ([RawCmmGroup], [(Label, RawCmmStatics)])
forall a b. (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((Label, CmmInfoTable)
 -> UniqSM (RawCmmGroup, (Label, RawCmmStatics)))
-> [(Label, CmmInfoTable)]
-> UniqSM [(RawCmmGroup, (Label, RawCmmStatics))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Label, CmmInfoTable)
-> UniqSM (RawCmmGroup, (Label, RawCmmStatics))
do_one_info (LabelMap CmmInfoTable -> [(KeyOf LabelMap, CmmInfoTable)]
forall a. LabelMap a -> [(KeyOf LabelMap, a)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
infos))
    RawCmmGroup -> UniqSM RawCmmGroup
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([RawCmmGroup] -> RawCmmGroup
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [RawCmmGroup]
top_declss RawCmmGroup -> RawCmmGroup -> RawCmmGroup
forall a. [a] -> [a] -> [a]
++
            [LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc ([(KeyOf LabelMap, RawCmmStatics)] -> LabelMap RawCmmStatics
forall a. [(KeyOf LabelMap, a)] -> LabelMap a
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(KeyOf LabelMap, RawCmmStatics)]
[(Label, RawCmmStatics)]
raw_infos) CLabel
entry_lbl [GlobalReg]
live CmmGraph
blocks])

  where
   platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
   do_one_info :: (Label, CmmInfoTable)
-> UniqSM (RawCmmGroup, (Label, RawCmmStatics))
do_one_info (Label
lbl,CmmInfoTable
itbl) = do
     (RawCmmGroup
top_decls, ([CmmLit]
std_info, [CmmLit]
extra_bits)) <-
         Profile
-> CmmInfoTable
-> Maybe WordOff
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents Profile
profile CmmInfoTable
itbl Maybe WordOff
forall a. Maybe a
Nothing
     let
        info_lbl :: CLabel
info_lbl = CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
itbl
        rel_std_info :: [CmmLit]
rel_std_info   = (CmmLit -> CmmLit) -> [CmmLit] -> [CmmLit]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo Platform
platform CLabel
info_lbl) [CmmLit]
std_info
        rel_extra_bits :: [CmmLit]
rel_extra_bits = (CmmLit -> CmmLit) -> [CmmLit] -> [CmmLit]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo Platform
platform CLabel
info_lbl) [CmmLit]
extra_bits
     --
     (RawCmmGroup, (Label, RawCmmStatics))
-> UniqSM (RawCmmGroup, (Label, RawCmmStatics))
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmGroup
top_decls, (Label
lbl, CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
info_lbl ([CmmStatic] -> RawCmmStatics) -> [CmmStatic] -> RawCmmStatics
forall a b. (a -> b) -> a -> b
$ (CmmLit -> CmmStatic) -> [CmmLit] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map CmmLit -> CmmStatic
CmmStaticLit ([CmmLit] -> [CmmStatic]) -> [CmmLit] -> [CmmStatic]
forall a b. (a -> b) -> a -> b
$
                              [CmmLit] -> [CmmLit]
forall a. [a] -> [a]
reverse [CmmLit]
rel_extra_bits [CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit]
rel_std_info))

-----------------------------------------------------
type InfoTableContents = ( [CmmLit]          -- The standard part
                         , [CmmLit] )        -- The "extra bits"
-- These Lits have *not* had mkRelativeTo applied to them

mkInfoTableContents :: Profile
                    -> CmmInfoTable
                    -> Maybe Int               -- Override default RTS type tag?
                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
                               InfoTableContents)       -- Info tbl + extra bits

mkInfoTableContents :: Profile
-> CmmInfoTable
-> Maybe WordOff
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents Profile
profile
                    info :: CmmInfoTable
info@(CmmInfoTable { cit_lbl :: CmmInfoTable -> CLabel
cit_lbl  = CLabel
info_lbl
                                       , cit_rep :: CmmInfoTable -> SMRep
cit_rep  = SMRep
smrep
                                       , cit_prof :: CmmInfoTable -> ProfilingInfo
cit_prof = ProfilingInfo
prof
                                       , cit_srt :: CmmInfoTable -> Maybe CLabel
cit_srt = Maybe CLabel
srt })
                    Maybe WordOff
mb_rts_tag
  | RTSRep WordOff
rts_tag SMRep
rep <- SMRep
smrep
  = Profile
-> CmmInfoTable
-> Maybe WordOff
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents Profile
profile CmmInfoTable
info{cit_rep :: SMRep
cit_rep = SMRep
rep} (WordOff -> Maybe WordOff
forall a. a -> Maybe a
Just WordOff
rts_tag)
    -- Completely override the rts_tag that mkInfoTableContents would
    -- otherwise compute, with the rts_tag stored in the RTSRep
    -- (which in turn came from a handwritten .cmm file)

  | StackRep [Bool]
frame <- SMRep
smrep
  = do { ((CmmLit, CmmLit)
prof_lits, RawCmmGroup
prof_data) <- Platform -> ProfilingInfo -> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
mkProfLits Platform
platform ProfilingInfo
prof
       ; let ([CmmLit]
srt_label, CmmLit
srt_bitmap) = Platform -> CLabel -> Maybe CLabel -> ([CmmLit], CmmLit)
mkSRTLit Platform
platform CLabel
info_lbl Maybe CLabel
srt
       ; (CmmLit
liveness_lit, RawCmmGroup
liveness_data) <- Platform -> [Bool] -> UniqSM (CmmLit, RawCmmGroup)
mkLivenessBits Platform
platform [Bool]
frame
       ; let
             std_info :: [CmmLit]
std_info = Profile
-> (CmmLit, CmmLit) -> WordOff -> CmmLit -> CmmLit -> [CmmLit]
mkStdInfoTable Profile
profile (CmmLit, CmmLit)
prof_lits WordOff
rts_tag CmmLit
srt_bitmap CmmLit
liveness_lit
             rts_tag :: WordOff
rts_tag | Just WordOff
tag <- Maybe WordOff
mb_rts_tag = WordOff
tag
                     | RawCmmGroup -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RawCmmGroup
liveness_data     = WordOff
rET_SMALL -- Fits in extra_bits
                     | Bool
otherwise              = WordOff
rET_BIG   -- Does not; extra_bits is
                                                          -- a label
       ; (RawCmmGroup, InfoTableContents)
-> UniqSM (RawCmmGroup, InfoTableContents)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmGroup
prof_data RawCmmGroup -> RawCmmGroup -> RawCmmGroup
forall a. [a] -> [a] -> [a]
++ RawCmmGroup
liveness_data, ([CmmLit]
std_info, [CmmLit]
srt_label)) }

  | HeapRep Bool
_ WordOff
ptrs WordOff
nonptrs ClosureTypeInfo
closure_type <- SMRep
smrep
  = do { let layout :: CmmLit
layout  = Platform -> WordOff -> WordOff -> CmmLit
packIntsCLit Platform
platform WordOff
ptrs WordOff
nonptrs
       ; ((CmmLit, CmmLit)
prof_lits, RawCmmGroup
prof_data) <- Platform -> ProfilingInfo -> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
mkProfLits Platform
platform ProfilingInfo
prof
       ; let ([CmmLit]
srt_label, CmmLit
srt_bitmap) = Platform -> CLabel -> Maybe CLabel -> ([CmmLit], CmmLit)
mkSRTLit Platform
platform CLabel
info_lbl Maybe CLabel
srt
       ; (Maybe CmmLit
mb_srt_field, Maybe CmmLit
mb_layout, [CmmLit]
extra_bits, RawCmmGroup
ct_data)
                                <- ClosureTypeInfo
-> [CmmLit]
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
mk_pieces ClosureTypeInfo
closure_type [CmmLit]
srt_label
       ; let std_info :: [CmmLit]
std_info = Profile
-> (CmmLit, CmmLit) -> WordOff -> CmmLit -> CmmLit -> [CmmLit]
mkStdInfoTable Profile
profile (CmmLit, CmmLit)
prof_lits
                                       (Maybe WordOff
mb_rts_tag   Maybe WordOff -> WordOff -> WordOff
forall a. Maybe a -> a -> a
`orElse` SMRep -> WordOff
rtsClosureType SMRep
smrep)
                                       (Maybe CmmLit
mb_srt_field Maybe CmmLit -> CmmLit -> CmmLit
forall a. Maybe a -> a -> a
`orElse` CmmLit
srt_bitmap)
                                       (Maybe CmmLit
mb_layout    Maybe CmmLit -> CmmLit -> CmmLit
forall a. Maybe a -> a -> a
`orElse` CmmLit
layout)
       ; (RawCmmGroup, InfoTableContents)
-> UniqSM (RawCmmGroup, InfoTableContents)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmGroup
prof_data RawCmmGroup -> RawCmmGroup -> RawCmmGroup
forall a. [a] -> [a] -> [a]
++ RawCmmGroup
ct_data, ([CmmLit]
std_info, [CmmLit]
extra_bits)) }
  where
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    mk_pieces :: ClosureTypeInfo -> [CmmLit]
              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this
                        , Maybe CmmLit  -- Override the layout field with this
                        , [CmmLit]           -- "Extra bits" for info table
                        , [RawCmmDecl])      -- Auxiliary data decls
    mk_pieces :: ClosureTypeInfo
-> [CmmLit]
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
mk_pieces (Constr WordOff
con_tag ConstrDescription
con_descr) [CmmLit]
_no_srt    -- A data constructor
      = do { (CmmLit
descr_lit, GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
decl) <- ConstrDescription
-> UniqSM
     (CmmLit,
      GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph)
forall info stmt.
ConstrDescription
-> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit ConstrDescription
con_descr
           ; (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( CmmLit -> Maybe CmmLit
forall a. a -> Maybe a
Just (Integer -> Width -> CmmLit
CmmInt (WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
con_tag)
                                   (Platform -> Width
halfWordWidth Platform
platform))
                    , Maybe CmmLit
forall a. Maybe a
Nothing, [CmmLit
descr_lit], [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
decl]) }

    mk_pieces ClosureTypeInfo
Thunk [CmmLit]
srt_label
      = (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CmmLit
forall a. Maybe a
Nothing, Maybe CmmLit
forall a. Maybe a
Nothing, [CmmLit]
srt_label, [])

    mk_pieces (ThunkSelector WordOff
offset) [CmmLit]
_no_srt
      = (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> Maybe CmmLit
forall a. a -> Maybe a
Just (Integer -> Width -> CmmLit
CmmInt Integer
0 (Platform -> Width
halfWordWidth Platform
platform)),
                CmmLit -> Maybe CmmLit
forall a. a -> Maybe a
Just (Platform -> Integer -> CmmLit
mkWordCLit Platform
platform (WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
offset)), [], [])
         -- Layout known (one free var); we use the layout field for offset

    mk_pieces (Fun WordOff
arity (ArgSpec WordOff
fun_type)) [CmmLit]
srt_label
      = do { let extra_bits :: [CmmLit]
extra_bits = Platform -> WordOff -> WordOff -> CmmLit
packIntsCLit Platform
platform WordOff
fun_type WordOff
arity CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
: [CmmLit]
srt_label
           ; (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CmmLit
forall a. Maybe a
Nothing, Maybe CmmLit
forall a. Maybe a
Nothing,  [CmmLit]
extra_bits, []) }

    mk_pieces (Fun WordOff
arity (ArgGen [Bool]
arg_bits)) [CmmLit]
srt_label
      = do { (CmmLit
liveness_lit, RawCmmGroup
liveness_data) <- Platform -> [Bool] -> UniqSM (CmmLit, RawCmmGroup)
mkLivenessBits Platform
platform [Bool]
arg_bits
           ; let fun_type :: WordOff
fun_type | RawCmmGroup -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RawCmmGroup
liveness_data = WordOff
aRG_GEN
                          | Bool
otherwise          = WordOff
aRG_GEN_BIG
                 extra_bits :: [CmmLit]
extra_bits = [ Platform -> WordOff -> WordOff -> CmmLit
packIntsCLit Platform
platform WordOff
fun_type WordOff
arity ]
                           [CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ (if Platform -> Bool
inlineSRT Platform
platform then [] else [ CmmLit
srt_lit ])
                           [CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [ CmmLit
liveness_lit, CmmLit
slow_entry ]
           ; (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CmmLit
forall a. Maybe a
Nothing, Maybe CmmLit
forall a. Maybe a
Nothing, [CmmLit]
extra_bits, RawCmmGroup
liveness_data) }
      where
        slow_entry :: CmmLit
slow_entry = CLabel -> CmmLit
CmmLabel (Platform -> CLabel -> CLabel
toSlowEntryLbl Platform
platform CLabel
info_lbl)
        srt_lit :: CmmLit
srt_lit = case [CmmLit]
srt_label of
                    []          -> Platform -> WordOff -> CmmLit
mkIntCLit Platform
platform WordOff
0
                    (CmmLit
lit:[CmmLit]
_rest) -> Bool -> CmmLit -> CmmLit
forall a. HasCallStack => Bool -> a -> a
assert ([CmmLit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmLit]
_rest) CmmLit
lit

    mk_pieces ClosureTypeInfo
other [CmmLit]
_ = String
-> SDoc
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mk_pieces" (ClosureTypeInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClosureTypeInfo
other)

mkInfoTableContents Profile
_ CmmInfoTable
_ Maybe WordOff
_ = String -> UniqSM (RawCmmGroup, InfoTableContents)
forall a. String -> a
panic String
"mkInfoTableContents"   -- NonInfoTable dealt with earlier

packIntsCLit :: Platform -> Int -> Int -> CmmLit
packIntsCLit :: Platform -> WordOff -> WordOff -> CmmLit
packIntsCLit Platform
platform WordOff
a WordOff
b = Platform -> StgHalfWord -> StgHalfWord -> CmmLit
packHalfWordsCLit Platform
platform
                           (Platform -> Integer -> StgHalfWord
toStgHalfWord Platform
platform (WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
a))
                           (Platform -> Integer -> StgHalfWord
toStgHalfWord Platform
platform (WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
b))


mkSRTLit :: Platform
         -> CLabel
         -> Maybe CLabel
         -> ([CmmLit],    -- srt_label, if any
             CmmLit)      -- srt_bitmap
mkSRTLit :: Platform -> CLabel -> Maybe CLabel -> ([CmmLit], CmmLit)
mkSRTLit Platform
platform CLabel
info_lbl (Just CLabel
lbl)
  | Platform -> Bool
inlineSRT Platform
platform
  = ([], CLabel -> CLabel -> WordOff -> Width -> CmmLit
CmmLabelDiffOff CLabel
lbl CLabel
info_lbl WordOff
0 (Platform -> Width
halfWordWidth Platform
platform))
mkSRTLit Platform
platform CLabel
_ Maybe CLabel
Nothing    = ([], Integer -> Width -> CmmLit
CmmInt Integer
0 (Platform -> Width
halfWordWidth Platform
platform))
mkSRTLit Platform
platform CLabel
_ (Just CLabel
lbl) = ([CLabel -> CmmLit
CmmLabel CLabel
lbl], Integer -> Width -> CmmLit
CmmInt Integer
1 (Platform -> Width
halfWordWidth Platform
platform))


-- | Is the SRT offset field inline in the info table on this platform?
--
-- See the section "Referring to an SRT from the info table" in
-- Note [SRTs] in "GHC.Cmm.Info.Build"
inlineSRT :: Platform -> Bool
inlineSRT :: Platform -> Bool
inlineSRT = PlatformConstants -> Bool
pc_USE_INLINE_SRT_FIELD (PlatformConstants -> Bool)
-> (Platform -> PlatformConstants) -> Platform -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> PlatformConstants
platformConstants

-------------------------------------------------------------------------
--
--      Lay out the info table and handle relative offsets
--
-------------------------------------------------------------------------

-- This function takes
--   * the standard info table portion (StgInfoTable)
--   * the "extra bits" (StgFunInfoExtraRev etc.)
--   * the entry label
--   * the code
-- and lays them out in memory, producing a list of RawCmmDecl

-------------------------------------------------------------------------
--
--      Position independent code
--
-------------------------------------------------------------------------
-- In order to support position independent code, we mustn't put absolute
-- references into read-only space. Info tables in the tablesNextToCode
-- case must be in .text, which is read-only, so we doctor the CmmLits
-- to use relative offsets instead.

-- Note that this is done even when the -fPIC flag is not specified,
-- as we want to keep binary compatibility between PIC and non-PIC.

makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo Platform
platform CLabel
info_lbl CmmLit
lit
  = if Platform -> Bool
platformTablesNextToCode Platform
platform
      then case CmmLit
lit of
         CmmLabel CLabel
lbl        -> CLabel -> CLabel -> WordOff -> Width -> CmmLit
CmmLabelDiffOff CLabel
lbl CLabel
info_lbl WordOff
0   (Platform -> Width
wordWidth Platform
platform)
         CmmLabelOff CLabel
lbl WordOff
off -> CLabel -> CLabel -> WordOff -> Width -> CmmLit
CmmLabelDiffOff CLabel
lbl CLabel
info_lbl WordOff
off (Platform -> Width
wordWidth Platform
platform)
         CmmLit
_                   -> CmmLit
lit
      else CmmLit
lit

-------------------------------------------------------------------------
--
--              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.

mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
              -- ^ Returns:
              --   1. The bitmap (literal value or label)
              --   2. Large bitmap CmmData if needed

mkLivenessBits :: Platform -> [Bool] -> UniqSM (CmmLit, RawCmmGroup)
mkLivenessBits Platform
platform [Bool]
liveness
  | WordOff
n_bits WordOff -> WordOff -> Bool
forall a. Ord a => a -> a -> Bool
> Platform -> WordOff
mAX_SMALL_BITMAP_SIZE Platform
platform -- does not fit in one word
  = do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
       ; let bitmap_lbl :: CLabel
bitmap_lbl = Unique -> CLabel
mkBitmapLabel Unique
uniq
       ; (CmmLit, RawCmmGroup) -> UniqSM (CmmLit, RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CLabel -> CmmLit
CmmLabel CLabel
bitmap_lbl,
                 [CLabel
-> [CmmLit]
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall (raw :: Bool) info stmt.
CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkRODataLits CLabel
bitmap_lbl [CmmLit]
lits]) }

  | Bool
otherwise -- Fits in one word
  = (CmmLit, RawCmmGroup) -> UniqSM (CmmLit, RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> StgWord -> CmmLit
mkStgWordCLit Platform
platform StgWord
bitmap_word, [])
  where
    n_bits :: WordOff
n_bits = [Bool] -> WordOff
forall a. [a] -> WordOff
forall (t :: * -> *) a. Foldable t => t a -> WordOff
length [Bool]
liveness

    bitmap :: Bitmap
    bitmap :: Bitmap
bitmap = Platform -> [Bool] -> Bitmap
mkBitmap Platform
platform [Bool]
liveness

    small_bitmap :: StgWord
small_bitmap = case Bitmap
bitmap of
                     []  -> Platform -> Integer -> StgWord
toStgWord Platform
platform Integer
0
                     [StgWord
b] -> StgWord
b
                     Bitmap
_   -> String -> StgWord
forall a. String -> a
panic String
"mkLiveness"
    bitmap_word :: StgWord
bitmap_word = Platform -> Integer -> StgWord
toStgWord Platform
platform (WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
n_bits)
              StgWord -> StgWord -> StgWord
forall a. Bits a => a -> a -> a
.|. (StgWord
small_bitmap StgWord -> WordOff -> StgWord
forall a. Bits a => a -> WordOff -> a
`shiftL` PlatformConstants -> WordOff
pc_BITMAP_BITS_SHIFT (Platform -> PlatformConstants
platformConstants Platform
platform))

    lits :: [CmmLit]
lits = Platform -> Integer -> CmmLit
mkWordCLit Platform
platform (WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
n_bits)
         CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
: (StgWord -> CmmLit) -> Bitmap -> [CmmLit]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> StgWord -> CmmLit
mkStgWordCLit Platform
platform) Bitmap
bitmap
      -- The first word is the size.  The structure must match
      -- StgLargeBitmap in rts/include/rts/storage/InfoTable.h

-------------------------------------------------------------------------
--
--      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
-- rts/include/rts/storage/InfoTables.h.
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants

mkStdInfoTable
   :: Profile
   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
   -> Int               -- Closure RTS tag
   -> CmmLit            -- SRT length
   -> CmmLit            -- layout field
   -> [CmmLit]

mkStdInfoTable :: Profile
-> (CmmLit, CmmLit) -> WordOff -> CmmLit -> CmmLit -> [CmmLit]
mkStdInfoTable Profile
profile (CmmLit
type_descr, CmmLit
closure_descr) WordOff
cl_type CmmLit
srt CmmLit
layout_lit
 =      -- Parallel revertible-black hole field
    [CmmLit]
prof_info
        -- Ticky info (none at present)
        -- Debug info (none at present)
 [CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ [CmmLit
layout_lit, CmmLit
tag, CmmLit
srt]

 where
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    prof_info :: [CmmLit]
prof_info
        | Profile -> Bool
profileIsProfiling Profile
profile = [CmmLit
type_descr, CmmLit
closure_descr]
        | Bool
otherwise = []

    tag :: CmmLit
tag = Integer -> Width -> CmmLit
CmmInt (WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
cl_type) (Platform -> Width
halfWordWidth Platform
platform)

-------------------------------------------------------------------------
--
--      Making string literals
--
-------------------------------------------------------------------------

mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
mkProfLits Platform
platform ProfilingInfo
NoProfilingInfo = ((CmmLit, CmmLit), RawCmmGroup)
-> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Platform -> CmmLit
zeroCLit Platform
platform, Platform -> CmmLit
zeroCLit Platform
platform), [])
mkProfLits Platform
_ (ProfilingInfo ConstrDescription
td ConstrDescription
cd)
  = do { (CmmLit
td_lit, GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
td_decl) <- ConstrDescription
-> UniqSM
     (CmmLit,
      GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph)
forall info stmt.
ConstrDescription
-> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit ConstrDescription
td
       ; (CmmLit
cd_lit, GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
cd_decl) <- ConstrDescription
-> UniqSM
     (CmmLit,
      GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph)
forall info stmt.
ConstrDescription
-> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit ConstrDescription
cd
       ; ((CmmLit, CmmLit), RawCmmGroup)
-> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CmmLit
td_lit,CmmLit
cd_lit), [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
td_decl,GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
cd_decl]) }

newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit :: forall info stmt.
ConstrDescription
-> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit ConstrDescription
bytes
  = do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
       ; (CmmLit, GenCmmDecl RawCmmStatics info stmt)
-> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CLabel
-> ConstrDescription
-> (CmmLit, GenCmmDecl RawCmmStatics info stmt)
forall (raw :: Bool) info stmt.
CLabel
-> ConstrDescription
-> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit (Unique -> CLabel
mkStringLitLabel Unique
uniq) ConstrDescription
bytes) }


-- Misc utils

-- | Value of the srt field of an info table when using an StgLargeSRT
srtEscape :: Platform -> StgHalfWord
srtEscape :: Platform -> StgHalfWord
srtEscape Platform
platform = Platform -> Integer -> StgHalfWord
toStgHalfWord Platform
platform (-Integer
1)

-------------------------------------------------------------------------
--
--      Accessing fields of an info table
--
-------------------------------------------------------------------------

-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
-- enabled.
wordAligned :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr
wordAligned :: Platform -> Bool -> CmmExpr -> CmmExpr
wordAligned Platform
platform Bool
align_check CmmExpr
e
  | Bool
align_check
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (WordOff -> Width -> MachOp
MO_AlignmentCheck (Platform -> WordOff
platformWordSizeInBytes Platform
platform) (Platform -> Width
wordWidth Platform
platform)) [CmmExpr
e]
  | Bool
otherwise
  = CmmExpr
e

-- | Takes a closure pointer and returns the info table pointer
closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr
closureInfoPtr :: Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_check CmmExpr
e =
    Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform (Platform -> Bool -> CmmExpr -> CmmExpr
wordAligned Platform
platform Bool
align_check CmmExpr
e)

-- | Takes an info pointer (the first word of a closure) and returns its entry
-- code
entryCode :: Platform -> CmmExpr -> CmmExpr
entryCode :: Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform CmmExpr
e =
 if Platform -> Bool
platformTablesNextToCode Platform
platform
      then CmmExpr
e
      else Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform CmmExpr
e

-- | Takes a closure pointer, and return the *zero-indexed*
-- constructor tag obtained from the info table
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr
getConstrTag :: Profile -> Bool -> CmmExpr -> CmmExpr
getConstrTag Profile
profile Bool
align_check CmmExpr
closure_ptr
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (Platform -> Width
halfWordWidth Platform
platform) (Platform -> Width
wordWidth Platform
platform)) [Profile -> CmmExpr -> CmmExpr
infoTableConstrTag Profile
profile CmmExpr
info_table]
  where
    info_table :: CmmExpr
info_table = Profile -> CmmExpr -> CmmExpr
infoTable Profile
profile (Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_check CmmExpr
closure_ptr)
    platform :: Platform
platform   = Profile -> Platform
profilePlatform Profile
profile

-- | Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr
cmmGetClosureType :: Profile -> Bool -> CmmExpr -> CmmExpr
cmmGetClosureType Profile
profile Bool
align_check CmmExpr
closure_ptr
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (Platform -> Width
halfWordWidth Platform
platform) (Platform -> Width
wordWidth Platform
platform)) [Profile -> CmmExpr -> CmmExpr
infoTableClosureType Profile
profile CmmExpr
info_table]
  where
    info_table :: CmmExpr
info_table = Profile -> CmmExpr -> CmmExpr
infoTable Profile
profile (Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_check CmmExpr
closure_ptr)
    platform :: Platform
platform   = Profile -> Platform
profilePlatform Profile
profile

-- | Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
infoTable :: Profile -> CmmExpr -> CmmExpr
infoTable :: Profile -> CmmExpr -> CmmExpr
infoTable Profile
profile CmmExpr
info_ptr
  | Platform -> Bool
platformTablesNextToCode Platform
platform = Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
info_ptr (- Profile -> WordOff
stdInfoTableSizeB Profile
profile)
  | Bool
otherwise                         = Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetW Platform
platform CmmExpr
info_ptr WordOff
1 -- Past the entry code pointer
  where platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

-- | Takes an info table pointer (from infoTable) and returns the constr tag
-- field of the info table (same as the srt_bitmap field)
infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr
infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr
infoTableConstrTag = Profile -> CmmExpr -> CmmExpr
infoTableSrtBitmap

-- | Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr
infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr
infoTableSrtBitmap Profile
profile CmmExpr
info_tbl
  = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
info_tbl (Profile -> WordOff
stdSrtBitmapOffset Profile
profile)) (Platform -> CmmType
bHalfWord Platform
platform) AlignmentSpec
NaturallyAligned
    where platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

-- | Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
infoTableClosureType :: Profile -> CmmExpr -> CmmExpr
infoTableClosureType :: Profile -> CmmExpr -> CmmExpr
infoTableClosureType Profile
profile CmmExpr
info_tbl
  = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
info_tbl (Profile -> WordOff
stdClosureTypeOffset Profile
profile)) (Platform -> CmmType
bHalfWord Platform
platform) AlignmentSpec
NaturallyAligned
    where platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

infoTablePtrs :: Profile -> CmmExpr -> CmmExpr
infoTablePtrs :: Profile -> CmmExpr -> CmmExpr
infoTablePtrs Profile
profile CmmExpr
info_tbl
  = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
info_tbl (Profile -> WordOff
stdPtrsOffset Profile
profile)) (Platform -> CmmType
bHalfWord Platform
platform) AlignmentSpec
NaturallyAligned
    where platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr
infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr
infoTableNonPtrs Profile
profile CmmExpr
info_tbl
  = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
info_tbl (Profile -> WordOff
stdNonPtrsOffset Profile
profile)) (Platform -> CmmType
bHalfWord Platform
platform) AlignmentSpec
NaturallyAligned
    where platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

-- | Takes the info pointer of a function, and returns a pointer to the first
-- word of the StgFunInfoExtra struct in the info table.
funInfoTable :: Profile -> CmmExpr -> CmmExpr
funInfoTable :: Profile -> CmmExpr -> CmmExpr
funInfoTable Profile
profile CmmExpr
info_ptr
  | Platform -> Bool
platformTablesNextToCode Platform
platform
  = Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
info_ptr (- Profile -> WordOff
stdInfoTableSizeB Profile
profile WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- PlatformConstants -> WordOff
pc_SIZEOF_StgFunInfoExtraRev (Platform -> PlatformConstants
platformConstants Platform
platform))
  | Bool
otherwise
  = Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetW Platform
platform CmmExpr
info_ptr (WordOff
1 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ Profile -> WordOff
stdInfoTableSizeW Profile
profile)
                                  -- Past the entry code pointer
  where
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

-- | Takes the info pointer of a function, returns the function's arity
funInfoArity :: Profile -> CmmExpr -> CmmExpr
funInfoArity :: Profile -> CmmExpr -> CmmExpr
funInfoArity Profile
profile CmmExpr
iptr
  = Platform -> CmmExpr -> CmmExpr
cmmToWord Platform
platform (Platform -> CmmType -> CmmExpr -> WordOff -> CmmExpr
cmmLoadIndex Platform
platform CmmType
rep CmmExpr
fun_info (WordOff
offset WordOff -> WordOff -> WordOff
forall a. Integral a => a -> a -> a
`div` WordOff
rep_bytes))
  where
   platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
   fun_info :: CmmExpr
fun_info = Profile -> CmmExpr -> CmmExpr
funInfoTable Profile
profile CmmExpr
iptr
   rep :: CmmType
rep = Width -> CmmType
cmmBits (WordOff -> Width
widthFromBytes WordOff
rep_bytes)
   tablesNextToCode :: Bool
tablesNextToCode = Platform -> Bool
platformTablesNextToCode Platform
platform

   (WordOff
rep_bytes, WordOff
offset)
    | Bool
tablesNextToCode = ( PlatformConstants -> WordOff
pc_REP_StgFunInfoExtraRev_arity PlatformConstants
pc
                         , PlatformConstants -> WordOff
pc_OFFSET_StgFunInfoExtraRev_arity PlatformConstants
pc )
    | Bool
otherwise        = ( PlatformConstants -> WordOff
pc_REP_StgFunInfoExtraFwd_arity PlatformConstants
pc
                         , PlatformConstants -> WordOff
pc_OFFSET_StgFunInfoExtraFwd_arity PlatformConstants
pc )

   pc :: PlatformConstants
pc = Platform -> PlatformConstants
platformConstants Platform
platform

-----------------------------------------------------------------------------
--
--      Info table sizes & offsets
--
-----------------------------------------------------------------------------

stdInfoTableSizeW :: Profile -> WordOff
-- The size of a standard info table varies with profiling/ticky etc,
-- so we can't get it from Constants
-- It must vary in sync with mkStdInfoTable
stdInfoTableSizeW :: Profile -> WordOff
stdInfoTableSizeW Profile
profile
  = WordOff
fixedInfoTableSizeW
  WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ if Profile -> Bool
profileIsProfiling Profile
profile
       then WordOff
profInfoTableSizeW
       else WordOff
0

fixedInfoTableSizeW :: WordOff
fixedInfoTableSizeW :: WordOff
fixedInfoTableSizeW = WordOff
2 -- layout, type

profInfoTableSizeW :: WordOff
profInfoTableSizeW :: WordOff
profInfoTableSizeW = WordOff
2

maxStdInfoTableSizeW :: WordOff
maxStdInfoTableSizeW :: WordOff
maxStdInfoTableSizeW =
  WordOff
1 {- entry, when !tablesNextToCode -}
  WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
fixedInfoTableSizeW
  WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
profInfoTableSizeW

maxRetInfoTableSizeW :: WordOff
maxRetInfoTableSizeW :: WordOff
maxRetInfoTableSizeW =
  WordOff
maxStdInfoTableSizeW
  WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
1 {- srt label -}

stdInfoTableSizeB  :: Profile -> ByteOff
stdInfoTableSizeB :: Profile -> WordOff
stdInfoTableSizeB Profile
profile = Profile -> WordOff
stdInfoTableSizeW Profile
profile WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
* Profile -> WordOff
profileWordSizeInBytes Profile
profile

-- | Byte offset of the SRT bitmap half-word which is in the *higher-addressed*
-- part of the type_lit
stdSrtBitmapOffset :: Profile -> ByteOff
stdSrtBitmapOffset :: Profile -> WordOff
stdSrtBitmapOffset Profile
profile = Profile -> WordOff
stdInfoTableSizeB Profile
profile WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Platform -> WordOff
halfWordSize (Profile -> Platform
profilePlatform Profile
profile)

-- | Byte offset of the closure type half-word
stdClosureTypeOffset :: Profile -> ByteOff
stdClosureTypeOffset :: Profile -> WordOff
stdClosureTypeOffset Profile
profile = Profile -> WordOff
stdInfoTableSizeB Profile
profile WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Profile -> WordOff
profileWordSizeInBytes Profile
profile

stdPtrsOffset :: Profile -> ByteOff
stdPtrsOffset :: Profile -> WordOff
stdPtrsOffset Profile
profile = Profile -> WordOff
stdInfoTableSizeB Profile
profile WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
2 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
* Profile -> WordOff
profileWordSizeInBytes Profile
profile

stdNonPtrsOffset :: Profile -> ByteOff
stdNonPtrsOffset :: Profile -> WordOff
stdNonPtrsOffset Profile
profile = Profile -> WordOff
stdInfoTableSizeB Profile
profile WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
2 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
* Profile -> WordOff
profileWordSizeInBytes Profile
profile
                                                     WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff
halfWordSize (Profile -> Platform
profilePlatform Profile
profile)

conInfoTableSizeB :: Profile -> Int
conInfoTableSizeB :: Profile -> WordOff
conInfoTableSizeB Profile
profile = Profile -> WordOff
stdInfoTableSizeB Profile
profile WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ Profile -> WordOff
profileWordSizeInBytes Profile
profile