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
|
%
% (c) The University of Glasgow 2000-2006
%
ByteCodeInstrs: Bytecode instruction definitions
\begin{code}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
-- for details
module ByteCodeInstr (
BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
import ByteCodeItbls ( ItblPtr )
import Type
import Outputable
import Name
import Id
import CoreSyn
import PprCore
import Literal
import DataCon
import VarSet
import PrimOp
import SMRep
import GHC.Ptr
import Module (Module)
import GHC.Prim
-- ----------------------------------------------------------------------------
-- Bytecode instructions
data ProtoBCO a
= ProtoBCO {
protoBCOName :: a, -- name, in some sense
protoBCOInstrs :: [BCInstr], -- instrs
-- arity and GC info
protoBCOBitmap :: [StgWord],
protoBCOBitmapSize :: Int,
protoBCOArity :: Int,
-- what the BCO came from
protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
-- malloc'd pointers
protoBCOPtrs :: [Either ItblPtr (Ptr ())]
}
type LocalLabel = Int
data BCInstr
-- Messing with the stack
= STKCHECK Int
-- Push locals (existing bits of the stack)
| PUSH_L !Int{-offset-}
| PUSH_LL !Int !Int{-2 offsets-}
| PUSH_LLL !Int !Int !Int{-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) CgRep
-- Pushing literals
| PUSH_UBX (Either Literal (Ptr ())) Int
-- push this int/float/double/addr, on the stack. Int
-- 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 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 Int{-this many-} Int{-down by this much-}
-- To do with the heap
| ALLOC_AP !Int -- make an AP with this many payload words
| ALLOC_PAP !Int !Int -- make a PAP with this arity / payload words
| MKAP !Int{-ptr to AP is this far down stack-} !Int{-# words-}
| MKPAP !Int{-ptr to PAP is this far down stack-} !Int{-# words-}
| UNPACK !Int -- unpack N words from t.o.s Constr
| PACK DataCon !Int
-- 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_F Float LocalLabel
| TESTEQ_F Float LocalLabel
| TESTLT_D Double LocalLabel
| TESTEQ_D Double LocalLabel
-- The Int value is a constructor number and therefore
-- stored in the insn stream rather than as an offset into
-- the literal pool.
| TESTLT_P Int LocalLabel
| TESTEQ_P Int LocalLabel
| CASEFAIL
| JMP LocalLabel
-- For doing calls to C (via glue code generated by ByteCodeFFI)
| CCALL Int -- stack frame size
(Ptr ()) -- addr of the glue code
-- For doing magic ByteArray passing to foreign calls
| SWIZZLE Int -- to the ptr N words down the stack,
Int -- add M (interpreted as a signed 16-bit entity)
-- To Infinity And Beyond
| ENTER
| RETURN -- return a lifted value
| RETURN_UBX CgRep -- return an unlifted value, here's its rep
-- Breakpoints
| BRK_FUN (MutableByteArray# RealWorld) Int BreakInfo
data BreakInfo
= BreakInfo
{ breakInfo_module :: Module
, breakInfo_number :: {-# UNPACK #-} !Int
, breakInfo_vars :: [(Id,Int)]
, 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 6 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap))
$$ nest 6 (vcat (map ppr instrs))
$$ case origin of
Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
Right rhs -> pprCoreExpr (deAnnotate rhs)
instance Outputable BCInstr where
ppr (STKCHECK n) = text "STKCHECK" <+> int n
ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int 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) = text "PUSH_BCO" <+> nest 3 (ppr bco)
ppr (PUSH_ALTS bco) = text "PUSH_ALTS " <+> ppr bco
ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco
ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (int 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 " <+> int n <+> int d
ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> int sz
ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> int arity <+> int sz
ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words,"
<+> int offset <+> text "stkoff"
ppr (MKPAP offset sz) = text "MKPAP " <+> int sz <+> text "words,"
<+> int offset <+> text "stkoff"
ppr (UNPACK sz) = text "UNPACK " <+> int sz
ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
ppr (LABEL lab) = text "__" <> int lab <> colon
ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
ppr CASEFAIL = text "CASEFAIL"
ppr (JMP lab) = text "JMP" <+> int lab
ppr (CCALL off marshall_addr) = text "CCALL " <+> int off
<+> text "marshall code at"
<+> text (show marshall_addr)
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> int stkoff
<+> text "by" <+> int 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>" <+> int 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 -> Int
protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
bciStackUse :: BCInstr -> Int
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) = 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_PAP{} = 1
bciStackUse (UNPACK sz) = sz
bciStackUse LABEL{} = 0
bciStackUse TESTLT_I{} = 0
bciStackUse TESTEQ_I{} = 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
\end{code}
|
