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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
{-# LANGUAGE CPP, MagicHash #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
--
-- (c) The University of Glasgow 2002-2006
--
-- | ByteCodeInstrs: Bytecode instruction definitions
module ByteCodeInstr (
BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
import ByteCodeItbls ( ItblPtr )
import StgCmmLayout ( ArgRep(..) )
import PprCore
import Type
import Outputable
import FastString
import Name
import Id
import CoreSyn
import Literal
import DataCon
import VarSet
import PrimOp
import SMRep
import Module (Module)
import GHC.Exts
import Data.Word
-- ----------------------------------------------------------------------------
-- Bytecode instructions
data ProtoBCO a
= ProtoBCO {
protoBCOName :: a, -- name, in some sense
protoBCOInstrs :: [BCInstr], -- instrs
-- arity and GC info
protoBCOBitmap :: [StgWord],
protoBCOBitmapSize :: Word16,
protoBCOArity :: Int,
-- what the BCO came from
protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
-- malloc'd pointers
protoBCOPtrs :: [Either ItblPtr (Ptr ())]
}
type LocalLabel = Word16
data BCInstr
-- Messing with the stack
= STKCHECK Word
-- Push locals (existing bits of the stack)
| PUSH_L !Word16{-offset-}
| PUSH_LL !Word16 !Word16{-2 offsets-}
| PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-}
-- Push a ptr (these all map to PUSH_G really)
| PUSH_G Name
| PUSH_PRIMOP PrimOp
| PUSH_BCO (ProtoBCO Name)
-- Push an alt continuation
| PUSH_ALTS (ProtoBCO Name)
| PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
-- Pushing literals
| PUSH_UBX (Either Literal (Ptr ())) Word16
-- push this int/float/double/addr, on the stack. Word16
-- is # of words to copy from literal pool. Eitherness reflects
-- the difficulty of dealing with MachAddr here, mostly due to
-- the excessive (and unnecessary) restrictions imposed by the
-- designers of the new Foreign library. In particular it is
-- quite impossible to convert an Addr to any other integral
-- type, and it appears impossible to get hold of the bits of
-- an addr, even though we need to assemble BCOs.
-- various kinds of application
| PUSH_APPLY_N
| PUSH_APPLY_V
| PUSH_APPLY_F
| PUSH_APPLY_D
| PUSH_APPLY_L
| PUSH_APPLY_P
| PUSH_APPLY_PP
| PUSH_APPLY_PPP
| PUSH_APPLY_PPPP
| PUSH_APPLY_PPPPP
| PUSH_APPLY_PPPPPP
| SLIDE Word16{-this many-} Word16{-down by this much-}
-- To do with the heap
| ALLOC_AP !Word16 -- make an AP with this many payload words
| ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words
| ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words
| MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}
| MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}
| UNPACK !Word16 -- unpack N words from t.o.s Constr
| PACK DataCon !Word16
-- after assembly, the DataCon is an index into the
-- itbl array
-- For doing case trees
| LABEL LocalLabel
| TESTLT_I Int LocalLabel
| TESTEQ_I Int LocalLabel
| TESTLT_W Word LocalLabel
| TESTEQ_W Word LocalLabel
| TESTLT_F Float LocalLabel
| TESTEQ_F Float LocalLabel
| TESTLT_D Double LocalLabel
| TESTEQ_D Double LocalLabel
-- The Word16 value is a constructor number and therefore
-- stored in the insn stream rather than as an offset into
-- the literal pool.
| TESTLT_P Word16 LocalLabel
| TESTEQ_P Word16 LocalLabel
| CASEFAIL
| JMP LocalLabel
-- For doing calls to C (via glue code generated by libffi)
| CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code
Word16 -- whether or not the call is interruptible
-- (XXX: inefficient, but I don't know
-- what the alignment constraints are.)
-- For doing magic ByteArray passing to foreign calls
| SWIZZLE Word16 -- to the ptr N words down the stack,
Word16 -- add M (interpreted as a signed 16-bit entity)
-- To Infinity And Beyond
| ENTER
| RETURN -- return a lifted value
| RETURN_UBX ArgRep -- return an unlifted value, here's its rep
-- Breakpoints
| BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo
data BreakInfo
= BreakInfo
{ breakInfo_module :: Module
, breakInfo_number :: {-# UNPACK #-} !Int
, breakInfo_vars :: [(Id,Word16)]
, breakInfo_resty :: Type
}
instance Outputable BreakInfo where
ppr info = text "BreakInfo" <+>
parens (ppr (breakInfo_module info) <+>
ppr (breakInfo_number info) <+>
ppr (breakInfo_vars info) <+>
ppr (breakInfo_resty info))
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
instance Outputable a => Outputable (ProtoBCO a) where
ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
= (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
<+> text (show malloced) <> colon)
$$ nest 3 (case origin of
Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
(map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
Right rhs -> pprCoreExprShort (deAnnotate rhs))
$$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
$$ nest 3 (vcat (map ppr instrs))
-- Print enough of the Core expression to enable the reader to find
-- the expression in the -ddump-prep output. That is, we need to
-- include at least a binder.
pprCoreExprShort :: CoreExpr -> SDoc
pprCoreExprShort expr@(Lam _ _)
= let
(bndrs, _) = collectBinders expr
in
char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> ptext (sLit "...")
pprCoreExprShort (Case _expr var _ty _alts)
= ptext (sLit "case of") <+> ppr var
pprCoreExprShort (Let (NonRec x _) _) = ptext (sLit "let") <+> ppr x <+> ptext (sLit ("= ... in ..."))
pprCoreExprShort (Let (Rec bs) _) = ptext (sLit "let {") <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> ptext (sLit "`cast` T")
pprCoreExprShort e = pprCoreExpr e
pprCoreAltShort :: CoreAlt -> SDoc
pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> ptext (sLit "->") <+> pprCoreExprShort expr
instance Outputable BCInstr where
ppr (STKCHECK n) = text "STKCHECK" <+> ppr n
ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa)
ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d
ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz
ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz
ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz
ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words,"
<+> ppr offset <+> text "stkoff"
ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words,"
<+> ppr offset <+> text "stkoff"
ppr (UNPACK sz) = text "UNPACK " <+> ppr sz
ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
ppr (LABEL lab) = text "__" <> ppr lab <> colon
ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab
ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab
ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
ppr CASEFAIL = text "CASEFAIL"
ppr (JMP lab) = text "JMP" <+> ppr lab
ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off
<+> text "marshall code at"
<+> text (show marshall_addr)
<+> (if int == 1
then text "(interruptible)"
else empty)
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
<+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
ppr RETURN = text "RETURN"
ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info
-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
-- correct, or overestimates of reality, to be safe.
-- NOTE: we aggregate the stack use from case alternatives too, so that
-- we can do a single stack check at the beginning of a function only.
-- This could all be made more accurate by keeping track of a proper
-- stack high water mark, but it doesn't seem worth the hassle.
protoBCOStackUse :: ProtoBCO a -> Word
protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
bciStackUse :: BCInstr -> Word
bciStackUse STKCHECK{} = 0
bciStackUse PUSH_L{} = 1
bciStackUse PUSH_LL{} = 2
bciStackUse PUSH_LLL{} = 3
bciStackUse PUSH_G{} = 1
bciStackUse PUSH_PRIMOP{} = 1
bciStackUse PUSH_BCO{} = 1
bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
bciStackUse PUSH_APPLY_N{} = 1
bciStackUse PUSH_APPLY_V{} = 1
bciStackUse PUSH_APPLY_F{} = 1
bciStackUse PUSH_APPLY_D{} = 1
bciStackUse PUSH_APPLY_L{} = 1
bciStackUse PUSH_APPLY_P{} = 1
bciStackUse PUSH_APPLY_PP{} = 1
bciStackUse PUSH_APPLY_PPP{} = 1
bciStackUse PUSH_APPLY_PPPP{} = 1
bciStackUse PUSH_APPLY_PPPPP{} = 1
bciStackUse PUSH_APPLY_PPPPPP{} = 1
bciStackUse ALLOC_AP{} = 1
bciStackUse ALLOC_AP_NOUPD{} = 1
bciStackUse ALLOC_PAP{} = 1
bciStackUse (UNPACK sz) = fromIntegral sz
bciStackUse LABEL{} = 0
bciStackUse TESTLT_I{} = 0
bciStackUse TESTEQ_I{} = 0
bciStackUse TESTLT_W{} = 0
bciStackUse TESTEQ_W{} = 0
bciStackUse TESTLT_F{} = 0
bciStackUse TESTEQ_F{} = 0
bciStackUse TESTLT_D{} = 0
bciStackUse TESTEQ_D{} = 0
bciStackUse TESTLT_P{} = 0
bciStackUse TESTEQ_P{} = 0
bciStackUse CASEFAIL{} = 0
bciStackUse JMP{} = 0
bciStackUse ENTER{} = 0
bciStackUse RETURN{} = 0
bciStackUse RETURN_UBX{} = 1
bciStackUse CCALL{} = 0
bciStackUse SWIZZLE{} = 0
bciStackUse BRK_FUN{} = 0
-- These insns actually reduce stack use, but we need the high-tide level,
-- so can't use this info. Not that it matters much.
bciStackUse SLIDE{} = 0
bciStackUse MKAP{} = 0
bciStackUse MKPAP{} = 0
bciStackUse PACK{} = 1 -- worst case is PACK 0 words
|