ByteCodeAsm.hs 20.2 KB
Newer Older
1
{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}
2
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
3 4 5
--
--  (c) The University of Glasgow 2002-2006
--
6

7
-- | ByteCodeLink: Bytecode assembler and linker
Ian Lynagh's avatar
Ian Lynagh committed
8
module ByteCodeAsm (
9
        assembleBCOs, assembleOneBCO,
10

11
        bcoFreeNames,
Ian Lynagh's avatar
Ian Lynagh committed
12 13
        SizedSeq, sizeSS, ssElts,
        iNTERP_STACK_CHECK_THRESH
14 15 16 17
  ) where

#include "HsVersions.h"

18 19
import GhcPrelude

20
import ByteCodeInstr
21
import ByteCodeItbls
22
import ByteCodeTypes
23
import GHCi.RemoteTypes
24
import GHCi
25

26
import HscTypes
27
import Name
28
import NameSet
29 30 31
import Literal
import TyCon
import FastString
Simon Marlow's avatar
Simon Marlow committed
32
import StgCmmLayout     ( ArgRep(..) )
33
import SMRep
34
import DynFlags
35
import Outputable
36
import Platform
37
import Util
38
import Unique
39
import UniqDSet
40

41 42 43
-- From iserv
import SizedSeq

pcapriotti's avatar
pcapriotti committed
44
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
45
import Control.Monad.ST ( runST )
46 47
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
48

49
import Data.Array.MArray
50 51

import qualified Data.Array.Unboxed as Array
Ian Lynagh's avatar
Ian Lynagh committed
52
import Data.Array.Base  ( UArray(..) )
53

54 55
import Data.Array.Unsafe( castSTUArray )

Ian Lynagh's avatar
Ian Lynagh committed
56
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
57
import Data.Char        ( ord )
58
import Data.List
59
import Data.Map (Map)
pcapriotti's avatar
pcapriotti committed
60
import Data.Maybe (fromMaybe)
61
import qualified Data.Map as Map
62

63 64
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
65

Ian Lynagh's avatar
Ian Lynagh committed
66
-- CompiledByteCode represents the result of byte-code
67 68
-- compiling a bunch of functions and data types

69
-- | Finds external references.  Remember to remove the names
70
-- defined by this group of BCOs themselves
71
bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
72
bcoFreeNames bco
73
  = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]
74
  where
75
    bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
76 77 78
        = unionManyUniqDSets (
             mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :
             mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
Ian Lynagh's avatar
Ian Lynagh committed
79 80
             map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
          )
81

82 83
-- -----------------------------------------------------------------------------
-- The bytecode assembler
84

85 86 87 88 89 90
-- The object format for bytecodes is: 16 bits for the opcode, and 16
-- for each field -- so the code can be considered a sequence of
-- 16-bit ints.  Each field denotes either a stack offset or number of
-- items on the stack (eg SLIDE), and index into the pointer table (eg
-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
-- bytecode address in this BCO.
91 92

-- Top level assembler fn.
93
assembleBCOs
94 95
  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
  -> Maybe ModBreaks
96
  -> IO CompiledByteCode
97
assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
98 99
  itblenv <- mkITbls hsc_env tycons
  bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
100
  (bcos',ptrs) <- mallocStrings hsc_env bcos
101
  return CompiledByteCode
102
    { bc_bcos = bcos'
103 104
    , bc_itbls =  itblenv
    , bc_ffis = concat (map protoBCOFFIs proto_bcos)
105
    , bc_strs = top_strs ++ ptrs
106 107
    , bc_breaks = modbreaks
    }
108

109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
-- Find all the literal strings and malloc them together.  We want to
-- do this because:
--
--  a) It should be done when we compile the module, not each time we relink it
--  b) For -fexternal-interpreter It's more efficient to malloc the strings
--     as a single batch message, especially when compiling in parallel.
--
mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
mallocStrings hsc_env ulbcos = do
  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
  ptrs <- iservCmd hsc_env (MallocStrings bytestrings)
  return (evalState (mapM splice ulbcos) ptrs, ptrs)
 where
  splice bco@UnlinkedBCO{..} = do
    lits <- mapM spliceLit unlinkedBCOLits
    ptrs <- mapM splicePtr unlinkedBCOPtrs
    return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }

  spliceLit (BCONPtrStr _) = do
