ByteCodeAsm.hs 20 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
pcapriotti's avatar
pcapriotti committed
159
160
161
162
assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
  -- pass 1: collect up the offsets of the local labels.
  let asm = mapM_ (assembleI dflags) instrs

163
      initial_offset = 0
pcapriotti's avatar
pcapriotti committed
164
165
166
167
168
169
170
171
172

      -- 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.
173
      (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
pcapriotti's avatar
pcapriotti committed
174
      ((n_insns, lbl_map), long_jumps)
175
        | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
pcapriotti's avatar
pcapriotti committed
176
177
        | otherwise = ((n_insns0, lbl_map0), False)

pcapriotti's avatar
pcapriotti committed
178
179
      env :: Word16 -> Word
      env lbl = fromMaybe
pcapriotti's avatar
pcapriotti committed
180
181
182
183
        (pprPanic "assembleBCO.findLabel" (ppr lbl))
        (Map.lookup lbl lbl_map)

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

  -- precomputed size should be equal to final size
188
  ASSERT(n_insns == sizeSS final_insns) return ()
pcapriotti's avatar
pcapriotti committed
189
190

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

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

202
mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64
203
204
205
206
207
208
-- 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
209

210
-- instrs nonptrs ptrs
Ian Lynagh's avatar
Ian Lynagh committed
211
type AsmState = (SizedSeq Word16,
212
213
                 SizedSeq BCONPtr,
                 SizedSeq BCOPtr)
214

pcapriotti's avatar
pcapriotti committed
215
216
217
218
data Operand
  = Op Word
  | SmallOp Word16
  | LabelOp Word16
219
-- (unused)  | LargeOp Word
pcapriotti's avatar
pcapriotti committed
220
221

data Assembler a
222
223
  = AllocPtr (IO BCOPtr) (Word -> Assembler a)
  | AllocLit [BCONPtr] (Word -> Assembler a)
pcapriotti's avatar
pcapriotti committed
224
225
226
227
  | AllocLabel Word16 (Assembler a)
  | Emit Word16 [Operand] (Assembler a)
  | NullAsm a

Austin Seipp's avatar
Austin Seipp committed
228
229
230
231
instance Functor Assembler where
    fmap = liftM

instance Applicative Assembler where
232
    pure = NullAsm
Austin Seipp's avatar
Austin Seipp committed
233
234
    (<*>) = ap

pcapriotti's avatar
pcapriotti committed
235
236
237
238
239
240
241
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)

242
ioptr :: IO BCOPtr -> Assembler Word
pcapriotti's avatar
pcapriotti committed
243
244
ioptr p = AllocPtr p return

245
ptr :: BCOPtr -> Assembler Word
pcapriotti's avatar
pcapriotti committed
246
247
ptr = ioptr . return

248
lit :: [BCONPtr] -> Assembler Word
pcapriotti's avatar
pcapriotti committed
249
250
251
252
253
254
255
256
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
257
258
259
260
type LabelEnv = Word16 -> Word

largeOp :: Bool -> Operand -> Bool
largeOp long_jumps op = case op of
261
262
263
264
   SmallOp _ -> False
   Op w      -> isLarge w
   LabelOp _ -> long_jumps
-- LargeOp _ -> True
pcapriotti's avatar
pcapriotti committed
265

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

type LabelEnvMap = Map Word16 Word

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

306
307
inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm dflags long_jumps initial_offset
pcapriotti's avatar
pcapriotti committed
308
309
310
311
312
313
314
315
316
317
318
319
  = 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
320
321
322
323
        size = sum (map count ops) + 1
        largeOps = any (largeOp long_jumps) ops
        count (SmallOp _) = 1
        count (LabelOp _) = count (Op 0)
324
        count (Op _) = if largeOps then largeArg16s dflags else 1
325
--      count (LargeOp _) = largeArg16s dflags
326

327
-- Bring in all the bci_ bytecode constants.
Simon Marlow's avatar
Simon Marlow committed
328
#include "rts/Bytecodes.h"
329

330
largeArgInstr :: Word16 -> Word16
331
332
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci

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

345
346
347
largeArg16s :: DynFlags -> Word
largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
                   | otherwise                      = 2
348

pcapriotti's avatar
pcapriotti committed
349
350
351
352
353
354
355
356
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]
357
358
359
360
361
362
  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
