Support for using libffi to implement FFI calls in GHCi (#631)
[ghc.git] / compiler / ghci / ByteCodeInstr.lhs
1 %
2 % (c) The University of Glasgow 2000-2006
3 %
4 ByteCodeInstrs: Bytecode instruction definitions
5
6 \begin{code}
7 {-# OPTIONS_GHC -funbox-strict-fields #-}
8
9 {-# OPTIONS -w #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 -- for details
15
16 module ByteCodeInstr ( 
17         BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) 
18   ) where
19
20 #include "HsVersions.h"
21 #include "../includes/MachDeps.h"
22
23 import ByteCodeItbls    ( ItblPtr )
24
25 import Type
26 import Outputable
27 import Name
28 import Id
29 import CoreSyn
30 import PprCore
31 import Literal
32 import DataCon
33 import VarSet
34 import PrimOp
35 import SMRep
36
37 import GHC.Ptr
38
39 import Module (Module)
40 import GHC.Exts
41
42
43 -- ----------------------------------------------------------------------------
44 -- Bytecode instructions
45
46 data ProtoBCO a 
47    = ProtoBCO { 
48         protoBCOName       :: a,          -- name, in some sense
49         protoBCOInstrs     :: [BCInstr],  -- instrs
50         -- arity and GC info
51         protoBCOBitmap     :: [StgWord],
52         protoBCOBitmapSize :: Int,
53         protoBCOArity      :: Int,
54         -- what the BCO came from
55         protoBCOExpr       :: Either  [AnnAlt Id VarSet] (AnnExpr Id VarSet),
56         -- malloc'd pointers
57         protoBCOPtrs       :: [Either ItblPtr (Ptr ())]
58    }
59
60 type LocalLabel = Int
61
62 data BCInstr
63    -- Messing with the stack
64    = STKCHECK  Int
65
66    -- Push locals (existing bits of the stack)
67    | PUSH_L    !Int{-offset-}
68    | PUSH_LL   !Int !Int{-2 offsets-}
69    | PUSH_LLL  !Int !Int !Int{-3 offsets-}
70
71    -- Push a ptr  (these all map to PUSH_G really)
72    | PUSH_G       Name
73    | PUSH_PRIMOP  PrimOp
74    | PUSH_BCO     (ProtoBCO Name)
75
76    -- Push an alt continuation
77    | PUSH_ALTS          (ProtoBCO Name)
78    | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep
79
80    -- Pushing literals
81    | PUSH_UBX  (Either Literal (Ptr ())) Int
82         -- push this int/float/double/addr, on the stack.  Int
83         -- is # of words to copy from literal pool.  Eitherness reflects
84         -- the difficulty of dealing with MachAddr here, mostly due to
85         -- the excessive (and unnecessary) restrictions imposed by the
86         -- designers of the new Foreign library.  In particular it is
87         -- quite impossible to convert an Addr to any other integral
88         -- type, and it appears impossible to get hold of the bits of
89         -- an addr, even though we need to to assemble BCOs.
90
91    -- various kinds of application
92    | PUSH_APPLY_N
93    | PUSH_APPLY_V
94    | PUSH_APPLY_F
95    | PUSH_APPLY_D
96    | PUSH_APPLY_L
97    | PUSH_APPLY_P
98    | PUSH_APPLY_PP
99    | PUSH_APPLY_PPP
100    | PUSH_APPLY_PPPP
101    | PUSH_APPLY_PPPPP
102    | PUSH_APPLY_PPPPPP
103
104    | SLIDE     Int{-this many-} Int{-down by this much-}
105
106    -- To do with the heap
107    | ALLOC_AP  !Int      -- make an AP with this many payload words
108    | ALLOC_AP_NOUPD !Int -- make an AP_NOUPD with this many payload words
109    | ALLOC_PAP !Int !Int -- make a PAP with this arity / payload words
110    | MKAP      !Int{-ptr to AP is this far down stack-} !Int{-# words-}
111    | MKPAP     !Int{-ptr to PAP is this far down stack-} !Int{-# words-}
112    | UNPACK    !Int     -- unpack N words from t.o.s Constr
113    | PACK      DataCon !Int
114                         -- after assembly, the DataCon is an index into the
115                         -- itbl array
116    -- For doing case trees
117    | LABEL     LocalLabel
118    | TESTLT_I  Int    LocalLabel
119    | TESTEQ_I  Int    LocalLabel
120    | TESTLT_F  Float  LocalLabel
121    | TESTEQ_F  Float  LocalLabel
122    | TESTLT_D  Double LocalLabel
123    | TESTEQ_D  Double LocalLabel
124
125    -- The Int value is a constructor number and therefore
126    -- stored in the insn stream rather than as an offset into
127    -- the literal pool.
128    | TESTLT_P  Int    LocalLabel
129    | TESTEQ_P  Int    LocalLabel
130
131    | CASEFAIL
132    | JMP              LocalLabel
133
134    -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
135    | CCALL            Int       -- stack frame size
136                       (Ptr ())  -- addr of the glue code
137
138    -- For doing magic ByteArray passing to foreign calls
139    | SWIZZLE          Int       -- to the ptr N words down the stack,
140                       Int       -- add M (interpreted as a signed 16-bit entity)
141
142    -- To Infinity And Beyond
143    | ENTER
144    | RETURN             -- return a lifted value
145    | RETURN_UBX CgRep -- return an unlifted value, here's its rep
146
147    -- Breakpoints 
148    | BRK_FUN          (MutableByteArray# RealWorld) Int BreakInfo
149
150 data BreakInfo 
151    = BreakInfo
152    { breakInfo_module :: Module
153    , breakInfo_number :: {-# UNPACK #-} !Int
154    , breakInfo_vars   :: [(Id,Int)]
155    , breakInfo_resty  :: Type
156    }
157
158 instance Outputable BreakInfo where
159    ppr info = text "BreakInfo" <+>
160               parens (ppr (breakInfo_module info) <+>
161                       ppr (breakInfo_number info) <+>
162                       ppr (breakInfo_vars info) <+>
163                       ppr (breakInfo_resty info))
164
165 -- -----------------------------------------------------------------------------
166 -- Printing bytecode instructions
167
168 instance Outputable a => Outputable (ProtoBCO a) where
169    ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
170       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity 
171                 <+> text (show malloced) <> colon)
172         $$ nest 6 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap))
173         $$ nest 6 (vcat (map ppr instrs))
174         $$ case origin of
175               Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
176               Right rhs -> pprCoreExpr (deAnnotate rhs)
177
178 instance Outputable BCInstr where
179    ppr (STKCHECK n)          = text "STKCHECK" <+> int n
180    ppr (PUSH_L offset)       = text "PUSH_L  " <+> int offset
181    ppr (PUSH_LL o1 o2)       = text "PUSH_LL " <+> int o1 <+> int o2
182    ppr (PUSH_LLL o1 o2 o3)   = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
183    ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
184    ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers." 
185                                                <> ppr op
186    ppr (PUSH_BCO bco)        = text "PUSH_BCO" <+> nest 3 (ppr bco)
187    ppr (PUSH_ALTS bco)       = text "PUSH_ALTS " <+> ppr bco
188    ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco
189
190    ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
191    ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (int nw) <+> text (show aa)
192    ppr PUSH_APPLY_N             = text "PUSH_APPLY_N"
193    ppr PUSH_APPLY_V             = text "PUSH_APPLY_V"
194    ppr PUSH_APPLY_F             = text "PUSH_APPLY_F"
195    ppr PUSH_APPLY_D             = text "PUSH_APPLY_D"
196    ppr PUSH_APPLY_L             = text "PUSH_APPLY_L"
197    ppr PUSH_APPLY_P             = text "PUSH_APPLY_P"
198    ppr PUSH_APPLY_PP            = text "PUSH_APPLY_PP"
199    ppr PUSH_APPLY_PPP           = text "PUSH_APPLY_PPP"
200    ppr PUSH_APPLY_PPPP          = text "PUSH_APPLY_PPPP"
201    ppr PUSH_APPLY_PPPPP         = text "PUSH_APPLY_PPPPP"
202    ppr PUSH_APPLY_PPPPPP        = text "PUSH_APPLY_PPPPPP"
203
204    ppr (SLIDE n d)           = text "SLIDE   " <+> int n <+> int d
205    ppr (ALLOC_AP sz)         = text "ALLOC_AP   " <+> int sz
206    ppr (ALLOC_AP_NOUPD sz)   = text "ALLOC_AP_NOUPD   " <+> int sz
207    ppr (ALLOC_PAP arity sz)  = text "ALLOC_PAP   " <+> int arity <+> int sz
208    ppr (MKAP offset sz)      = text "MKAP    " <+> int sz <+> text "words," 
209                                                <+> int offset <+> text "stkoff"
210    ppr (MKPAP offset sz)     = text "MKPAP   " <+> int sz <+> text "words,"
211                                                <+> int offset <+> text "stkoff"
212    ppr (UNPACK sz)           = text "UNPACK  " <+> int sz
213    ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz
214    ppr (LABEL     lab)       = text "__"       <> int lab <> colon
215    ppr (TESTLT_I  i lab)     = text "TESTLT_I" <+> int i <+> text "__" <> int lab
216    ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
217    ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> int lab
218    ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
219    ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> int lab
220    ppr (TESTEQ_D  d lab)     = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
221    ppr (TESTLT_P  i lab)     = text "TESTLT_P" <+> int i <+> text "__" <> int lab
222    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
223    ppr CASEFAIL              = text "CASEFAIL"
224    ppr (JMP lab)             = text "JMP"      <+> int lab
225    ppr (CCALL off marshall_addr) = text "CCALL   " <+> int off 
226                                                 <+> text "marshall code at" 
227                                                <+> text (show marshall_addr)
228    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> int stkoff 
229                                                <+> text "by" <+> int n 
230    ppr ENTER                 = text "ENTER"
231    ppr RETURN                = text "RETURN"
232    ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk
233    ppr (BRK_FUN breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> int index <+> ppr info 
234
235 -- -----------------------------------------------------------------------------
236 -- The stack use, in words, of each bytecode insn.  These _must_ be
237 -- correct, or overestimates of reality, to be safe.
238
239 -- NOTE: we aggregate the stack use from case alternatives too, so that
240 -- we can do a single stack check at the beginning of a function only.
241
242 -- This could all be made more accurate by keeping track of a proper
243 -- stack high water mark, but it doesn't seem worth the hassle.
244
245 protoBCOStackUse :: ProtoBCO a -> Int
246 protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
247
248 bciStackUse :: BCInstr -> Int
249 bciStackUse STKCHECK{}            = 0
250 bciStackUse PUSH_L{}              = 1
251 bciStackUse PUSH_LL{}             = 2
252 bciStackUse PUSH_LLL{}            = 3
253 bciStackUse PUSH_G{}              = 1
254 bciStackUse PUSH_PRIMOP{}         = 1
255 bciStackUse PUSH_BCO{}            = 1
256 bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco
257 bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
258 bciStackUse (PUSH_UBX _ nw)       = nw
259 bciStackUse PUSH_APPLY_N{}        = 1
260 bciStackUse PUSH_APPLY_V{}        = 1
261 bciStackUse PUSH_APPLY_F{}        = 1
262 bciStackUse PUSH_APPLY_D{}        = 1
263 bciStackUse PUSH_APPLY_L{}        = 1
264 bciStackUse PUSH_APPLY_P{}        = 1
265 bciStackUse PUSH_APPLY_PP{}       = 1
266 bciStackUse PUSH_APPLY_PPP{}      = 1
267 bciStackUse PUSH_APPLY_PPPP{}     = 1
268 bciStackUse PUSH_APPLY_PPPPP{}    = 1
269 bciStackUse PUSH_APPLY_PPPPPP{}   = 1
270 bciStackUse ALLOC_AP{}            = 1
271 bciStackUse ALLOC_AP_NOUPD{}      = 1
272 bciStackUse ALLOC_PAP{}           = 1
273 bciStackUse (UNPACK sz)           = sz
274 bciStackUse LABEL{}               = 0
275 bciStackUse TESTLT_I{}            = 0
276 bciStackUse TESTEQ_I{}            = 0
277 bciStackUse TESTLT_F{}            = 0
278 bciStackUse TESTEQ_F{}            = 0
279 bciStackUse TESTLT_D{}            = 0
280 bciStackUse TESTEQ_D{}            = 0
281 bciStackUse TESTLT_P{}            = 0
282 bciStackUse TESTEQ_P{}            = 0
283 bciStackUse CASEFAIL{}            = 0
284 bciStackUse JMP{}                 = 0
285 bciStackUse ENTER{}               = 0
286 bciStackUse RETURN{}              = 0
287 bciStackUse RETURN_UBX{}          = 1
288 bciStackUse CCALL{}               = 0
289 bciStackUse SWIZZLE{}             = 0
290 bciStackUse BRK_FUN{}             = 0
291
292 -- These insns actually reduce stack use, but we need the high-tide level,
293 -- so can't use this info.  Not that it matters much.
294 bciStackUse SLIDE{}               = 0
295 bciStackUse MKAP{}                = 0
296 bciStackUse MKPAP{}               = 0
297 bciStackUse PACK{}                = 1 -- worst case is PACK 0 words
298 \end{code}