ByteCodeInstr.hs 15.3 KB
Newer Older
1
{-# LANGUAGE CPP, MagicHash #-}
2
{-# OPTIONS_GHC -funbox-strict-fields #-}
3 4 5 6 7
--
--  (c) The University of Glasgow 2002-2006
--

-- | 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 16
import GhcPrelude

17
import ByteCodeTypes
18
import GHCi.RemoteTypes
19
import GHCi.FFI (C_ffi_cif)
Simon Marlow's avatar
Simon Marlow committed
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 29 30 31 32 33
import Literal
import DataCon
import VarSet
import PrimOp
import SMRep

34
import Data.Word
35
import GHC.Stack.CCS (CostCentre)
36

37 38
-- ----------------------------------------------------------------------------
-- Bytecode instructions
39

40 41 42 43 44 45 46 47 48
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
49
        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
50
        -- malloc'd pointers
51
        protoBCOFFIs       :: [FFIInfo]
52
   }
53

54
type LocalLabel = Word16
55 56 57

data BCInstr
   -- Messing with the stack
58
   = STKCHECK  Word
59

60
   -- Push locals (existing bits of the stack)
61 62 63
   | PUSH_L    !Word16{-offset-}
   | PUSH_LL   !Word16 !Word16{-2 offsets-}
   | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}
64

65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
   -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
   -- the stack will grow by 8, 16 or 32 bits)
   | PUSH8  !Word16
   | PUSH16 !Word16
   | PUSH32 !Word16

   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
   -- value will take the whole word on the stack (i.e., the stack will gorw by
   -- a word)
   -- This is useful when extracting a packed constructor field for further use.
   -- Currently we expect all values on the stack to take full words, except for
   -- the ones used for PACK (i.e., actually constracting new data types, in
   -- which case we use PUSH{8,16,32})
   | PUSH8_W  !Word16
   | PUSH16_W !Word16
   | PUSH32_W !Word16

82 83 84 85 86
   -- Push a ptr  (these all map to PUSH_G really)
   | PUSH_G       Name
   | PUSH_PRIMOP  PrimOp
   | PUSH_BCO     (ProtoBCO Name)

87
   -- Push an alt continuation
88
   | PUSH_ALTS          (ProtoBCO Name)
Simon Marlow's avatar
Simon Marlow committed
89
   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
90

91 92 93 94 95
   -- Pushing 8, 16 and 32 bits of padding (for constructors).
   | PUSH_PAD8
   | PUSH_PAD16
   | PUSH_PAD32

96
   -- Pushing literals
97 98 99 100
   | PUSH_UBX8  Literal
   | PUSH_UBX16 Literal
   | PUSH_UBX32 Literal
   | PUSH_UBX   Literal Word16
101 102 103 104 105 106 107 108
        -- 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.
109 110 111 112 113 114 115 116 117 118 119 120 121

   -- 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
122

123
   | SLIDE     Word16{-this many-} Word16{-down by this much-}
124

125
   -- To do with the heap
126 127 128 129 130 131 132
   | 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
133 134
                        -- after assembly, the DataCon is an index into the
                        -- itbl array
135 136 137 138
   -- For doing case trees
   | LABEL     LocalLabel
   | TESTLT_I  Int    LocalLabel
   | TESTEQ_I  Int    LocalLabel
139 140
   | TESTLT_W  Word   LocalLabel
   | TESTEQ_W  Word   LocalLabel
141 142 143 144 145
   | TESTLT_F  Float  LocalLabel
   | TESTEQ_F  Float  LocalLabel
   | TESTLT_D  Double LocalLabel
   | TESTEQ_D  Double LocalLabel

146
   -- The Word16 value is a constructor number and therefore
147 148
   -- stored in the insn stream rather than as an offset into
   -- the literal pool.
149 150
   | TESTLT_P  Word16 LocalLabel
   | TESTEQ_P  Word16 LocalLabel
151 152

   | CASEFAIL
153 154
   | JMP              LocalLabel

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 159 160 161 162
                      Word16    -- flags.
                                --
                                -- 0x1: call is interruptible
                                -- 0x2: call is unsafe
                                --
163 164
                                -- (XXX: inefficient, but I don't know
                                -- what the alignment constraints are.)
165 166

   -- For doing magic ByteArray passing to foreign calls
167 168
   | SWIZZLE          Word16 -- to the ptr N words down the stack,
                      Word16 -- add M (interpreted as a signed 16-bit entity)
169

170 171
   -- To Infinity And Beyond
   | ENTER
172
   | RETURN             -- return a lifted value
Simon Marlow's avatar
Simon Marlow committed
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 name instrs bitmap bsize arity origin ffis)
183
      = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
184
                <+> text (show ffis) <> colon)
185 186 187 188
        $$ nest 3 (case origin of
                      Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
                                                       (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
                      Right rhs -> pprCoreExprShort (deAnnotate rhs))
189
        $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
190 191 192 193 194 195 196 197 198 199 200
        $$ 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
201
    char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."
202 203

pprCoreExprShort (Case _expr var _ty _alts)
204
 = text "case of" <+> ppr var
205

206 207
pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))
pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
208 209

pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
210
pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"
211 212 213 214

pprCoreExprShort e = pprCoreExpr e

pprCoreAltShort :: CoreAlt -> SDoc
215
pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr
216

217
instance Outputable BCInstr where
218 219 220 221
   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
222 223 224 225 226 227
   ppr (PUSH8  offset)       = text "PUSH8  " <+> ppr offset
   ppr (PUSH16 offset)       = text "PUSH16  " <+> ppr offset
   ppr (PUSH32 offset)       = text "PUSH32  " <+> ppr offset
   ppr (PUSH8_W  offset)     = text "PUSH8_W  " <+> ppr offset
   ppr (PUSH16_W offset)     = text "PUSH16_W  " <+> ppr offset
   ppr (PUSH32_W offset)     = text "PUSH32_W  " <+> ppr offset
228 229
   ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
   ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."
230
                                               <> ppr op
231 232 233
   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)
234

235 236 237 238 239 240 241
   ppr PUSH_PAD8             = text "PUSH_PAD8"
   ppr PUSH_PAD16            = text "PUSH_PAD16"
   ppr PUSH_PAD32            = text "PUSH_PAD32"

   ppr (PUSH_UBX8  lit)      = text "PUSH_UBX8" <+> ppr lit
   ppr (PUSH_UBX16 lit)      = text "PUSH_UBX16" <+> ppr lit
   ppr (PUSH_UBX32 lit)      = text "PUSH_UBX32" <+> ppr lit
242 243 244 245 246 247 248 249 250 251 252 253
   ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
   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"
254

255 256 257 258
   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
259
   ppr (MKAP offset sz)      = text "MKAP    " <+> ppr sz <+> text "words,"
260 261 262 263
                                               <+> 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
264
   ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz
265 266 267
   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
268 269
   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
270 271 272 273 274 275
   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
276
   ppr CASEFAIL              = text "CASEFAIL"
277
   ppr (JMP lab)             = text "JMP"      <+> ppr lab
278
   ppr (CCALL off marshall_addr flags) = text "CCALL   " <+> ppr off
279
                                                <+> text "marshall code at"
280
                                               <+> text (show marshall_addr)
281 282 283 284
                                               <+> (case flags of
                                                      0x1 -> text "(interruptible)"
                                                      0x2 -> text "(unsafe)"
                                                      _   -> empty)
285 286
   ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
                                               <+> text "by" <+> ppr n
287
   ppr ENTER                 = text "ENTER"
288
   ppr RETURN                = text "RETURN"
289
   ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk
290
   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
291

292
-- -----------------------------------------------------------------------------
293 294
-- The stack use, in words, of each bytecode insn.  These _must_ be
-- correct, or overestimates of reality, to be safe.
295

296 297 298 299 300 301
-- 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.

302
protoBCOStackUse :: ProtoBCO a -> Word
303 304
protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))

305
bciStackUse :: BCInstr -> Word
306
bciStackUse STKCHECK{}            = 0
307 308
bciStackUse PUSH_L{}              = 1
bciStackUse PUSH_LL{}             = 2
309
bciStackUse PUSH_LLL{}            = 3
310 311 312 313 314 315
bciStackUse PUSH8{}               = 1  -- overapproximation
bciStackUse PUSH16{}              = 1  -- overapproximation
bciStackUse PUSH32{}              = 1  -- overapproximation on 64bit arch
bciStackUse PUSH8_W{}             = 1  -- takes exactly 1 word
bciStackUse PUSH16_W{}            = 1  -- takes exactly 1 word
bciStackUse PUSH32_W{}            = 1  -- takes exactly 1 word
316
bciStackUse PUSH_G{}              = 1
317
bciStackUse PUSH_PRIMOP{}         = 1
318
bciStackUse PUSH_BCO{}            = 1
319 320
bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
321 322 323 324 325 326
bciStackUse (PUSH_PAD8)           = 1  -- overapproximation
bciStackUse (PUSH_PAD16)          = 1  -- overapproximation
bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch
bciStackUse (PUSH_UBX8 _)         = 1  -- overapproximation
bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation
bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch
327
bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw
328 329 330 331 332 333 334 335 336 337 338
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
339
bciStackUse ALLOC_AP{}            = 1
340
bciStackUse ALLOC_AP_NOUPD{}      = 1
341
bciStackUse ALLOC_PAP{}           = 1
342
bciStackUse (UNPACK sz)           = fromIntegral sz
343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361
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
362 363 364

-- These insns actually reduce stack use, but we need the high-tide level,
-- so can't use this info.  Not that it matters much.
365 366 367 368
bciStackUse SLIDE{}               = 0
bciStackUse MKAP{}                = 0
bciStackUse MKPAP{}               = 0
bciStackUse PACK{}                = 1 -- worst case is PACK 0 words