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
_ [] = () -> FCode ()
forall a. a -> FCode a
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) = (State StringTable [CgInfoProvEnt]
 -> StringTable -> ([CgInfoProvEnt], StringTable))
-> StringTable
-> State StringTable [CgInfoProvEnt]
-> ([CgInfoProvEnt], StringTable)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State StringTable [CgInfoProvEnt]
-> StringTable -> ([CgInfoProvEnt], StringTable)
forall s a. State s a -> s -> (a, s)
runState StringTable
emptyStringTable (State StringTable [CgInfoProvEnt]
 -> ([CgInfoProvEnt], StringTable))
-> State StringTable [CgInfoProvEnt]
-> ([CgInfoProvEnt], StringTable)
forall a b. (a -> b) -> a -> b
$ do
            StrTabOffset
module_name <- ShortText -> State StringTable StrTabOffset
lookupStringTable (ShortText -> State StringTable StrTabOffset)
-> ShortText -> State StringTable StrTabOffset
forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack (String -> ShortText) -> String -> ShortText
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod)
            (InfoProvEnt -> StateT StringTable Identity CgInfoProvEnt)
-> [InfoProvEnt] -> State StringTable [CgInfoProvEnt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Platform
-> SDocContext
-> StrTabOffset
-> InfoProvEnt
-> StateT StringTable Identity 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 (Int -> Integer
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 (Int -> CmmLit) -> Int -> CmmLit
forall a b. (a -> b) -> a -> b
$ [CgInfoProvEnt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CgInfoProvEnt]
cg_ipes  -- 'count' field
               ] [CmmLit] -> [CmmLit] -> [CmmLit]
forall a. [a] -> [a] -> [a]
++ (CgInfoProvEnt -> [CmmLit]) -> [CgInfoProvEnt] -> [CmmLit]
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
-> StateT StringTable Identity CgInfoProvEnt
toCgIPE Platform
platform SDocContext
ctx StrTabOffset
module_name InfoProvEnt
ipe = do
    StrTabOffset
table_name <- ShortText -> State StringTable StrTabOffset
lookupStringTable (ShortText -> State StringTable StrTabOffset)
-> ShortText -> State StringTable StrTabOffset
forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack (String -> ShortText) -> String -> ShortText
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 (ShortText -> State StringTable StrTabOffset)
-> ShortText -> State StringTable StrTabOffset
forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack (String -> ShortText) -> String -> ShortText
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (InfoProvEnt -> Int
infoProvEntClosureType InfoProvEnt
ipe)
    StrTabOffset
type_desc <- ShortText -> State StringTable StrTabOffset
lookupStringTable (ShortText -> State StringTable StrTabOffset)
-> ShortText -> State StringTable StrTabOffset
forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack (String -> ShortText) -> String -> ShortText
forall a b. (a -> b) -> a -> b
$ InfoProvEnt -> String
infoTableType InfoProvEnt
ipe
    let (String
src_loc_str, String
label_str) = (String, String)
-> ((RealSrcSpan, String) -> (String, String))
-> Maybe (RealSrcSpan, String)
-> (String, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
"", String
"") ((RealSrcSpan -> String)
-> (RealSrcSpan, String) -> (String, String)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (SDoc -> String) -> (RealSrcSpan -> SDoc) -> RealSrcSpan -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr)) (InfoProvEnt -> Maybe (RealSrcSpan, String)
infoTableProv InfoProvEnt
ipe)
    StrTabOffset
label <- ShortText -> State StringTable StrTabOffset
lookupStringTable (ShortText -> State StringTable StrTabOffset)
-> ShortText -> State StringTable StrTabOffset
forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack String
label_str
    StrTabOffset
src_loc <- ShortText -> State StringTable StrTabOffset
lookupStringTable (ShortText -> State StringTable StrTabOffset)
-> ShortText -> State StringTable StrTabOffset
forall a b. (a -> b) -> a -> b
$ String -> ShortText
ST.pack String
src_loc_str
    CgInfoProvEnt -> StateT StringTable Identity CgInfoProvEnt
forall a. a -> StateT StringTable Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoProvEnt -> StateT StringTable Identity CgInfoProvEnt)
-> CgInfoProvEnt -> StateT StringTable Identity CgInfoProvEnt
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 = DList ShortText
forall a. DList a
emptyDList
                , stLength :: Int
stLength = Int
0
                , stLookup :: Map ShortText StrTabOffset
stLookup = Map ShortText StrTabOffset
forall k a. Map k a
M.empty
                }

getStringTableStrings :: StringTable -> BS.ByteString
getStringTableStrings :: StringTable -> ByteString
getStringTableStrings StringTable
st =
    ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BSB.toLazyByteString
    (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ (ShortText -> Builder) -> [ShortText] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ShortText -> Builder
f ([ShortText] -> Builder) -> [ShortText] -> Builder
forall a b. (a -> b) -> a -> b
$ DList ShortText -> [ShortText]
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) Builder -> Builder -> Builder
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 = (StringTable -> (StrTabOffset, StringTable))
-> State StringTable StrTabOffset
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((StringTable -> (StrTabOffset, StringTable))
 -> State StringTable StrTabOffset)
-> (StringTable -> (StrTabOffset, StringTable))
-> State StringTable StrTabOffset
forall a b. (a -> b) -> a -> b
$ \StringTable
st ->
    case ShortText -> Map ShortText StrTabOffset -> Maybe StrTabOffset
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 DList ShortText -> ShortText -> DList ShortText
forall a. DList a -> a -> DList a
`snoc` ShortText
str
                        , stLength :: Int
stLength  = StringTable -> Int
stLength StringTable
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ShortText -> Int
ST.byteLength ShortText
str Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                        , stLookup :: Map ShortText StrTabOffset
stLookup  = ShortText
-> StrTabOffset
-> Map ShortText StrTabOffset
-> Map ShortText StrTabOffset
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 = ([a] -> [a]) -> DList a
forall a. ([a] -> [a]) -> DList a
DList [a] -> [a]
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 = ([a] -> [a]) -> DList a
forall a. ([a] -> [a]) -> DList a
DList ([a] -> [a]
f ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:))

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