1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where
import GHC.Prelude
import GHC.Platform
import GHC.Unit.Module
import GHC.Utils.Encoding
import GHC.Utils.Outputable
import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
import GHC.Data.FastString (fastStringToShortByteString)
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 Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short 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 _ [] = return ()
emitIpeBufferListNode this_mod ents = do
cfg <- getStgToCmmConfig
let ctx = stgToCmmContext cfg
platform = stgToCmmPlatform cfg
let (cg_ipes, strtab) = flip runState emptyStringTable $ do
module_name <- lookupStringTable
$ utf8EncodeShortByteString
$ renderWithContext ctx (ppr this_mod)
mapM (toCgIPE platform ctx module_name) ents
let -- Emit the fields of an IpeBufferEntry struct.
toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]
toIpeBufferEntry cg_ipe =
[ CmmLabel (ipeInfoTablePtr cg_ipe)
, strtab_offset (ipeTableName cg_ipe)
, strtab_offset (ipeClosureDesc cg_ipe)
, strtab_offset (ipeTypeDesc cg_ipe)
, strtab_offset (ipeLabel cg_ipe)
, strtab_offset (ipeModuleName cg_ipe)
, strtab_offset (ipeSrcFile cg_ipe)
, strtab_offset (ipeSrcSpan cg_ipe)
, int32 0
]
int n = mkIntCLit platform n
int32 n = CmmInt n W32
strtab_offset (StrTabOffset n) = int32 (fromIntegral n)
strings <- newByteStringCLit (getStringTableStrings strtab)
let lits = [ zeroCLit platform -- 'next' field
, strings -- 'strings' field
, int $ length cg_ipes -- 'count' field
] ++ concatMap toIpeBufferEntry cg_ipes
emitDataLits (mkIPELabel this_mod) lits
toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt
toCgIPE platform ctx module_name ipe = do
table_name <- lookupStringTable $ utf8EncodeShortByteString $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe))
closure_desc <- lookupStringTable $ utf8EncodeShortByteString $ show (infoProvEntClosureType ipe)
type_desc <- lookupStringTable $ utf8EncodeShortByteString $ infoTableType ipe
let label_str = maybe "" snd (infoTableProv ipe)
let (src_loc_file, src_loc_span) =
case infoTableProv ipe of
Nothing -> (mempty, "")
Just (span, _) ->
let file = fastStringToShortByteString $ srcSpanFile span
coords = renderWithContext ctx (pprUserRealSpan False span)
in (file, coords)
label <- lookupStringTable $ utf8EncodeShortByteString label_str
src_file <- lookupStringTable src_loc_file
src_span <- lookupStringTable $ utf8EncodeShortByteString src_loc_span
return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe
, ipeTableName = table_name
, ipeClosureDesc = closure_desc
, ipeTypeDesc = type_desc
, ipeLabel = label
, ipeModuleName = module_name
, ipeSrcFile = src_file
, ipeSrcSpan = src_span
}
data CgInfoProvEnt = CgInfoProvEnt
{ ipeInfoTablePtr :: !CLabel
, ipeTableName :: !StrTabOffset
, ipeClosureDesc :: !StrTabOffset
, ipeTypeDesc :: !StrTabOffset
, ipeLabel :: !StrTabOffset
, ipeModuleName :: !StrTabOffset
, ipeSrcFile :: !StrTabOffset
, ipeSrcSpan :: !StrTabOffset
}
data StringTable = StringTable { stStrings :: DList ShortByteString
, stLength :: !Int
, stLookup :: !(M.Map ShortByteString StrTabOffset)
}
newtype StrTabOffset = StrTabOffset Int
emptyStringTable :: StringTable
emptyStringTable =
StringTable { stStrings = emptyDList
, stLength = 0
, stLookup = M.empty
}
getStringTableStrings :: StringTable -> BS.ByteString
getStringTableStrings st =
BSL.toStrict $ BSB.toLazyByteString
$ foldMap f $ dlistToList (stStrings st)
where
f x = BSB.shortByteString x `mappend` BSB.word8 0
lookupStringTable :: ShortByteString -> State StringTable StrTabOffset
lookupStringTable str = state $ \st ->
case M.lookup str (stLookup st) of
Just off -> (off, st)
Nothing ->
let !st' = st { stStrings = stStrings st `snoc` str
, stLength = stLength st + ST.length str + 1
, stLookup = M.insert str res (stLookup st)
}
res = StrTabOffset (stLength st)
in (res, st')
newtype DList a = DList ([a] -> [a])
emptyDList :: DList a
emptyDList = DList id
snoc :: DList a -> a -> DList a
snoc (DList f) x = DList (f . (x:))
dlistToList :: DList a -> [a]
dlistToList (DList f) = f []
|
