GHCi support for levity-polymorphic join points
[ghc.git] / compiler / ghci / ByteCodeInstr.hs
1 {-# LANGUAGE CPP, MagicHash #-}
2 {-# OPTIONS_GHC -funbox-strict-fields #-}
3 --
4 -- (c) The University of Glasgow 2002-2006
5 --
6
7 -- | ByteCodeInstrs: Bytecode instruction definitions
8 module ByteCodeInstr (
9 BCInstr(..), ProtoBCO(..), bciStackUse,
10 ) where
11
12 #include "HsVersions.h"
13 #include "../includes/MachDeps.h"
14
15 import GhcPrelude
16
17 import ByteCodeTypes
18 import GHCi.RemoteTypes
19 import GHCi.FFI (C_ffi_cif)
20 import StgCmmLayout ( ArgRep(..) )
21 import PprCore
22 import Outputable
23 import FastString
24 import Name
25 import Unique
26 import Id
27 import CoreSyn
28 import Literal
29 import DataCon
30 import VarSet
31 import PrimOp
32 import SMRep
33
34 import Data.Word
35 import GHC.Stack.CCS (CostCentre)
36
37 -- ----------------------------------------------------------------------------
38 -- Bytecode instructions
39
40 data ProtoBCO a
41 = ProtoBCO {
42 protoBCOName :: a, -- name, in some sense
43 protoBCOInstrs :: [BCInstr], -- instrs
44 -- arity and GC info
45 protoBCOBitmap :: [StgWord],
46 protoBCOBitmapSize :: Word16,
47 protoBCOArity :: Int,
48 -- what the BCO came from, for debugging only
49 protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
50 -- malloc'd pointers
51 protoBCOFFIs :: [FFIInfo]
52 }
53
54 type LocalLabel = Word16
55
56 data BCInstr
57 -- Messing with the stack
58 = STKCHECK Word
59
60 -- Push locals (existing bits of the stack)
61 | PUSH_L !Word16{-offset-}
62 | PUSH_LL !Word16 !Word16{-2 offsets-}
63 | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-}
64
65 -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
66 -- the stack will grow by 8, 16 or 32 bits)
67 | PUSH8 !Word16
68 | PUSH16 !Word16
69 | PUSH32 !Word16
70
71 -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
72 -- value will take the whole word on the stack (i.e., the stack will gorw by
73 -- a word)
74 -- This is useful when extracting a packed constructor field for further use.
75 -- Currently we expect all values on the stack to take full words, except for
76 -- the ones used for PACK (i.e., actually constracting new data types, in
77 -- which case we use PUSH{8,16,32})
78 | PUSH8_W !Word16
79 | PUSH16_W !Word16
80 | PUSH32_W !Word16
81
82 -- Push a ptr (these all map to PUSH_G really)
83 | PUSH_G Name
84 | PUSH_PRIMOP PrimOp
85 | PUSH_BCO (ProtoBCO Name)
86
87 -- Push an alt continuation
88 | PUSH_ALTS (ProtoBCO Name)
89 | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
90
91 -- Pushing 8, 16 and 32 bits of padding (for constructors).
92 | PUSH_PAD8
93 | PUSH_PAD16
94 | PUSH_PAD32
95
96 -- Pushing literals
97 | PUSH_UBX8 Literal
98 | PUSH_UBX16 Literal
99 | PUSH_UBX32 Literal
100 | PUSH_UBX Literal Word16
101 -- push this int/float/double/addr, on the stack. Word16
102 -- is # of words to copy from literal pool. Eitherness reflects
103 -- the difficulty of dealing with MachAddr here, mostly due to
104 -- the excessive (and unnecessary) restrictions imposed by the
105 -- designers of the new Foreign library. In particular it is
106 -- quite impossible to convert an Addr to any other integral
107 -- type, and it appears impossible to get hold of the bits of
108 -- an addr, even though we need to assemble BCOs.
109
110 -- various kinds of application
111 | PUSH_APPLY_N
112 | PUSH_APPLY_V
113 | PUSH_APPLY_F
114 | PUSH_APPLY_D
115 | PUSH_APPLY_L
116 | PUSH_APPLY_P
117 | PUSH_APPLY_PP
118 | PUSH_APPLY_PPP
119 | PUSH_APPLY_PPPP
120 | PUSH_APPLY_PPPPP
121 | PUSH_APPLY_PPPPPP
122
123 | SLIDE Word16{-this many-} Word16{-down by this much-}
124
125 -- To do with the heap
126 | ALLOC_AP !Word16 -- make an AP with this many payload words
127 | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words
128 | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words
129 | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}
130 | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}
131 | UNPACK !Word16 -- unpack N words from t.o.s Constr
132 | PACK DataCon !Word16
133 -- after assembly, the DataCon is an index into the
134 -- itbl array
135 -- For doing case trees
136 | LABEL LocalLabel
137 | TESTLT_I Int LocalLabel
138 | TESTEQ_I Int LocalLabel
139 | TESTLT_W Word LocalLabel
140 | TESTEQ_W Word LocalLabel
141 | TESTLT_F Float LocalLabel
142 | TESTEQ_F Float LocalLabel
143 | TESTLT_D Double LocalLabel
144 | TESTEQ_D Double LocalLabel
145
146 -- The Word16 value is a constructor number and therefore
147 -- stored in the insn stream rather than as an offset into
148 -- the literal pool.
149 | TESTLT_P Word16 LocalLabel
150 | TESTEQ_P Word16 LocalLabel
151
152 | CASEFAIL
153 | JMP LocalLabel
154
155 -- For doing calls to C (via glue code generated by libffi)
156 | CCALL Word16 -- stack frame size
157 (RemotePtr C_ffi_cif) -- addr of the glue code
158 Word16 -- flags.
159 --
160 -- 0x1: call is interruptible
161 -- 0x2: call is unsafe
162 --
163 -- (XXX: inefficient, but I don't know
164 -- what the alignment constraints are.)
165
166 -- For doing magic ByteArray passing to foreign calls
167 | SWIZZLE Word16 -- to the ptr N words down the stack,
168 Word16 -- add M (interpreted as a signed 16-bit entity)
169
170 -- To Infinity And Beyond
171 | ENTER
172 | RETURN -- return a lifted value
173 | RETURN_UBX ArgRep -- return an unlifted value, here's its rep
174
175 -- Breakpoints
176 | BRK_FUN Word16 Unique (RemotePtr CostCentre)
177
178 -- -----------------------------------------------------------------------------
179 -- Printing bytecode instructions
180
181 instance Outputable a => Outputable (ProtoBCO a) where
182 ppr (ProtoBCO { protoBCOName = name
183 , protoBCOInstrs = instrs
184 , protoBCOBitmap = bitmap
185 , protoBCOBitmapSize = bsize
186 , protoBCOArity = arity
187 , protoBCOExpr = origin
188 , protoBCOFFIs = ffis })
189 = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
190 <+> text (show ffis) <> colon)
191 $$ nest 3 (case origin of
192 Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
193 (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
194 Right rhs -> pprCoreExprShort (deAnnotate rhs))
195 $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
196 $$ nest 3 (vcat (map ppr instrs))
197
198 -- Print enough of the Core expression to enable the reader to find
199 -- the expression in the -ddump-prep output. That is, we need to
200 -- include at least a binder.
201
202 pprCoreExprShort :: CoreExpr -> SDoc
203 pprCoreExprShort expr@(Lam _ _)
204 = let
205 (bndrs, _) = collectBinders expr
206 in
207 char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."
208
209 pprCoreExprShort (Case _expr var _ty _alts)
210 = text "case of" <+> ppr var
211
212 pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))
213 pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
214
215 pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
216 pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"
217
218 pprCoreExprShort e = pprCoreExpr e
219
220 pprCoreAltShort :: CoreAlt -> SDoc
221 pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr
222
223 instance Outputable BCInstr where
224 ppr (STKCHECK n) = text "STKCHECK" <+> ppr n
225 ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset
226 ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2
227 ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
228 ppr (PUSH8 offset) = text "PUSH8 " <+> ppr offset
229 ppr (PUSH16 offset) = text "PUSH16 " <+> ppr offset
230 ppr (PUSH32 offset) = text "PUSH32 " <+> ppr offset
231 ppr (PUSH8_W offset) = text "PUSH8_W " <+> ppr offset
232 ppr (PUSH16_W offset) = text "PUSH16_W " <+> ppr offset
233 ppr (PUSH32_W offset) = text "PUSH32_W " <+> ppr offset
234 ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
235 ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
236 <> ppr op
237 ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
238 ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
239 ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
240
241 ppr PUSH_PAD8 = text "PUSH_PAD8"
242 ppr PUSH_PAD16 = text "PUSH_PAD16"
243 ppr PUSH_PAD32 = text "PUSH_PAD32"
244
245 ppr (PUSH_UBX8 lit) = text "PUSH_UBX8" <+> ppr lit
246 ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit
247 ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit
248 ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
249 ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
250 ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
251 ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
252 ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
253 ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
254 ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
255 ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
256 ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
257 ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
258 ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
259 ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
260
261 ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d
262 ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz
263 ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz
264 ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz
265 ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words,"
266 <+> ppr offset <+> text "stkoff"
267 ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words,"
268 <+> ppr offset <+> text "stkoff"
269 ppr (UNPACK sz) = text "UNPACK " <+> ppr sz
270 ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
271 ppr (LABEL lab) = text "__" <> ppr lab <> colon
272 ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
273 ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
274 ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
275 ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
276 ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
277 ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
278 ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
279 ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab
280 ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab
281 ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
282 ppr CASEFAIL = text "CASEFAIL"
283 ppr (JMP lab) = text "JMP" <+> ppr lab
284 ppr (CCALL off marshall_addr flags) = text "CCALL " <+> ppr off
285 <+> text "marshall code at"
286 <+> text (show marshall_addr)
287 <+> (case flags of
288 0x1 -> text "(interruptible)"
289 0x2 -> text "(unsafe)"
290 _ -> empty)
291 ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
292 <+> text "by" <+> ppr n
293 ppr ENTER = text "ENTER"
294 ppr RETURN = text "RETURN"
295 ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
296 ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
297
298 -- -----------------------------------------------------------------------------
299 -- The stack use, in words, of each bytecode insn. These _must_ be
300 -- correct, or overestimates of reality, to be safe.
301
302 -- NOTE: we aggregate the stack use from case alternatives too, so that
303 -- we can do a single stack check at the beginning of a function only.
304
305 -- This could all be made more accurate by keeping track of a proper
306 -- stack high water mark, but it doesn't seem worth the hassle.
307
308 protoBCOStackUse :: ProtoBCO a -> Word
309 protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
310
311 bciStackUse :: BCInstr -> Word
312 bciStackUse STKCHECK{} = 0
313 bciStackUse PUSH_L{} = 1
314 bciStackUse PUSH_LL{} = 2
315 bciStackUse PUSH_LLL{} = 3
316 bciStackUse PUSH8{} = 1 -- overapproximation
317 bciStackUse PUSH16{} = 1 -- overapproximation
318 bciStackUse PUSH32{} = 1 -- overapproximation on 64bit arch
319 bciStackUse PUSH8_W{} = 1 -- takes exactly 1 word
320 bciStackUse PUSH16_W{} = 1 -- takes exactly 1 word
321 bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word
322 bciStackUse PUSH_G{} = 1
323 bciStackUse PUSH_PRIMOP{} = 1
324 bciStackUse PUSH_BCO{} = 1
325 bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
326 bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
327 bciStackUse (PUSH_PAD8) = 1 -- overapproximation
328 bciStackUse (PUSH_PAD16) = 1 -- overapproximation
329 bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch
330 bciStackUse (PUSH_UBX8 _) = 1 -- overapproximation
331 bciStackUse (PUSH_UBX16 _) = 1 -- overapproximation
332 bciStackUse (PUSH_UBX32 _) = 1 -- overapproximation on 64bit arch
333 bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
334 bciStackUse PUSH_APPLY_N{} = 1
335 bciStackUse PUSH_APPLY_V{} = 1
336 bciStackUse PUSH_APPLY_F{} = 1
337 bciStackUse PUSH_APPLY_D{} = 1
338 bciStackUse PUSH_APPLY_L{} = 1
339 bciStackUse PUSH_APPLY_P{} = 1
340 bciStackUse PUSH_APPLY_PP{} = 1
341 bciStackUse PUSH_APPLY_PPP{} = 1
342 bciStackUse PUSH_APPLY_PPPP{} = 1
343 bciStackUse PUSH_APPLY_PPPPP{} = 1
344 bciStackUse PUSH_APPLY_PPPPPP{} = 1
345 bciStackUse ALLOC_AP{} = 1
346 bciStackUse ALLOC_AP_NOUPD{} = 1
347 bciStackUse ALLOC_PAP{} = 1
348 bciStackUse (UNPACK sz) = fromIntegral sz
349 bciStackUse LABEL{} = 0
350 bciStackUse TESTLT_I{} = 0
351 bciStackUse TESTEQ_I{} = 0
352 bciStackUse TESTLT_W{} = 0
353 bciStackUse TESTEQ_W{} = 0
354 bciStackUse TESTLT_F{} = 0
355 bciStackUse TESTEQ_F{} = 0
356 bciStackUse TESTLT_D{} = 0
357 bciStackUse TESTEQ_D{} = 0
358 bciStackUse TESTLT_P{} = 0
359 bciStackUse TESTEQ_P{} = 0
360 bciStackUse CASEFAIL{} = 0
361 bciStackUse JMP{} = 0
362 bciStackUse ENTER{} = 0
363 bciStackUse RETURN{} = 0
364 bciStackUse RETURN_UBX{} = 1
365 bciStackUse CCALL{} = 0
366 bciStackUse SWIZZLE{} = 0
367 bciStackUse BRK_FUN{} = 0
368
369 -- These insns actually reduce stack use, but we need the high-tide level,
370 -- so can't use this info. Not that it matters much.
371 bciStackUse SLIDE{} = 0
372 bciStackUse MKAP{} = 0
373 bciStackUse MKPAP{} = 0
374 bciStackUse PACK{} = 1 -- worst case is PACK 0 words