ByteCodeAsm.hs 17.4 KB
Newer Older
1 2
{-# LANGUAGE BangPatterns, CPP, MagicHash #-}
{-# 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 9
module ByteCodeAsm (
        assembleBCOs, assembleBCO,
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
import ByteCodeInstr
19
import ByteCodeItbls
20
import ByteCodeTypes
21

22
import HscTypes
23
import Name
24
import NameSet
25 26 27
import Literal
import TyCon
import FastString
Simon Marlow's avatar
Simon Marlow committed
28
import StgCmmLayout     ( ArgRep(..) )
29
import SMRep
30
import DynFlags
31
import Outputable
32
import Platform
33
import Util
34

35 36 37
-- From iserv
import SizedSeq

38
#if __GLASGOW_HASKELL__ < 709
Austin Seipp's avatar
Austin Seipp committed
39
import Control.Applicative (Applicative(..))
40
#endif
pcapriotti's avatar
pcapriotti committed
41
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
42
import Control.Monad.ST ( runST )
43 44
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
45

46
import Data.Array.MArray
47 48

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

51 52
import Data.Array.Unsafe( castSTUArray )

53
import qualified Data.ByteString as B
Ian Lynagh's avatar
Ian Lynagh committed
54
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
55
import Data.Char        ( ord )
56
import Data.List
57
import Data.Map (Map)
pcapriotti's avatar
pcapriotti committed
58
import Data.Maybe (fromMaybe)
59
import qualified Data.Map as Map
60

61 62
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
63

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

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

80 81
-- -----------------------------------------------------------------------------
-- The bytecode assembler
82

83 84 85 86 87 88
-- 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.
89 90

-- Top level assembler fn.
91 92 93 94 95
assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons = do
  itblenv <- mkITbls hsc_env tycons
  bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
  return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos)))
96

97
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
pcapriotti's avatar
pcapriotti committed
98 99 100 101
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

102
      initial_offset = 0
pcapriotti's avatar
pcapriotti committed
103 104 105 106 107 108 109 110 111

      -- 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.
112
      (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
pcapriotti's avatar
pcapriotti committed
113
      ((n_insns, lbl_map), long_jumps)
114
        | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
pcapriotti's avatar
pcapriotti committed
115 116
        | otherwise = ((n_insns0, lbl_map0), False)

pcapriotti's avatar
pcapriotti committed
117 118
      env :: Word16 -> Word
      env lbl = fromMaybe
pcapriotti's avatar
pcapriotti committed
119 120 121 122
        (pprPanic "assembleBCO.findLabel" (ppr lbl))
        (Map.lookup lbl lbl_map)

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

  -- precomputed size should be equal to final size
127
  ASSERT(n_insns == sizeSS final_insns) return ()
pcapriotti's avatar
pcapriotti committed
128 129

  let asm_insns = ssElts final_insns
130
      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
131
      bitmap_arr = mkBitmapArray bsize bitmap
132
      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
pcapriotti's avatar
pcapriotti committed
133 134 135 136 137 138 139

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

141 142 143 144 145 146 147
mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word
-- 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
148

149
-- instrs nonptrs ptrs
Ian Lynagh's avatar
Ian Lynagh committed
150
type AsmState = (SizedSeq Word16,
151 152
                 SizedSeq BCONPtr,
                 SizedSeq BCOPtr)
153

pcapriotti's avatar
pcapriotti committed
154 155 156 157
data Operand
  = Op Word
  | SmallOp Word16
  | LabelOp Word16
158
-- (unused)  | LargeOp Word
pcapriotti's avatar
pcapriotti committed
159 160

data Assembler a
161 162
  = AllocPtr (IO BCOPtr) (Word -> Assembler a)
  | AllocLit [BCONPtr] (Word -> Assembler a)
pcapriotti's avatar
pcapriotti committed
163 164 165 166
  | AllocLabel Word16 (Assembler a)
  | Emit Word16 [Operand] (Assembler a)
  | NullAsm a

Austin Seipp's avatar
Austin Seipp committed
167 168 169 170
instance Functor Assembler where
    fmap = liftM

instance Applicative Assembler where
171
    pure = NullAsm
Austin Seipp's avatar
Austin Seipp committed
172 173
    (<*>) = ap

pcapriotti's avatar
pcapriotti committed
174
instance Monad Assembler where
175
  return = pure
pcapriotti's avatar
pcapriotti committed
176 177 178 179 180 181
  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)

182
ioptr :: IO BCOPtr -> Assembler Word
pcapriotti's avatar
pcapriotti committed
183 184
ioptr p = AllocPtr p return