363
  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
364
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
365
  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
366
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
367
368
  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
369
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
370
371
  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
372
                                 emit bci_PUSH_ALTS [Op p]
pcapriotti's avatar
pcapriotti committed
373
374
375
  PUSH_ALTS_UNLIFTED proto pk
                           -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
376
                                 emit (push_alts pk) [Op p]
377
378
379
380
381
382
383
384
385
  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]
386
  PUSH_UBX lit nws         -> do np <- literal lit
387
                                 emit bci_PUSH_UBX [Op np, SmallOp nws]
pcapriotti's avatar
pcapriotti committed
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408

  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)]
409
                                 emit bci_PACK [Op itbl_no, SmallOp sz]
pcapriotti's avatar
pcapriotti committed
410
411
  LABEL     lbl            -> label lbl
  TESTLT_I  i l            -> do np <- int i
412
                                 emit bci_TESTLT_I [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
413
  TESTEQ_I  i l            -> do np <- int i
414
                                 emit bci_TESTEQ_I [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
415
  TESTLT_W  w l            -> do np <- word w
416
                                 emit bci_TESTLT_W [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
417
  TESTEQ_W  w l            -> do np <- word w
418
                                 emit bci_TESTEQ_W [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
419
  TESTLT_F  f l            -> do np <- float f
420
                                 emit bci_TESTLT_F [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
421
  TESTEQ_F  f l            -> do np <- float f
422
                                 emit bci_TESTEQ_F [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
423
  TESTLT_D  d l            -> do np <- double d
424
                                 emit bci_TESTLT_D [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
425
  TESTEQ_D  d l            -> do np <- double d
426
                                 emit bci_TESTEQ_D [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
427
428
429
430
431
432
433
434
435
  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
436
                                 emit bci_CCALL [SmallOp off, Op np, SmallOp i]
437
438
439
440
441
  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
442
443

  where
Sylvain Henry's avatar
Sylvain Henry committed
444
    literal (LitLabel fs (Just sz) _)
pcapriotti's avatar
pcapriotti committed
445
446
447
448
     | 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
449
450
451
452
453
454
455
    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
456
457
458
459
460
461
462
    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
463
    -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
464
465
    -- likely to elicit a crash (rather than corrupt memory) in case absence
    -- analysis messed up.
Sylvain Henry's avatar
Sylvain Henry committed
466
    literal LitRubbish         = int 0
pcapriotti's avatar
pcapriotti committed
467
468

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

477
478
isLarge :: Word -> Bool
isLarge n = n > 65535
479

Simon Marlow's avatar
Simon Marlow committed
480
push_alts :: ArgRep -> Word16
481
482
483
484
485
486
487
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"
488
push_alts V32 = error "push_alts: vector"
489
push_alts V64 = error "push_alts: vector"
Simon Marlow's avatar
Simon Marlow committed
490
491

return_ubx :: ArgRep -> Word16
492
493
494
495
496
497
498
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"
499
return_ubx V32 = error "return_ubx: vector"
500
return_ubx V64 = error "return_ubx: vector"
501

502
503
504
-- 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.
505
506
507
508
mkLitI   ::             Int    -> [Word]
mkLitF   ::             Float  -> [Word]
mkLitD   :: DynFlags -> Double -> [Word]
mkLitI64 :: DynFlags -> Int64  -> [Word]
509
510
511
512
513
514
515
516
517
518

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]
     )

519
520
mkLitD dflags d
   | wORD_SIZE dflags == 4
521
522
523
524
525
526
527
528
   = 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]
     )
529
   | wORD_SIZE dflags == 8
530
531
532
533
534
535
536
   = 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
537
538
   | otherwise
   = panic "mkLitD: Bad wORD_SIZE"
539

540
541
mkLitI64 dflags ii
   | wORD_SIZE dflags == 4
542
543
544
545
546
547
548
549
   = 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]
     )
550
   | wORD_SIZE dflags == 8
551
552
553
554
555
556
557
   = 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
558
559
   | otherwise
   = panic "mkLitI64: Bad wORD_SIZE"
560

561
mkLitI i = [fromIntegral i :: Word]
562

Ian Lynagh's avatar
Ian Lynagh committed
563
564
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH