{-# 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 GHC.Platform
import Maybes
import DynFlags
import ErrUtils (withTimingSilent)
import Panic
import UniqSupply
import MonadUtils
import Util
import Outputable

import Data.ByteString (ByteString)
import Data.Bits

-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
mkEmptyContInfoTable 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 a
            -> IO (Stream IO RawCmmGroup a)
cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a -> IO (Stream IO RawCmmGroup a)
cmmToRawCmm DynFlags
dflags Stream IO CmmGroup a
cmms
  = do { UniqSupply
uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'i'
       ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])
             do_one :: UniqSupply -> CmmGroup -> IO (UniqSupply, RawCmmGroup)
do_one UniqSupply
uniqs CmmGroup
cmm =
               -- NB. strictness fixes a space leak.  DO NOT REMOVE.
               DynFlags
-> SDoc
-> ((UniqSupply, RawCmmGroup) -> ())
-> IO (UniqSupply, RawCmmGroup)
-> IO (UniqSupply, RawCmmGroup)
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent DynFlags
dflags (String -> SDoc
text String
"Cmm -> Raw Cmm")
                                (UniqSupply, RawCmmGroup) -> ()
forall (t :: * -> *) a a. Foldable t => (a, t a) -> ()
forceRes (IO (UniqSupply, RawCmmGroup) -> IO (UniqSupply, RawCmmGroup))
-> IO (UniqSupply, RawCmmGroup) -> IO (UniqSupply, RawCmmGroup)
forall a b. (a -> b) -> a -> b
$
                 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
                   (RawCmmGroup
b,UniqSupply
uniqs') -> (UniqSupply, RawCmmGroup) -> IO (UniqSupply, RawCmmGroup)
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply
uniqs',RawCmmGroup
b)
       ; Stream IO RawCmmGroup a -> IO (Stream IO RawCmmGroup a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((UniqSupply, a) -> a
forall a b. (a, b) -> b
snd ((UniqSupply, a) -> a)
-> Stream IO RawCmmGroup (UniqSupply, a) -> Stream IO RawCmmGroup a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UniqSupply -> CmmGroup -> IO (UniqSupply, RawCmmGroup))
-> UniqSupply
-> Stream IO CmmGroup a
-> Stream IO RawCmmGroup (UniqSupply, a)
forall (m :: * -> *) c a b r.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)
Stream.mapAccumL_ UniqSupply -> CmmGroup -> IO (UniqSupply, RawCmmGroup)
do_one UniqSupply
uniqs Stream IO CmmGroup a
cmms)
       }

    where forceRes :: (a, t a) -> ()
forceRes (a
uniqs, t a
rawcmms) =
            a
uniqs a -> () -> ()
`seq` (a -> () -> ()) -> () -> t a -> ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
decl ()
r -> a
decl a -> () -> ()
`seq` ()
r) () t a
rawcmms