185
ptr :: BCOPtr -> Assembler Word
pcapriotti's avatar
pcapriotti committed
186 187
ptr = ioptr . return

188
lit :: [BCONPtr] -> Assembler Word
pcapriotti's avatar
pcapriotti committed
189 190 191 192 193 194 195 196
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
197 198 199 200
type LabelEnv = Word16 -> Word

largeOp :: Bool -> Operand -> Bool
largeOp long_jumps op = case op of
201 202 203 204
   SmallOp _ -> False
   Op w      -> isLarge w
   LabelOp _ -> long_jumps
-- LargeOp _ -> True
pcapriotti's avatar
pcapriotti committed
205

206
runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
207
runAsm dflags long_jumps e = go
pcapriotti's avatar
pcapriotti committed
208 209 210 211
  where
    go (NullAsm x) = return x
    go (AllocPtr p_io k) = do
      p <- lift p_io
212
      w <- state $ \(st_i0,st_l0,st_p0) ->
pcapriotti's avatar
pcapriotti committed
213
        let st_p1 = addToSS st_p0 p
214
        in (sizeSS st_p0, (st_i0,st_l0,st_p1))
pcapriotti's avatar
pcapriotti committed
215 216
      go $ k w
    go (AllocLit lits k) = do
217
      w <- state $ \(st_i0,st_l0,st_p0) ->
pcapriotti's avatar
pcapriotti committed
218
        let st_l1 = addListToSS st_l0 lits
219
        in (sizeSS st_l0, (st_i0,st_l1,st_p0))
pcapriotti's avatar
pcapriotti committed
220 221 222 223 224 225 226 227 228 229
      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))
230
          expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
231
--        expand (LargeOp w) = largeArg dflags w
232
      state $ \(st_i0,st_l0,st_p0) ->
pcapriotti's avatar
pcapriotti committed
233
        let st_i1 = addListToSS st_i0 (opcode : words)
234
        in ((), (st_i1,st_l0,st_p0))
pcapriotti's avatar
pcapriotti committed
235
      go k
pcapriotti's avatar
pcapriotti committed
236 237 238 239 240 241 242 243 244 245

type LabelEnvMap = Map Word16 Word

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

246 247
inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm dflags long_jumps initial_offset
pcapriotti's avatar
pcapriotti committed
248 249 250 251 252 253 254 255 256 257 258 259
  = 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
260 261 262 263
        size = sum (map count ops) + 1
        largeOps = any (largeOp long_jumps) ops
        count (SmallOp _) = 1
        count (LabelOp _) = count (Op 0)
264
        count (Op _) = if largeOps then largeArg16s dflags else 1
265
--      count (LargeOp _) = largeArg16s dflags
266

267
-- Bring in all the bci_ bytecode constants.
Simon Marlow's avatar
Simon Marlow committed
268
#include "rts/Bytecodes.h"
269

270
largeArgInstr :: Word16 -> Word16
271 272
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci

273 274 275
largeArg :: DynFlags -> Word -> [Word16]
largeArg dflags w
 | wORD_SIZE_IN_BITS dflags == 64
276 277 278 279
           = [fromIntegral (w `shiftR` 48),
              fromIntegral (w `shiftR` 32),
              fromIntegral (w `shiftR` 16),
              fromIntegral w]
280
 | wORD_SIZE_IN_BITS dflags == 32
281 282
           = [fromIntegral (w `shiftR` 16),
              fromIntegral w]
283 284
 | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"

285 286 287
largeArg16s :: DynFlags -> Word
largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
                   | otherwise                      = 2
288

pcapriotti's avatar
pcapriotti committed
289 290 291 292 293 294 295 296 297
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]
  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
298
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
299
  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
300
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
301 302
  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
303
                                 emit bci_PUSH_G [Op p]
pcapriotti's avatar
pcapriotti committed
304 305
  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
306
                                 emit bci_PUSH_ALTS [Op p]
pcapriotti's avatar
pcapriotti committed
307 308 309
  PUSH_ALTS_UNLIFTED proto pk
                           -> do let ul_bco = assembleBCO dflags proto
                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
310
                                 emit (push_alts pk) [Op p]
311
  PUSH_UBX lit nws         -> do np <- literal lit
312
                                 emit bci_PUSH_UBX [Op np, SmallOp nws]
pcapriotti's avatar
pcapriotti committed
313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333

  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)]
334
                                 emit bci_PACK [Op itbl_no, SmallOp sz]
pcapriotti's avatar
pcapriotti committed
335 336
  LABEL     lbl            -> label lbl
  TESTLT_I  i l            -> do np <- int i
