{-# LANGUAGE CPP #-}
module CmmInfo (
  mkEmptyContInfoTable,
  cmmToRawCmm,
  mkInfoTable,
  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

#include "HsVersions.h"

import GhcPrelude

import Cmm
import CmmUtils
import CLabel
import SMRep
import Bitmap
import Stream (Stream)
import qualified Stream
import Hoopl.Collections

import Platform
import Maybes
import DynFlags
import Panic
import UniqSupply
import MonadUtils
import Util
import Outputable

import Data.Bits
import Data.Word

-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
mkEmptyContInfoTable info_lbl :: CLabel
info_lbl
  = CmmInfoTable :: CLabel
-> SMRep
-> ProfilingInfo
-> Maybe CLabel
-> Maybe (Id, CostCentreStack)
-> CmmInfoTable
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 :: DynFlags -> Stream IO CmmGroup ()
            -> IO (Stream IO RawCmmGroup ())
cmmToRawCmm :: DynFlags -> Stream IO CmmGroup () -> IO (Stream IO RawCmmGroup ())
cmmToRawCmm dflags :: DynFlags
dflags cmms :: Stream IO CmmGroup ()
cmms
  = do { UniqSupply
uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply 'i'
       ; let do_one :: UniqSupply -> CmmGroup -> m (UniqSupply, RawCmmGroup)
do_one uniqs :: UniqSupply
uniqs cmm :: CmmGroup
cmm = do
                case UniqSupply -> UniqSM RawCmmGroup -> (RawCmmGroup, UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
uniqs (UniqSM RawCmmGroup -> (RawCmmGroup, UniqSupply))
-> UniqSM RawCmmGroup -> (RawCmmGroup, UniqSupply)
forall a b. (a -> b) -> a -> b
$ (CmmDecl -> UniqSM RawCmmGroup) -> CmmGroup -> UniqSM RawCmmGroup
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (DynFlags -> CmmDecl -> UniqSM RawCmmGroup
mkInfoTable DynFlags
dflags) CmmGroup
cmm of
                  (b :: RawCmmGroup
b,uniqs' :: UniqSupply
uniqs') -> (UniqSupply, RawCmmGroup) -> m (UniqSupply, RawCmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply
uniqs',RawCmmGroup
b)
                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
       ; Stream IO RawCmmGroup () -> IO (Stream IO RawCmmGroup ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((UniqSupply -> CmmGroup -> IO (UniqSupply, RawCmmGroup))
-> UniqSupply
-> Stream IO CmmGroup ()
-> Stream IO RawCmmGroup UniqSupply
forall (m :: * -> *) c a b.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a () -> Stream m b c
Stream.mapAccumL UniqSupply -> CmmGroup -> IO (UniqSupply, RawCmmGroup)
forall (m :: * -> *).
Monad m =>
UniqSupply -> CmmGroup -> m (UniqSupply, RawCmmGroup)
do_one UniqSupply
uniqs Stream IO CmmGroup ()
cmms Stream IO RawCmmGroup UniqSupply
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Stream IO RawCmmGroup ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       }

-- 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 includes/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 :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable :: DynFlags -> CmmDecl -> UniqSM RawCmmGroup
mkInfoTable _ (CmmData sec :: Section
sec dat :: CmmStatics
dat)
  = RawCmmGroup -> UniqSM RawCmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return [Section
-> CmmStatics
-> GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec CmmStatics
dat]

mkInfoTable dflags :: DynFlags
dflags proc :: CmmDecl
proc@(CmmProc infos :: CmmTopInfo
infos entry_lbl :: CLabel
entry_lbl live :: [GlobalReg]
live blocks :: 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 (DynFlags -> Bool
tablesNextToCode DynFlags
dflags)
  = case CmmDecl -> Maybe CmmInfoTable
forall a (n :: * -> * -> *).
GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable CmmDecl
proc of   --  must be at most one
      -- no info table
      Nothing ->
         RawCmmGroup -> UniqSM RawCmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return [LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
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
        (top_decls :: RawCmmGroup
top_decls, (std_info :: [CmmLit]
std_info, extra_bits :: [CmmLit]
extra_bits)) <-
             DynFlags
-> CmmInfoTable
-> Maybe Int
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents DynFlags
dflags CmmInfoTable
info Maybe Int
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 (DynFlags -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo DynFlags
dflags 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 (DynFlags -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo DynFlags
dflags 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 (m :: * -> *) a. Monad m => a -> m a
return (RawCmmGroup
top_decls RawCmmGroup -> RawCmmGroup -> RawCmmGroup
forall a. [a] -> [a] -> [a]
++
                [LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
forall (map :: * -> *) a. IsMap map => map a
mapEmpty CLabel
entry_lbl [GlobalReg]
live CmmGraph
blocks,
                 CLabel
-> [CmmLit] -> GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
forall info stmt.
CLabel -> [CmmLit] -> GenCmmDecl CmmStatics 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
    (top_declss :: [RawCmmGroup]
top_declss, raw_infos :: [(Label, CmmStatics)]
raw_infos) <-
       [(RawCmmGroup, (Label, CmmStatics))]
-> ([RawCmmGroup], [(Label, CmmStatics)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(RawCmmGroup, (Label, CmmStatics))]
 -> ([RawCmmGroup], [(Label, CmmStatics)]))
-> UniqSM [(RawCmmGroup, (Label, CmmStatics))]
-> UniqSM ([RawCmmGroup], [(Label, CmmStatics)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((Label, CmmInfoTable)
 -> UniqSM (RawCmmGroup, (Label, CmmStatics)))
-> [(Label, CmmInfoTable)]
-> UniqSM [(RawCmmGroup, (Label, CmmStatics))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Label, CmmInfoTable) -> UniqSM (RawCmmGroup, (Label, CmmStatics))
forall a.
(a, CmmInfoTable) -> UniqSM (RawCmmGroup, (a, CmmStatics))
do_one_info (LabelMap CmmInfoTable -> [(KeyOf LabelMap, CmmInfoTable)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
infos))
    RawCmmGroup -> UniqSM RawCmmGroup
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 CmmStatics
-> CLabel
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc ([(KeyOf LabelMap, CmmStatics)] -> LabelMap CmmStatics
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(KeyOf LabelMap, CmmStatics)]
[(Label, CmmStatics)]
raw_infos) CLabel
entry_lbl [GlobalReg]
live CmmGraph
blocks])

  where
   do_one_info :: (a, CmmInfoTable) -> UniqSM (RawCmmGroup, (a, CmmStatics))
do_one_info (lbl :: a
lbl,itbl :: CmmInfoTable
itbl) = do
     (top_decls :: RawCmmGroup
top_decls, (std_info :: [CmmLit]
std_info, extra_bits :: [CmmLit]
extra_bits)) <-
         DynFlags
-> CmmInfoTable
-> Maybe Int
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents DynFlags
dflags CmmInfoTable
itbl Maybe Int
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 (DynFlags -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo DynFlags
dflags 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 (DynFlags -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo DynFlags
dflags CLabel
info_lbl) [CmmLit]
extra_bits
     --
     (RawCmmGroup, (a, CmmStatics))
-> UniqSM (RawCmmGroup, (a, CmmStatics))
forall (m :: * -> *) a. Monad m => a -> m a
return (RawCmmGroup
top_decls, (a
lbl, CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
info_lbl ([CmmStatic] -> CmmStatics) -> [CmmStatic] -> CmmStatics
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 :: DynFlags
                    -> CmmInfoTable
                    -> Maybe Int               -- Override default RTS type tag?
                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
                               InfoTableContents)       -- Info tbl + extra bits

mkInfoTableContents :: DynFlags
-> CmmInfoTable
-> Maybe Int
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents dflags :: DynFlags
dflags
                    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 })
                    mb_rts_tag :: Maybe Int
mb_rts_tag
  | RTSRep rts_tag :: Int
rts_tag rep :: SMRep
rep <- SMRep
smrep
  = DynFlags
-> CmmInfoTable
-> Maybe Int
-> UniqSM (RawCmmGroup, InfoTableContents)
mkInfoTableContents DynFlags
dflags CmmInfoTable
info{cit_rep :: SMRep
cit_rep = SMRep
rep} (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
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 frame :: [Bool]
frame <- SMRep
smrep
  = do { (prof_lits :: (CmmLit, CmmLit)
prof_lits, prof_data :: RawCmmGroup
prof_data) <- DynFlags -> ProfilingInfo -> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
mkProfLits DynFlags
dflags ProfilingInfo
prof
       ; let (srt_label :: [CmmLit]
srt_label, srt_bitmap :: CmmLit
srt_bitmap) = DynFlags -> CLabel -> Maybe CLabel -> ([CmmLit], CmmLit)
mkSRTLit DynFlags
dflags CLabel
info_lbl Maybe CLabel
srt
       ; (liveness_lit :: CmmLit
liveness_lit, liveness_data :: RawCmmGroup
liveness_data) <- DynFlags -> [Bool] -> UniqSM (CmmLit, RawCmmGroup)
mkLivenessBits DynFlags
dflags [Bool]
frame
       ; let
             std_info :: [CmmLit]
std_info = DynFlags -> (CmmLit, CmmLit) -> Int -> CmmLit -> CmmLit -> [CmmLit]
mkStdInfoTable DynFlags
dflags (CmmLit, CmmLit)
prof_lits Int
rts_tag CmmLit
srt_bitmap CmmLit
liveness_lit
             rts_tag :: Int
rts_tag | Just tag :: Int
tag <- Maybe Int
mb_rts_tag = Int
tag
                     | RawCmmGroup -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RawCmmGroup
liveness_data     = Int
rET_SMALL -- Fits in extra_bits
                     | Bool
otherwise              = Int
rET_BIG   -- Does not; extra_bits is
                                                          -- a label
       ; (RawCmmGroup, InfoTableContents)
-> UniqSM (RawCmmGroup, InfoTableContents)
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 _ ptrs :: Int
ptrs nonptrs :: Int
nonptrs closure_type :: ClosureTypeInfo
closure_type <- SMRep
smrep
  = do { let layout :: CmmLit
layout  = DynFlags -> Int -> Int -> CmmLit
packIntsCLit DynFlags
dflags Int
ptrs Int
nonptrs
       ; (prof_lits :: (CmmLit, CmmLit)
prof_lits, prof_data :: RawCmmGroup
prof_data) <- DynFlags -> ProfilingInfo -> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
mkProfLits DynFlags
dflags ProfilingInfo
prof
       ; let (srt_label :: [CmmLit]
srt_label, srt_bitmap :: CmmLit
srt_bitmap) = DynFlags -> CLabel -> Maybe CLabel -> ([CmmLit], CmmLit)
mkSRTLit DynFlags
dflags CLabel
info_lbl Maybe CLabel
srt
       ; (mb_srt_field :: Maybe CmmLit
mb_srt_field, mb_layout :: Maybe CmmLit
mb_layout, extra_bits :: [CmmLit]
extra_bits, ct_data :: 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 = DynFlags -> (CmmLit, CmmLit) -> Int -> CmmLit -> CmmLit -> [CmmLit]
mkStdInfoTable DynFlags
dflags (CmmLit, CmmLit)
prof_lits
                                       (Maybe Int
mb_rts_tag   Maybe Int -> Int -> Int
forall a. Maybe a -> a -> a
`orElse` SMRep -> Int
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 (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
    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 con_tag :: Int
con_tag con_descr :: ConstrDescription
con_descr) _no_srt :: [CmmLit]
_no_srt    -- A data constructor
      = do { (descr_lit :: CmmLit
descr_lit, decl :: GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
decl) <- ConstrDescription
-> UniqSM
     (CmmLit, GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph)
forall info stmt.
ConstrDescription
-> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit ConstrDescription
con_descr
           ; (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return ( CmmLit -> Maybe CmmLit
forall a. a -> Maybe a
Just (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
con_tag)
                                   (DynFlags -> Width
halfWordWidth DynFlags
dflags))
                    , Maybe CmmLit
forall a. Maybe a
Nothing, [CmmLit
descr_lit], [GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
decl]) }

    mk_pieces Thunk srt_label :: [CmmLit]
srt_label
      = (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
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 offset :: Int
offset) _no_srt :: [CmmLit]
_no_srt
      = (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
-> UniqSM (Maybe CmmLit, Maybe CmmLit, [CmmLit], RawCmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmLit -> Maybe CmmLit
forall a. a -> Maybe a
Just (Integer -> Width -> CmmLit
CmmInt 0 (DynFlags -> Width
halfWordWidth DynFlags
dflags)),
                CmmLit -> Maybe CmmLit
forall a. a -> Maybe a
Just (DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset)), [], [])
         -- Layout known (one free var); we use the layout field for offset

    mk_pieces (Fun arity :: Int
arity (ArgSpec fun_type :: Int
fun_type)) srt_label :: [CmmLit]
srt_label
      = do { let extra_bits :: [CmmLit]
extra_bits = DynFlags -> Int -> Int -> CmmLit
packIntsCLit DynFlags
dflags Int
fun_type Int
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 (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 arity :: Int
arity (ArgGen arg_bits :: [Bool]
arg_bits)) srt_label :: [CmmLit]
srt_label
      = do { (liveness_lit :: CmmLit
liveness_lit, liveness_data :: RawCmmGroup
liveness_data) <- DynFlags -> [Bool] -> UniqSM (CmmLit, RawCmmGroup)
mkLivenessBits DynFlags
dflags [Bool]
arg_bits
           ; let fun_type :: Int
fun_type | RawCmmGroup -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RawCmmGroup
liveness_data = Int
aRG_GEN
                          | Bool
otherwise          = Int
aRG_GEN_BIG
                 extra_bits :: [CmmLit]
extra_bits = [ DynFlags -> Int -> Int -> CmmLit
packIntsCLit DynFlags
dflags Int
fun_type Int
arity ]
                           [CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ (if DynFlags -> Bool
inlineSRT DynFlags
dflags 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 (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 (CLabel -> CLabel
toSlowEntryLbl CLabel
info_lbl)
        srt_lit :: CmmLit
srt_lit = case [CmmLit]
srt_label of
                    []          -> DynFlags -> Int -> CmmLit
mkIntCLit DynFlags
dflags 0
                    (lit :: CmmLit
lit:_rest :: [CmmLit]
_rest) -> ASSERT( null _rest ) lit

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

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

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


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


-- | 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 CmmBuildInfoTables.hs
inlineSRT :: DynFlags -> Bool
inlineSRT :: DynFlags -> Bool
inlineSRT dflags :: DynFlags
dflags = Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchX86_64
  Bool -> Bool -> Bool
&& DynFlags -> Bool
tablesNextToCode DynFlags
dflags

-------------------------------------------------------------------------
--
--      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 :: DynFlags -> CLabel -> CmmLit -> CmmLit

makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo dflags :: DynFlags
dflags info_lbl :: CLabel
info_lbl (CmmLabel lbl :: CLabel
lbl)
  | DynFlags -> Bool
tablesNextToCode DynFlags
dflags
  = CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
lbl CLabel
info_lbl 0 (DynFlags -> Width
wordWidth DynFlags
dflags)
makeRelativeRefTo dflags :: DynFlags
dflags info_lbl :: CLabel
info_lbl (CmmLabelOff lbl :: CLabel
lbl off :: Int
off)
  | DynFlags -> Bool
tablesNextToCode DynFlags
dflags
  = CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
lbl CLabel
info_lbl Int
off (DynFlags -> Width
wordWidth DynFlags
dflags)
makeRelativeRefTo _ _ lit :: CmmLit
lit = 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 :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
              -- ^ Returns:
              --   1. The bitmap (literal value or label)
              --   2. Large bitmap CmmData if needed

mkLivenessBits :: DynFlags -> [Bool] -> UniqSM (CmmLit, RawCmmGroup)
mkLivenessBits dflags :: DynFlags
dflags liveness :: [Bool]
liveness
  | Int
n_bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> DynFlags -> Int
mAX_SMALL_BITMAP_SIZE DynFlags
dflags -- 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 (m :: * -> *) a. Monad m => a -> m a
return (CLabel -> CmmLit
CmmLabel CLabel
bitmap_lbl,
                 [CLabel
-> [CmmLit] -> GenCmmDecl CmmStatics (LabelMap CmmStatics) CmmGraph
forall info stmt.
CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkRODataLits CLabel
bitmap_lbl [CmmLit]
lits]) }

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

    bitmap :: Bitmap
    bitmap :: Bitmap
bitmap = DynFlags -> [Bool] -> Bitmap
mkBitmap DynFlags
dflags [Bool]
liveness

    small_bitmap :: StgWord
small_bitmap = case Bitmap
bitmap of
                     []  -> DynFlags -> Integer -> StgWord
toStgWord DynFlags
dflags 0
                     [b :: StgWord
b] -> StgWord
b
                     _   -> String -> StgWord
forall a. String -> a
panic "mkLiveness"
    bitmap_word :: StgWord
bitmap_word = DynFlags -> Integer -> StgWord
toStgWord DynFlags
dflags (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n_bits)
              StgWord -> StgWord -> StgWord
forall a. Bits a => a -> a -> a
.|. (StgWord
small_bitmap StgWord -> Int -> StgWord
forall a. Bits a => a -> Int -> a
`shiftL` DynFlags -> Int
bITMAP_BITS_SHIFT DynFlags
dflags)

    lits :: [CmmLit]
lits = DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n_bits)
         CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
: (StgWord -> CmmLit) -> Bitmap -> [CmmLit]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> StgWord -> CmmLit
mkStgWordCLit DynFlags
dflags) Bitmap
bitmap
      -- The first word is the size.  The structure must match
      -- StgLargeBitmap in includes/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
-- includes/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
   :: DynFlags
   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
   -> Int               -- Closure RTS tag
   -> CmmLit            -- SRT length
   -> CmmLit            -- layout field
   -> [CmmLit]

mkStdInfoTable :: DynFlags -> (CmmLit, CmmLit) -> Int -> CmmLit -> CmmLit -> [CmmLit]
mkStdInfoTable dflags :: DynFlags
dflags (type_descr :: CmmLit
type_descr, closure_descr :: CmmLit
closure_descr) cl_type :: Int
cl_type srt :: CmmLit
srt layout_lit :: 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
    prof_info :: [CmmLit]
prof_info
        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags = [CmmLit
type_descr, CmmLit
closure_descr]
        | Bool
otherwise = []

    tag :: CmmLit
tag = Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cl_type) (DynFlags -> Width
halfWordWidth DynFlags
dflags)

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

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

newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit :: ConstrDescription
-> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit bytes :: ConstrDescription
bytes
  = do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
       ; (CmmLit, GenCmmDecl CmmStatics info stmt)
-> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
forall (m :: * -> *) a. Monad m => a -> m a
return (CLabel
-> ConstrDescription -> (CmmLit, GenCmmDecl CmmStatics info stmt)
forall info stmt.
CLabel
-> ConstrDescription -> (CmmLit, GenCmmDecl CmmStatics 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 :: DynFlags -> StgHalfWord
srtEscape :: DynFlags -> StgHalfWord
srtEscape dflags :: DynFlags
dflags = DynFlags -> Integer -> StgHalfWord
toStgHalfWord DynFlags
dflags (-1)

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

-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
-- enabled.
wordAligned :: DynFlags -> CmmExpr -> CmmExpr
wordAligned :: DynFlags -> CmmExpr -> CmmExpr
wordAligned dflags :: DynFlags
dflags e :: CmmExpr
e
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AlignmentSanitisation DynFlags
dflags
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Int -> Width -> MachOp
MO_AlignmentCheck (DynFlags -> Int
wORD_SIZE DynFlags
dflags) (DynFlags -> Width
wordWidth DynFlags
dflags)) [CmmExpr
e]
  | Bool
otherwise
  = CmmExpr
e

closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
closureInfoPtr dflags :: DynFlags
dflags e :: CmmExpr
e =
    CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> CmmExpr
wordAligned DynFlags
dflags CmmExpr
e) (DynFlags -> CmmType
bWord DynFlags
dflags)

entryCode :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns its entry code
entryCode :: DynFlags -> CmmExpr -> CmmExpr
entryCode dflags :: DynFlags
dflags e :: CmmExpr
e
 | DynFlags -> Bool
tablesNextToCode DynFlags
dflags = CmmExpr
e
 | Bool
otherwise               = CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
e (DynFlags -> CmmType
bWord DynFlags
dflags)

getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- 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 :: DynFlags -> CmmExpr -> CmmExpr
getConstrTag dflags :: DynFlags
dflags closure_ptr :: CmmExpr
closure_ptr
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (DynFlags -> Width
halfWordWidth DynFlags
dflags) (DynFlags -> Width
wordWidth DynFlags
dflags)) [DynFlags -> CmmExpr -> CmmExpr
infoTableConstrTag DynFlags
dflags CmmExpr
info_table]
  where
    info_table :: CmmExpr
info_table = DynFlags -> CmmExpr -> CmmExpr
infoTable DynFlags
dflags (DynFlags -> CmmExpr -> CmmExpr
closureInfoPtr DynFlags
dflags CmmExpr
closure_ptr)

cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
cmmGetClosureType dflags :: DynFlags
dflags closure_ptr :: CmmExpr
closure_ptr
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (DynFlags -> Width
halfWordWidth DynFlags
dflags) (DynFlags -> Width
wordWidth DynFlags
dflags)) [DynFlags -> CmmExpr -> CmmExpr
infoTableClosureType DynFlags
dflags CmmExpr
info_table]
  where
    info_table :: CmmExpr
info_table = DynFlags -> CmmExpr -> CmmExpr
infoTable DynFlags
dflags (DynFlags -> CmmExpr -> CmmExpr
closureInfoPtr DynFlags
dflags CmmExpr
closure_ptr)

infoTable :: DynFlags -> CmmExpr -> CmmExpr
-- 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 :: DynFlags -> CmmExpr -> CmmExpr
infoTable dflags :: DynFlags
dflags info_ptr :: CmmExpr
info_ptr
  | DynFlags -> Bool
tablesNextToCode DynFlags
dflags = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
info_ptr (- DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags)
  | Bool
otherwise               = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags CmmExpr
info_ptr 1 -- Past the entry code pointer

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

infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
infoTableSrtBitmap dflags :: DynFlags
dflags info_tbl :: CmmExpr
info_tbl
  = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
info_tbl (DynFlags -> Int
stdSrtBitmapOffset DynFlags
dflags)) (DynFlags -> CmmType
bHalfWord DynFlags
dflags)

infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
infoTableClosureType dflags :: DynFlags
dflags info_tbl :: CmmExpr
info_tbl
  = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
info_tbl (DynFlags -> Int
stdClosureTypeOffset DynFlags
dflags)) (DynFlags -> CmmType
bHalfWord DynFlags
dflags)

infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs dflags :: DynFlags
dflags info_tbl :: CmmExpr
info_tbl
  = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
info_tbl (DynFlags -> Int
stdPtrsOffset DynFlags
dflags)) (DynFlags -> CmmType
bHalfWord DynFlags
dflags)

infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs dflags :: DynFlags
dflags info_tbl :: CmmExpr
info_tbl
  = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
info_tbl (DynFlags -> Int
stdNonPtrsOffset DynFlags
dflags)) (DynFlags -> CmmType
bHalfWord DynFlags
dflags)

funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the info pointer of a function,
-- and returns a pointer to the first word of the StgFunInfoExtra struct
-- in the info table.
funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
funInfoTable dflags :: DynFlags
dflags info_ptr :: CmmExpr
info_ptr
  | DynFlags -> Bool
tablesNextToCode DynFlags
dflags
  = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
info_ptr (- DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
sIZEOF_StgFunInfoExtraRev DynFlags
dflags)
  | Bool
otherwise
  = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags CmmExpr
info_ptr (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
stdInfoTableSizeW DynFlags
dflags)
                                -- Past the entry code pointer

-- Takes the info pointer of a function, returns the function's arity
funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
funInfoArity dflags :: DynFlags
dflags iptr :: CmmExpr
iptr
  = DynFlags -> CmmExpr -> CmmExpr
cmmToWord DynFlags
dflags (DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex DynFlags
dflags CmmType
rep CmmExpr
fun_info (Int
offset Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
rep_bytes))
  where
   fun_info :: CmmExpr
fun_info = DynFlags -> CmmExpr -> CmmExpr
funInfoTable DynFlags
dflags CmmExpr
iptr
   rep :: CmmType
rep = Width -> CmmType
cmmBits (Int -> Width
widthFromBytes Int
rep_bytes)

   (rep_bytes :: Int
rep_bytes, offset :: Int
offset)
    | DynFlags -> Bool
tablesNextToCode DynFlags
dflags = ( PlatformConstants -> Int
pc_REP_StgFunInfoExtraRev_arity PlatformConstants
pc
                                , DynFlags -> Int
oFFSET_StgFunInfoExtraRev_arity DynFlags
dflags )
    | Bool
otherwise               = ( PlatformConstants -> Int
pc_REP_StgFunInfoExtraFwd_arity PlatformConstants
pc
                                , DynFlags -> Int
oFFSET_StgFunInfoExtraFwd_arity DynFlags
dflags )

   pc :: PlatformConstants
pc = Settings -> PlatformConstants
sPlatformConstants (DynFlags -> Settings
settings DynFlags
dflags)

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

stdInfoTableSizeW :: DynFlags -> 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 :: DynFlags -> Int
stdInfoTableSizeW dflags :: DynFlags
dflags
  = Int
fixedInfoTableSizeW
  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
       then Int
profInfoTableSizeW
       else 0

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

profInfoTableSizeW :: WordOff
profInfoTableSizeW :: Int
profInfoTableSizeW = 2

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

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

stdInfoTableSizeB  :: DynFlags -> ByteOff
stdInfoTableSizeB :: DynFlags -> Int
stdInfoTableSizeB dflags :: DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeW DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
* DynFlags -> Int
wORD_SIZE DynFlags
dflags

stdSrtBitmapOffset :: DynFlags -> ByteOff
-- Byte offset of the SRT bitmap half-word which is
-- in the *higher-addressed* part of the type_lit
stdSrtBitmapOffset :: DynFlags -> Int
stdSrtBitmapOffset dflags :: DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
hALF_WORD_SIZE DynFlags
dflags

stdClosureTypeOffset :: DynFlags -> ByteOff
-- Byte offset of the closure type half-word
stdClosureTypeOffset :: DynFlags -> Int
stdClosureTypeOffset dflags :: DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
wORD_SIZE DynFlags
dflags

stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
stdPtrsOffset :: DynFlags -> Int
stdPtrsOffset    dflags :: DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* DynFlags -> Int
wORD_SIZE DynFlags
dflags
stdNonPtrsOffset :: DynFlags -> Int
stdNonPtrsOffset dflags :: DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
hALF_WORD_SIZE DynFlags
dflags

conInfoTableSizeB :: DynFlags -> Int
conInfoTableSizeB :: DynFlags -> Int
conInfoTableSizeB dflags :: DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
wORD_SIZE DynFlags
dflags