-- 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 DynFlags
_ (CmmData Section
sec 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 DynFlags
dflags proc :: CmmDecl
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 (DynFlags -> Bool
tablesNextToCode DynFlags
dflags)
  = case CmmDecl -> Maybe CmmInfoTable
forall a (n :: Extensibility -> Extensibility -> *).
GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable CmmDecl
proc of   --  must be at most one
      -- no info table
      Maybe CmmInfoTable
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
        (RawCmmGroup
top_decls, ([CmmLit]
std_info, [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
    ([RawCmmGroup]
top_declss, [(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 (a
lbl,CmmInfoTable
itbl) = do
     (RawCmmGroup
top_decls, ([CmmLit]
std_info, [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 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 })
                    Maybe Int
mb_rts_tag
  | RTSRep Int
rts_tag 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 [Bool]
frame <- SMRep
smrep
  = do { ((CmmLit, CmmLit)
prof_lits, RawCmmGroup
prof_data) <- DynFlags -> ProfilingInfo -> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
mkProfLits DynFlags
dflags ProfilingInfo
prof
       ; let ([CmmLit]
srt_label, CmmLit
srt_bitmap) = DynFlags -> CLabel -> Maybe CLabel -> ([CmmLit], CmmLit)
mkSRTLit DynFlags
dflags CLabel
info_lbl Maybe CLabel
srt
       ; (CmmLit
liveness_lit, 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 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 Bool
_ Int
ptrs Int
nonptrs ClosureTypeInfo
closure_type <- SMRep
smrep
  = do { let layout :: CmmLit
layout  = DynFlags -> Int -> Int -> CmmLit
packIntsCLit DynFlags
dflags Int
ptrs Int
nonptrs
       ; ((CmmLit, CmmLit)
prof_lits, RawCmmGroup
prof_data) <- DynFlags -> ProfilingInfo -> UniqSM ((CmmLit, CmmLit), RawCmmGroup)
mkProfLits DynFlags
dflags ProfilingInfo
prof
       ; let ([CmmLit]
srt_label, CmmLit
srt_bitmap) = DynFlags -> CLabel -> Maybe CLabel -> ([CmmLit], CmmLit)
mkSRTLit DynFlags
dflags 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 = 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 Int
con_tag ConstrDescription
con_descr) [CmmLit]
_no_srt    -- A data constructor
      = do { (CmmLit
descr_lit, 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 ClosureTypeInfo
Thunk [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 Int
offset) [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 Integer
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 Int
arity (ArgSpec Int
fun_type)) [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 Int
arity (ArgGen [Bool]
arg_bits)) [CmmLit]
srt_label
      = do { (CmmLit
liveness_lit, 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 Int
0
                    (CmmLit
lit:[CmmLit]
_rest) -> ASSERT( null _rest ) 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 DynFlags
_ CmmInfoTable
_ Maybe Int
_ = String -> UniqSM (RawCmmGroup, InfoTableContents)
forall a. String -> a
panic String
"mkInfoTableContents"   -- NonInfoTable dealt with earlier

packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
packIntsCLit DynFlags
dflags Int
a 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 DynFlags
dflags CLabel
info_lbl (Just CLabel
lbl)
  | DynFlags -> Bool
inlineSRT DynFlags
dflags
  = ([], CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
lbl CLabel
info_lbl Int
0 (DynFlags -> Width
halfWordWidth DynFlags
dflags))
mkSRTLit DynFlags
dflags CLabel
_ Maybe CLabel
Nothing    = ([], Integer -> Width -> CmmLit
CmmInt Integer
0 (DynFlags -> Width
halfWordWidth DynFlags
dflags))
mkSRTLit DynFlags
dflags CLabel
_ (Just CLabel
lbl) = ([CLabel -> CmmLit
CmmLabel CLabel
lbl], Integer -> Width -> CmmLit
CmmInt Integer
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 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 DynFlags
dflags CLabel
info_lbl (CmmLabel CLabel
lbl)
  | DynFlags -> Bool
tablesNextToCode DynFlags
dflags
  = CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
lbl CLabel
info_lbl Int
0 (DynFlags -> Width
wordWidth DynFlags
dflags)
makeRelativeRefTo DynFlags
dflags CLabel
info_lbl (CmmLabelOff CLabel
lbl 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 DynFlags
_ CLabel
_ 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 DynFlags
dflags [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 Integer
0
                     [StgWord
b] -> StgWord
b
                     Bitmap
_   -> String -> StgWord
forall a. String -> a
panic String
"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 DynFlags
dflags (CmmLit
type_descr, CmmLit
closure_descr) Int
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
    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 DynFlags
dflags ProfilingInfo
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 DynFlags
_ (ProfilingInfo ConstrDescription
td ConstrDescription
cd)
  = do { (CmmLit
td_lit, 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
       ; (CmmLit
cd_lit, 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 :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit :: ConstrDescription
-> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
newStringLit 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 DynFlags
dflags = DynFlags -> Integer -> StgHalfWord
toStgHalfWord DynFlags
dflags (-Integer
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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 Int
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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 (Int
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 DynFlags
dflags 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)

   (Int
rep_bytes, 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 = DynFlags -> PlatformConstants
platformConstants 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 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 Int
0

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

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

maxStdInfoTableSizeW :: WordOff
maxStdInfoTableSizeW :: Int
maxStdInfoTableSizeW =
  Int
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
+ Int
1 {- srt label -}

stdInfoTableSizeB  :: DynFlags -> ByteOff
stdInfoTableSizeB :: DynFlags -> Int
stdInfoTableSizeB 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 DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
halfWordSize DynFlags
dflags

stdClosureTypeOffset :: DynFlags -> ByteOff
-- Byte offset of the closure type half-word
stdClosureTypeOffset :: DynFlags -> Int
stdClosureTypeOffset 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    DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* DynFlags -> Int
wORD_SIZE DynFlags
dflags
stdNonPtrsOffset :: DynFlags -> Int
stdNonPtrsOffset DynFlags
dflags = DynFlags -> Int
stdInfoTableSizeB DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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
halfWordSize DynFlags
dflags

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