module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where

import GHC.Prelude
import GHC.Platform
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
import GHC.Data.FastString (unpackFS)

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 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
ipeSrcFile CgInfoProvEnt
cg_ipe)
            , StrTabOffset -> CmmLit
strtab_offset (CgInfoProvEnt -> StrTabOffset
ipeSrcSpan CgInfoProvEnt
cg_ipe)
            , Integer -> CmmLit
int32 Integer
0
            ]

        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 -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform (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 label_str :: String
label_str = String
-> ((RealSrcSpan, String) -> String)
-> Maybe (RealSrcSpan, String)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (RealSrcSpan, String) -> String
forall a b. (a, b) -> b
snd (InfoProvEnt -> Maybe (RealSrcSpan, String)
infoTableProv InfoProvEnt
ipe)
    let (String
src_loc_file, String
src_loc_span) =
            case InfoProvEnt -> Maybe (RealSrcSpan, String)
infoTableProv InfoProvEnt
ipe of
              Maybe (RealSrcSpan, String)
Nothing -> (String
"", String
"")
              Just (RealSrcSpan
span, String
_) ->
                  let file :: String
file = FastString -> String
unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span
                      coords :: String
coords = SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (Bool -> RealSrcSpan -> SDoc
pprUserRealSpan Bool
False RealSrcSpan
span)
                  in (String
file, String
coords)
    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_file <- 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_file
    StrTabOffset
src_span <- 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_span
    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
                           , ipeSrcFile :: StrTabOffset
ipeSrcFile = StrTabOffset
src_file
                           , ipeSrcSpan :: StrTabOffset
ipeSrcSpan = StrTabOffset
src_span
                           }

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
ipeSrcFile :: !StrTabOffset
                               , CgInfoProvEnt -> StrTabOffset
ipeSrcSpan :: !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 = stStrings st `snoc` str
                        , stLength  = stLength st + ST.byteLength str + 1
                        , stLookup  = M.insert str res (stLookup 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 []