128 129 130 131 132 133
    rptrs <- get
    case rptrs of
      (RemotePtr p : rest) -> do
        put rest
        return (BCONPtrWord (fromIntegral p))
      _ -> panic "mallocStrings:spliceLit"
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
  spliceLit other = return other

  splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
  splicePtr other = return other

  collect UnlinkedBCO{..} = do
    mapM_ collectLit unlinkedBCOLits
    mapM_ collectPtr unlinkedBCOPtrs

  collectLit (BCONPtrStr bs) = do
    strs <- get
    put (bs:strs)
  collectLit _ = return ()

  collectPtr (BCOPtrBCO bco) = collect bco
  collectPtr _ = return ()


assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO hsc_env pbco = do
  ubco <- assembleBCO (hsc_dflags hsc_env) pbco
  ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
  return ubco'

158
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
159 160 161 162 163
assembleBCO dflags (ProtoBCO { protoBCOName       = nm
                             , protoBCOInstrs     = instrs
                             , protoBCOBitmap     = bitmap
                             , protoBCOBitmapSize = bsize
                             , protoBCOArity      = arity }) = do
pcapriotti's avatar
pcapriotti committed
164 165 166
  -- pass 1: collect up the offsets of the local labels.
  let asm = mapM_ (assembleI dflags) instrs

167
      initial_offset = 0
pcapriotti's avatar
pcapriotti committed
168 169 170 171 172 173 174 175 176

      -- Jump instructions are variable-sized, there are long and short variants
      -- depending on the magnitude of the offset.  However, we can't tell what
      -- size instructions we will need until we have calculated the offsets of
      -- the labels, which depends on the size of the instructions...  So we
      -- first create the label environment assuming that all jumps are short,
      -- and if the final size is indeed small enough for short jumps, we are
      -- done.  Otherwise, we repeat the calculation, and we force all jumps in
      -- this BCO to be long.
177
      (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
pcapriotti's avatar
pcapriotti committed
178
      ((n_insns, lbl_map), long_jumps)
179
        | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
pcapriotti's avatar
pcapriotti committed
180 181
        | otherwise = ((n_insns0, lbl_map0), False)

pcapriotti's avatar
pcapriotti committed
182 183
      env :: Word16 -> Word
      env lbl = fromMaybe
pcapriotti's avatar
pcapriotti committed
184 185 186 187
        (pprPanic "assembleBCO.findLabel" (ppr lbl))
        (Map.lookup lbl lbl_map)

  -- pass 2: run assembler and generate instructions, literals and pointers
188
  let initial_state = (emptySS, emptySS, emptySS)
189
  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm
pcapriotti's avatar
pcapriotti committed
190 191

  -- precomputed size should be equal to final size
192
  ASSERT(n_insns == sizeSS final_insns) return ()
pcapriotti's avatar
pcapriotti committed
193 194

  let asm_insns = ssElts final_insns
195
      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
196
      bitmap_arr = mkBitmapArray bsize bitmap
197
      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
pcapriotti's avatar
pcapriotti committed
198 199 200 201 202 203 204

  -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
  -- objects, since they might get run too early.  Disable this until
  -- we figure out what to do.
  -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))

  return ul_bco
205

206
mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64
207 208 209 210 211 212
-- Here the return type must be an array of Words, not StgWords,
-- because the underlying ByteArray# will end up as a component
-- of a BCO object.
mkBitmapArray bsize bitmap
  = Array.listArray (0, length bitmap) $
      fromIntegral bsize : map (fromInteger . fromStgWord) bitmap
213

214
-- instrs nonptrs ptrs
Ian Lynagh's avatar
Ian Lynagh committed
215
type AsmState = (SizedSeq Word16,
216 217
                 SizedSeq BCONPtr,
                 SizedSeq BCOPtr)
218

pcapriotti's avatar
pcapriotti committed
219 220 221 222
data Operand
  = Op Word
  | SmallOp Word16
  | LabelOp Word16
223
-- (unused)  | LargeOp Word
pcapriotti's avatar
pcapriotti committed
224 225