337
                                 emit bci_TESTLT_I [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
338
  TESTEQ_I  i l            -> do np <- int i
339
                                 emit bci_TESTEQ_I [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
340
  TESTLT_W  w l            -> do np <- word w
341
                                 emit bci_TESTLT_W [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
342
  TESTEQ_W  w l            -> do np <- word w
343
                                 emit bci_TESTEQ_W [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
344
  TESTLT_F  f l            -> do np <- float f
345
                                 emit bci_TESTLT_F [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
346
  TESTEQ_F  f l            -> do np <- float f
347
                                 emit bci_TESTEQ_F [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
348
  TESTLT_D  d l            -> do np <- double d
349
                                 emit bci_TESTLT_D [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
350
  TESTEQ_D  d l            -> do np <- double d
351
                                 emit bci_TESTEQ_D [Op np, LabelOp l]
pcapriotti's avatar
pcapriotti committed
352 353 354 355 356 357 358 359 360
  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
361
                                 emit bci_CCALL [SmallOp off, Op np, SmallOp i]
pcapriotti's avatar
pcapriotti committed
362 363
  BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array)
                                 p2 <- ptr (BCOPtrBreakInfo info)
364
                                 emit bci_BRK_FUN [Op p1, SmallOp index, Op p2]
pcapriotti's avatar
pcapriotti committed
365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380

  where
    literal (MachLabel fs (Just sz) _)
     | 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)
    literal (MachLabel fs _ _) = litlabel fs
    literal (MachWord w)       = int (fromIntegral w)
    literal (MachInt j)        = int (fromIntegral j)
    literal MachNullAddr       = int 0
    literal (MachFloat r)      = float (fromRational r)
    literal (MachDouble r)     = double (fromRational r)
    literal (MachChar c)       = int (ord c)
    literal (MachInt64 ii)     = int64 (fromIntegral ii)
    literal (MachWord64 ii)    = int64 (fromIntegral ii)
381 382 383
    literal (MachStr bs)       = lit [BCONPtrStr (bs `B.snoc` 0)]
       -- MachStr requires a zero-terminator when emitted
    literal LitInteger{}       = panic "ByteCodeAsm.literal: LitInteger"
pcapriotti's avatar
pcapriotti committed
384 385 386 387

    litlabel fs = lit [BCONPtrLbl fs]
    addr = words . mkLitPtr
    float = words . mkLitF
388
    double = words . mkLitD dflags
pcapriotti's avatar
pcapriotti committed
389
    int = words . mkLitI
390
    int64 = words . mkLitI64 dflags
pcapriotti's avatar
pcapriotti committed
391 392
    words ws = lit (map BCONPtrWord ws)
    word w = words [w]
393

394 395
isLarge :: Word -> Bool
isLarge n = n > 65535
396

Simon Marlow's avatar
Simon Marlow committed
397
push_alts :: ArgRep -> Word16
398 399 400 401 402 403 404
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"
405
push_alts V32 = error "push_alts: vector"
406
push_alts V64 = error "push_alts: vector"
Simon Marlow's avatar
Simon Marlow committed
407 408

return_ubx :: ArgRep -> Word16
409 410 411 412 413 414 415
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"
416
return_ubx V32 = error "return_ubx: vector"
417
return_ubx V64 = error "return_ubx: vector"
418

419 420 421
-- 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.
422 423 424 425 426
mkLitI   ::             Int    -> [Word]
mkLitF   ::             Float  -> [Word]
mkLitD   :: DynFlags -> Double -> [Word]
mkLitPtr ::             Ptr () -> [Word]
mkLitI64 :: DynFlags -> Int64  -> [Word]
427 428 429 430 431 432 433 434 435 436

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

437 438
mkLitD dflags d
   | wORD_SIZE dflags == 4
439 440 441 442 443 444 445 446
   = 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]
     )
447
   | wORD_SIZE dflags == 8
448 449 450 451 452 453 454
   = 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
455 456
   | otherwise
   = panic "mkLitD: Bad wORD_SIZE"
457

458 459
mkLitI64 dflags ii
   | wORD_SIZE dflags == 4
460 461 462 463 464 465 466 467
   = 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]
     )
468
   | wORD_SIZE dflags == 8
469 470 471 472 473 474 475
   = 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
476 477
   | otherwise
   = panic "mkLitI64: Bad wORD_SIZE"
478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496

mkLitI i
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 i
        i_arr <- castSTUArray arr
        w0 <- readArray i_arr 0
        return [w0 :: Word]
     )

mkLitPtr a
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 a
        a_arr <- castSTUArray arr
        w0 <- readArray a_arr 0
        return [w0 :: Word]
     )

Ian Lynagh's avatar
Ian Lynagh committed
497 498
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH