module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where

import GHC.Prelude
import GHC.Platform
import GHC.Unit.Module
import GHC.Utils.Outputable

import GHC.Cmm.CLabel
import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.StgToCmm.Config
import GHC.StgToCmm.Lit (newByteStringCLit)
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils

import GHC.Data.ShortText (ShortText)
import qualified GHC.Data.ShortText as ST

import Data.Bifunctor (first)
import qualified Data.Map.Strict as M
import Control.Monad.Trans.State.Strict
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL

emitIpeBufferListNode :: Module
                      -> [InfoProvEnt]
                      -> FCode ()
emitIpeBufferListNode :: Module -> [InfoProvEnt] -> FCode ()
emitIpeBufferListNode Module
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
emitIpeBufferListNode Module
this_mod [InfoProvEnt]
ents = do
    StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
    let ctx :: SDocContext
ctx      = StgToCmmConfig -> SDocContext
stgToCmmContext  StgToCmmConfig
cfg
        platform :: Platform
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg

    let ([CgInfoProvEnt]
cg_ipes, StringTable
strtab) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState StringTable
emptyStringTable forall a b. (a -> b) -> a -> b
$ do
            StrTabOffset
module_name <- ShortText -> State StringTable StrTabOffset
lookupStringTable forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (forall a. Outputable a => a -> SDoc
ppr Module
this_mod)
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Platform
-> SDocContext
-> StrTabOffset
-> InfoProvEnt
-> State StringTable CgInfoProvEnt
toCgIPE Platform
platform SDocContext
ctx StrTabOffset
module_name) [InfoProvEnt]
ents

    let -- Emit the fields of an IpeBufferEntry struct.
        toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]
        toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]
toIpeBufferEntry CgInfoProvEnt
cg_ipe =
            [ CLabel -> CmmLit
CmmLabel (CgInfoProvEnt -> CLabel
ipeInfoTablePtr CgInfoProvEnt
cg_ipe)
            , StrTabOffset -> CmmLit
strtab_offset (CgInfoProvEnt -> StrTabOffset
ipeTableName CgInfoProvEnt
cg_ipe)
            , StrTabOffset -> CmmLit
strtab_offset (CgInfoProvEnt -> StrTabOffset
ipeClosureDesc CgInfoProvEnt
cg_ipe)
            , StrTabOffset -> CmmLit
strtab_offset (CgInfoProvEnt -> StrTabOffset
ipeTypeDesc CgInfoProvEnt
cg_ipe)
            , StrTabOffset -> CmmLit
strtab_offset (CgInfoProvEnt -> StrTabOffset
ipeLabel CgInfoProvEnt
cg_ipe)
            , StrTabOffset -> CmmLit
strtab_offset (CgInfoProvEnt -> StrTabOffset
ipeModuleName CgInfoProvEnt
cg_ipe)
            , StrTabOffset -> CmmLit
strtab_offset (CgInfoProvEnt -> StrTabOffset
ipeSrcLoc CgInfoProvEnt
cg_ipe)
            ]

        int :: Int -> CmmLit
int Int
n = Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
n
        int32 :: Integer -> CmmLit
int32 Integer
n = Integer -> Width -> CmmLit
CmmInt Integer
n Width
W32
        strtab_offset :: StrTabOffset -> CmmLit
strtab_offset (StrTabOffset Int
n) = Integer -> CmmLit
int32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

    CmmLit
strings <- ByteString -> FCode CmmLit
newByteStringCLit (StringTable -> ByteString
getStringTableStrings StringTable
strtab)
    let lits :: [CmmLit]
lits = [ Platform -> CmmLit
zeroCLit Platform
platform     -- 'next' field
               , CmmLit
strings               -- 'strings' field
               , Int -> CmmLit
int forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [CgInfoProvEnt]
cg_ipes  -- 'count' field
               ] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CgInfoProvEnt -> [CmmLit]
toIpeBufferEntry [CgInfoProvEnt]
cg_ipes
    CLabel -> [CmmLit] -> FCode ()
emitDataLits (Module -> CLabel
mkIPELabel Module
this_mod) [CmmLit]
lits

toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt
toCgIPE :: Platform
-> SDocContext
-> StrTabOffset
-> InfoProvEnt
-> State StringTable CgInfoProvEnt
toCgIPE Platform
platform SDocContext
ctx StrTabOffset
module_name InfoProvEnt
ipe = do
    StrTabOffset
table_name <- ShortText -> State StringTable StrTabOffset
lookupStringTable forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle (InfoProvEnt -> CLabel
infoTablePtr InfoProvEnt
ipe))
    StrTabOffset
closure_desc <- ShortText -> State StringTable StrTabOffset
lookupStringTable forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (InfoProvEnt -> Int
infoProvEntClosureType InfoProvEnt
ipe)
    StrTabOffset
type_desc <- ShortText -> State StringTable StrTabOffset
lookupStringTable forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack forall a b. (a -> b) -> a -> b
$ InfoProvEnt -> String
infoTableType InfoProvEnt
ipe
    let (String
src_loc_str, String
label_str) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
"", String
"") (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr)) (InfoProvEnt -> Maybe (RealSrcSpan, String)
infoTableProv InfoProvEnt
ipe)
    StrTabOffset