data Assembler a
226 227
  = AllocPtr (IO BCOPtr) (Word -> Assembler a)
  | AllocLit [BCONPtr] (Word -> Assembler a)
pcapriotti's avatar
pcapriotti committed
228 229 230 231
  | AllocLabel Word16 (Assembler a)
  | Emit Word16 [Operand] (Assembler a)
  | NullAsm a

Austin Seipp's avatar
Austin Seipp committed
232 233 234 235
instance Functor Assembler where
    fmap = liftM

instance Applicative Assembler where
236
    pure = NullAsm
Austin Seipp's avatar
Austin Seipp committed
237 238
    (<*>) = ap

pcapriotti's avatar
pcapriotti committed
239 240 241 242 243 244 245
instance Monad Assembler where
  NullAsm x >>= f = f x
  AllocPtr p k >>= f = AllocPtr p (k >=> f)
  AllocLit l k >>= f = AllocLit l (k >=> f)
  AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)
  Emit w ops k >>= f = Emit w ops (k >>= f)

246
ioptr :: IO BCOPtr -> Assembler Word
pcapriotti's avatar
pcapriotti committed
247 248
ioptr p = AllocPtr p return

249
ptr :: BCOPtr -> Assembler Word
pcapriotti's avatar
pcapriotti committed
250 251
ptr = ioptr . return

252
lit :: [BCONPtr] -> Assembler Word
pcapriotti's avatar
pcapriotti committed
253 254 255 256 257 258 259 260
lit l = AllocLit l return

label :: Word16 -> Assembler ()
label w = AllocLabel w (return ())

emit :: Word16 -> [Operand] -> Assembler ()
emit w ops = Emit w ops (return ())

pcapriotti's avatar
pcapriotti committed
261 262 263 264
type LabelEnv = Word16 -> Word

largeOp :: Bool -> Operand -> Bool
largeOp long_jumps op = case op of
265 266 267 268
   SmallOp _ -> False
   Op w      -> isLarge w
   LabelOp _ -> long_jumps
-- LargeOp _ -> True
pcapriotti's avatar
pcapriotti committed
269

270
runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
271
runAsm dflags long_jumps e = go
pcapriotti's avatar
pcapriotti committed
272 273 274 275
  where
    go (NullAsm x) = return x
    go (AllocPtr p_io k) = do
      p <- lift p_io
276
      w <- state $ \(st_i0,st_l0,st_p0) ->
pcapriotti's avatar
pcapriotti committed
277
        let st_p1 = addToSS st_p0 p
278
        in (sizeSS st_p0, (st_i0,st_l0,st_p1))
pcapriotti's avatar
pcapriotti committed
279 280
      go $ k w
    go (AllocLit lits k) = do
281
      w <- state $ \(st_i0,st_l0,st_p0) ->
pcapriotti's avatar
pcapriotti committed
282
        let st_l1 = addListToSS st_l0 lits
283
        in (sizeSS st_l0, (st_i0,st_l1,st_p0))
pcapriotti's avatar
pcapriotti committed
284 285 286 287 288 289 290 291 292 293
      go $ k w
    go (AllocLabel _ k) = go k
    go (Emit w ops k) = do
      let largeOps = any (largeOp long_jumps) ops
          opcode
            | largeOps = largeArgInstr w
            | otherwise = w
          words = concatMap expand ops
          expand (SmallOp w) = [w]
          expand (LabelOp w) = expand (Op (e w))
294
          expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
295
--        expand (LargeOp w) = largeArg dflags w
296
      state $ \(st_i0,st_l0,st_p0) ->
pcapriotti's avatar
pcapriotti committed
297
        let st_i1 = addListToSS st_i0 (opcode : words)
298
        in ((), (st_i1,st_l0,st_p0))
pcapriotti's avatar
pcapriotti committed
299
      go k
pcapriotti's avatar
pcapriotti committed
300 301 302 303 304 305 306 307 308 309

type LabelEnvMap = Map Word16 Word

data InspectState = InspectState
  { instrCount :: !Word
  , ptrCount :: !Word
  , litCount :: !Word
  , lblEnv :: LabelEnvMap
  }

310 311
inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm dflags long_jumps initial_offset
pcapriotti's avatar
pcapriotti committed
312 313 314 315 316 317 318 319 320 321 322 323
  = go (InspectState initial_offset 0 0 Map.empty)
  where
    go s (NullAsm _) = (instrCount s, lblEnv s)
    go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
      where n = ptrCount s
    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
      where n = litCount s
    go s (AllocLabel lbl k) = go s' k
      where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
    go s (Emit _ ops k) = go s' k
      where
        s' = s { instrCount = instrCount s + size }
pcapriotti's avatar
pcapriotti committed
324 325 326 327
        size = sum (map count ops) + 1
        largeOps = any (largeOp long_jumps) ops
        count (SmallOp _) = 1
        count (LabelOp _) = count (Op 0)
328
        count (Op _) = if largeOps then largeArg16s dflags else 1
329
--      count (LargeOp _) = largeArg16s dflags
330

331
-- Bring in all the bci_ bytecode constants.
Simon Marlow's avatar
Simon Marlow committed
332
#include "rts/Bytecodes.h"
333

334
largeArgInstr :: Word16 -> Word16
335 336
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci

337 338 339
largeArg :: DynFlags -> Word -> [Word16]
largeArg dflags w
 | wORD_SIZE_IN_BITS dflags == 64
340 341 342 343
           = [fromIntegral (w `shiftR` 48),
              fromIntegral (w `shiftR` 32),
              fromIntegral (w `shiftR` 16),
              fromIntegral w]
344
 | wORD_SIZE_IN_BITS dflags == 32
345 346
           = [fromIntegral (w `shiftR` 16),
              fromIntegral w]
347 348
 | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"

349 350 351
largeArg16s :: DynFlags -> Word
largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
                   | otherwise                      = 2
352

pcapriotti's avatar
pcapriotti committed
353 354 355 356 357 358 359 360
assembleI :: DynFlags
          -> BCInstr
          -> Assembler ()
assembleI dflags i = case i of
  STKCHECK n               -> emit bci_STKCHECK [Op n]
  PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]
  PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
  PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
361 362 363 364 365 366
  PUSH8 o1                 -> emit bci_PUSH8 [SmallOp o1]
  PUSH16 o1                -> emit bci_PUSH16 [SmallOp o1]
  PUSH32 o1                -> emit bci_PUSH32 [SmallOp o1]
  PUSH8_W o1               -> emit bci_PUSH8_W [SmallOp o1]
  PUSH16_W o1              -> emit bci_PUSH16_W [SmallOp o1]
  PUSH32_W o1              -> emit bci_PUSH32_W [SmallOp o1]
pcapriotti's avatar
pcapriotti committed
367
  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
368
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
369
  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
370
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
371 372
  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
373
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
374 375
  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
376
                                 emit bci_PUSH_ALTS [Op p]
pcapriotti's avatar
pcapriotti committed
377 378 379
  PUSH_ALTS_UNLIFTED proto pk
                           -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
380
                                 emit (push_alts pk) [Op p]
381 382 383 384 385 386 387 388 389
  PUSH_PAD8                -> emit bci_PUSH_PAD8 []
  PUSH_PAD16               -> emit bci_PUSH_PAD16 []
  PUSH_PAD32               -> emit bci_PUSH_PAD32 []
  PUSH_UBX8 lit            -> do np <- literal lit
                                 emit bci_PUSH_UBX8 [Op np]
  PUSH_UBX16 lit           -> do np <- literal lit
                                 emit bci_PUSH_UBX16 [Op np]
  PUSH_UBX32 lit           -> do np <- literal lit
                                 emit bci_PUSH_UBX32 [Op np]
390
  PUSH_UBX lit nws         -> do np <- literal lit
391
                                 emit bci_PUSH_UBX [Op np, SmallOp nws]