label <- ShortText -> State StringTable StrTabOffset
lookupStringTable forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack String
label_str
    StrTabOffset
src_loc <- ShortText -> State StringTable StrTabOffset
lookupStringTable forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack String
src_loc_str
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CgInfoProvEnt { ipeInfoTablePtr :: CLabel
ipeInfoTablePtr = InfoProvEnt -> CLabel
infoTablePtr InfoProvEnt
ipe
                           , ipeTableName :: StrTabOffset
ipeTableName = StrTabOffset
table_name
                           , ipeClosureDesc :: StrTabOffset
ipeClosureDesc = StrTabOffset
closure_desc
                           , ipeTypeDesc :: StrTabOffset
ipeTypeDesc = StrTabOffset
type_desc
                           , ipeLabel :: StrTabOffset
ipeLabel = StrTabOffset
label
                           , ipeModuleName :: StrTabOffset
ipeModuleName = StrTabOffset
module_name
                           , ipeSrcLoc :: StrTabOffset
ipeSrcLoc = StrTabOffset
src_loc
                           }

data CgInfoProvEnt = CgInfoProvEnt
                               { CgInfoProvEnt -> CLabel
ipeInfoTablePtr :: !CLabel
                               , CgInfoProvEnt -> StrTabOffset
ipeTableName :: !StrTabOffset
                               , CgInfoProvEnt -> StrTabOffset
ipeClosureDesc :: !StrTabOffset
                               , CgInfoProvEnt -> StrTabOffset
ipeTypeDesc :: !StrTabOffset
                               , CgInfoProvEnt -> StrTabOffset
ipeLabel :: !StrTabOffset
                               , CgInfoProvEnt -> StrTabOffset
ipeModuleName :: !StrTabOffset
                               , CgInfoProvEnt -> StrTabOffset
ipeSrcLoc :: !StrTabOffset
                               }

data StringTable = StringTable { StringTable -> DList ShortText
stStrings :: DList ShortText
                               , StringTable -> Int
stLength :: !Int
                               , StringTable -> Map ShortText StrTabOffset
stLookup :: !(M.Map ShortText StrTabOffset)
                               }

newtype StrTabOffset = StrTabOffset Int

emptyStringTable :: StringTable
emptyStringTable :: StringTable
emptyStringTable =
    StringTable { stStrings :: DList ShortText
stStrings = forall a. DList a
emptyDList
                , stLength :: Int
stLength = Int
0
                , stLookup :: Map ShortText StrTabOffset
stLookup = forall k a. Map k a
M.empty
                }

getStringTableStrings :: StringTable -> BS.ByteString
getStringTableStrings :: StringTable -> ByteString
getStringTableStrings StringTable
st =
    ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BSB.toLazyByteString
    forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ShortText -> Builder
f forall a b. (a -> b) -> a -> b
$ forall a. DList a -> [a]
dlistToList (StringTable -> DList ShortText
stStrings StringTable
st)
  where
    f :: ShortText -> Builder
f ShortText
x = ShortByteString -> Builder
BSB.shortByteString (ShortText -> ShortByteString
ST.contents ShortText
x) forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
BSB.word8 Word8
0

lookupStringTable :: ShortText -> State StringTable StrTabOffset
lookupStringTable :: ShortText -> State StringTable StrTabOffset
lookupStringTable ShortText
str = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$ \StringTable
st ->
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ShortText
str (StringTable -> Map ShortText StrTabOffset
stLookup StringTable
st) of
      Just StrTabOffset
off -> (StrTabOffset
off, StringTable
st)
      Maybe StrTabOffset
Nothing ->
          let !st' :: StringTable
st' = StringTable
st { stStrings :: DList ShortText
stStrings = StringTable -> DList ShortText
stStrings StringTable
st forall a. DList a -> a -> DList a
`snoc` ShortText
str
                        , stLength :: Int
stLength  = StringTable -> Int
stLength StringTable
st forall a. Num a => a -> a -> a
+ ShortText -> Int
ST.byteLength ShortText
str forall a. Num a => a -> a -> a
+ Int
1
                        , stLookup :: Map ShortText StrTabOffset
stLookup  = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ShortText
str StrTabOffset
res (StringTable -> Map ShortText StrTabOffset
stLookup StringTable
st)
                        }
              res :: StrTabOffset
res = Int -> StrTabOffset
StrTabOffset (StringTable -> Int
stLength StringTable
st)
          in (StrTabOffset
res, StringTable
st')

newtype DList a = DList ([a] -> [a])

emptyDList :: DList a
emptyDList :: forall a. DList a
emptyDList = forall a. ([a] -> [a]) -> DList a
DList forall a. a -> a
id

snoc :: DList a -> a -> DList a
snoc :: forall a. DList a -> a -> DList a
snoc (DList [a] -> [a]
f) a
x = forall a. ([a] -> [a]) -> DList a
DList ([a] -> [a]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xforall a. a -> [a] -> [a]
:))

dlistToList :: DList a -> [a]
dlistToList :: forall a. DList a -> [a]
dlistToList (DList [a] -> [a]
f) = [a] -> [a]
f []