pcapriotti's avatar
pcapriotti committed
392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412

  PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []
  PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []
  PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []
  PUSH_APPLY_D             -> emit bci_PUSH_APPLY_D []
  PUSH_APPLY_L             -> emit bci_PUSH_APPLY_L []
  PUSH_APPLY_P             -> emit bci_PUSH_APPLY_P []
  PUSH_APPLY_PP            -> emit bci_PUSH_APPLY_PP []
  PUSH_APPLY_PPP           -> emit bci_PUSH_APPLY_PPP []
  PUSH_APPLY_PPPP          -> emit bci_PUSH_APPLY_PPPP []
  PUSH_APPLY_PPPPP         -> emit bci_PUSH_APPLY_PPPPP []
  PUSH_APPLY_PPPPPP        -> emit bci_PUSH_APPLY_PPPPPP []

  SLIDE     n by           -> emit bci_SLIDE [SmallOp n, SmallOp by]
  ALLOC_AP  n              -> emit bci_ALLOC_AP [SmallOp n]
  ALLOC_AP_NOUPD n         -> emit bci_ALLOC_AP_NOUPD [SmallOp n]
  ALLOC_PAP arity n        -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
  MKAP      off sz         -> emit bci_MKAP [SmallOp off, SmallOp sz]
  MKPAP     off sz         -> emit bci_MKPAP [SmallOp off, SmallOp sz]
  UNPACK    n              -> emit bci_UNPACK [SmallOp n]
  PACK      dcon sz        -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]
413
                                 emit bci_PACK [Op itbl_no, SmallOp sz]
pcapriotti's avatar
pcapriotti committed
414 415
  LABEL     lbl            -> label lbl
  TESTLT_I  i l            -> do np <- int i
416
                                 emit bci_TESTLT_I [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
417
  TESTEQ_I  i l            -> do np <- int i
418
                                 emit bci_TESTEQ_I [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
419
  TESTLT_W  w l            -> do np <- word w
420
                                 emit bci_TESTLT_W [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
421
  TESTEQ_W  w l            -> do np <- word w
422
                                 emit bci_TESTEQ_W [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
423
  TESTLT_F  f l            -> do np <- float f
424
                                 emit bci_TESTLT_F [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
425
  TESTEQ_F  f l            -> do np <- float f
426
                                 emit bci_TESTEQ_F [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
427
  TESTLT_D  d l            -> do np <- double d
428
                                 emit bci_TESTLT_D [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
429
  TESTEQ_D  d l            -> do np <- double d
430
                                 emit bci_TESTEQ_D [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
431 432 433 434 435 436 437 438 439
  TESTLT_P  i l            -> emit bci_TESTLT_P [SmallOp i, LabelOp l]
  TESTEQ_P  i l            -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]
  CASEFAIL                 -> emit bci_CASEFAIL []
  SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
  JMP       l              -> emit bci_JMP [LabelOp l]
  ENTER                    -> emit bci_ENTER []
  RETURN                   -> emit bci_RETURN []
  RETURN_UBX rep           -> emit (return_ubx rep) []
  CCALL off m_addr i       -> do np <- addr m_addr
440
                                 emit bci_CCALL [SmallOp off, Op np, SmallOp i]
441 442 443 444 445
  BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray
                                 q <- int (getKey uniq)
                                 np <- addr cc
                                 emit bci_BRK_FUN [Op p1, SmallOp index,
                                                   Op q, Op np]
pcapriotti's avatar
pcapriotti committed
446 447

  where
Sylvain Henry's avatar
Sylvain Henry committed
448
    literal (LitLabel fs (Just sz) _)
pcapriotti's avatar
pcapriotti committed
449 450 451 452
     | platformOS (targetPlatform dflags) == OSMinGW32
         = litlabel (appendFS fs (mkFastString ('@':show sz)))
     -- On Windows, stdcall labels have a suffix indicating the no. of
     -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
Sylvain Henry's avatar
Sylvain Henry committed
453 454 455 456 457 458 459
    literal (LitLabel fs _ _) = litlabel fs
    literal LitNullAddr       = int 0
    literal (LitFloat r)      = float (fromRational r)
    literal (LitDouble r)     = double (fromRational r)
    literal (LitChar c)       = int (ord c)
    literal (LitString bs)    = lit [BCONPtrStr bs]
       -- LitString requires a zero-terminator when emitted
460 461 462 463 464 465 466
    literal (LitNumber nt i _) = case nt of
      LitNumInt     -> int (fromIntegral i)
      LitNumWord    -> int (fromIntegral i)
      LitNumInt64   -> int64 (fromIntegral i)
      LitNumWord64  -> int64 (fromIntegral i)
      LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
      LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
Sylvain Henry's avatar
Sylvain Henry committed
467
    -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
468 469
    -- likely to elicit a crash (rather than corrupt memory) in case absence
    -- analysis messed up.
Sylvain Henry's avatar
Sylvain Henry committed
470
    literal LitRubbish         = int 0
pcapriotti's avatar
pcapriotti committed
471 472

    litlabel fs = lit [BCONPtrLbl fs]
473
    addr (RemotePtr a) = words [fromIntegral a]
pcapriotti's avatar
pcapriotti committed
474
    float = words . mkLitF
475
    double = words . mkLitD dflags
pcapriotti's avatar
pcapriotti committed
476
    int = words . mkLitI
477
    int64 = words . mkLitI64 dflags
pcapriotti's avatar
pcapriotti committed
478 479
    words ws = lit (map BCONPtrWord ws)
    word w = words [w]
480

481 482
isLarge :: Word -> Bool
isLarge n = n > 65535
483

Simon Marlow's avatar
Simon Marlow committed
484
push_alts :: ArgRep -> Word16
485 486 487 488 489 490 491
push_alts V   = bci_PUSH_ALTS_V
push_alts P   = bci_PUSH_ALTS_P
push_alts N   = bci_PUSH_ALTS_N
push_alts L   = bci_PUSH_ALTS_L
push_alts F   = bci_PUSH_ALTS_F
push_alts D   = bci_PUSH_ALTS_D
push_alts V16 = error "push_alts: vector"
492
push_alts V32 = error "push_alts: vector"
493
push_alts V64 = error "push_alts: vector"
Simon Marlow's avatar
Simon Marlow committed
494 495

return_ubx :: ArgRep -> Word16
496 497 498 499 500 501 502
return_ubx V   = bci_RETURN_V
return_ubx P   = bci_RETURN_P
return_ubx N   = bci_RETURN_N
return_ubx L   = bci_RETURN_L
return_ubx F   = bci_RETURN_F
return_ubx D   = bci_RETURN_D
return_ubx V16 = error "return_ubx: vector"
503
return_ubx V32 = error "return_ubx: vector"
504
return_ubx V64 = error "return_ubx: vector"
505

506 507 508
-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
-- bit pattern is correct for the host's word size and endianness.
509 510 511 512
mkLitI   ::             Int    -> [Word]
mkLitF   ::             Float  -> [Word]
mkLitD   :: DynFlags -> Double -> [Word]
mkLitI64 :: DynFlags -> Int64  -> [Word]
513 514 515 516 517 518 519 520 521 522

mkLitF f
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 f
        f_arr <- castSTUArray arr
        w0 <- readArray f_arr 0
        return [w0 :: Word]
     )

523 524
mkLitD dflags d
   | wORD_SIZE dflags == 4
525 526 527 528 529 530 531 532
   = runST (do
        arr <- newArray_ ((0::Int),1)
        writeArray arr 0 d
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        w1 <- readArray d_arr 1
        return [w0 :: Word, w1]
     )
533
   | wORD_SIZE dflags == 8
534 535 536 537 538 539 540
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 d
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        return [w0 :: Word]
     )
Ian Lynagh's avatar
Ian Lynagh committed
541 542
   | otherwise
   = panic "mkLitD: Bad wORD_SIZE"
543

544 545
mkLitI64 dflags ii
   | wORD_SIZE dflags == 4
546 547 548 549 550 551 552 553
   = runST (do
        arr <- newArray_ ((0::Int),1)
        writeArray arr 0 ii
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        w1 <- readArray d_arr 1
        return [w0 :: Word,w1]
     )
554
   | wORD_SIZE dflags == 8
555 556 557 558 559 560 561
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 ii
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        return [w0 :: Word]
     )
Ian Lynagh's avatar
Ian Lynagh committed
562 563
   | otherwise
   = panic "mkLitI64: Bad wORD_SIZE"
564

565
mkLitI i = [fromIntegral i :: Word]
566

Ian Lynagh's avatar
Ian Lynagh committed
567 568
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH