compiler/ghci/ByteCodeAsm.lhs

   1 %
   2 % (c) The University of Glasgow 2002-2006
   3 %
   4
   5 ByteCodeLink: Bytecode assembler and linker
   6
   7 \begin{code}
   8 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
   9
  10 module ByteCodeAsm (
  11         assembleBCOs, assembleBCO,
  12
  13         CompiledByteCode(..),
  14         UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames,
  15         SizedSeq, sizeSS, ssElts,
  16         iNTERP_STACK_CHECK_THRESH
  17   ) where
  18
  19 #include "HsVersions.h"
  20
  21 import ByteCodeInstr
  22 import ByteCodeItbls
  23
  24 import Name
  25 import NameSet
  26 import FiniteMap
  27 import Literal
  28 import TyCon
  29 import PrimOp
  30 import Constants
  31 import FastString
  32 import SMRep
  33 import Outputable
  34
  35 import Control.Monad    ( foldM )
  36 import Control.Monad.ST ( runST )
  37
  38 import Data.Array.MArray
  39 import Data.Array.Unboxed ( listArray )
  40 import Data.Array.Base  ( UArray(..) )
  41 import Data.Array.ST    ( castSTUArray )
  42 import Foreign
  43 import Data.Char        ( ord )
  44
  45 import GHC.Base         ( ByteArray#, MutableByteArray#, RealWorld )
  46
  47 -- -----------------------------------------------------------------------------
  48 -- Unlinked BCOs
  49
  50 -- CompiledByteCode represents the result of byte-code
  51 -- compiling a bunch of functions and data types
  52
  53 data CompiledByteCode
  54   = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
  55              ItblEnv       -- A mapping from DataCons to their itbls
  56
  57 instance Outputable CompiledByteCode where
  58   ppr (ByteCode bcos _) = ppr bcos
  59
  60
  61 data UnlinkedBCO
  62    = UnlinkedBCO {
  63         unlinkedBCOName   :: Name,
  64         unlinkedBCOArity  :: Int,
  65         unlinkedBCOInstrs :: ByteArray#,                 -- insns
  66         unlinkedBCOBitmap :: ByteArray#,                 -- bitmap
  67         unlinkedBCOLits   :: (SizedSeq BCONPtr),        -- non-ptrs
  68         unlinkedBCOPtrs   :: (SizedSeq BCOPtr)          -- ptrs
  69    }
  70
  71 data BCOPtr
  72   = BCOPtrName   Name
  73   | BCOPtrPrimOp PrimOp
  74   | BCOPtrBCO    UnlinkedBCO
  75   | BCOPtrBreakInfo  BreakInfo
  76   | BCOPtrArray (MutableByteArray# RealWorld)
  77
  78 data BCONPtr
  79   = BCONPtrWord  Word
  80   | BCONPtrLbl   FastString
  81   | BCONPtrItbl  Name
  82
  83 -- | Finds external references.  Remember to remove the names
  84 -- defined by this group of BCOs themselves
  85 bcoFreeNames :: UnlinkedBCO -> NameSet
  86 bcoFreeNames bco
  87   = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
  88   where
  89     bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
  90         = unionManyNameSets (
  91              mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
  92              mkNameSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
  93              map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
  94           )
  95
  96 instance Outputable UnlinkedBCO where
  97    ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
  98       = sep [text "BCO", ppr nm, text "with",
  99              int (sizeSS lits), text "lits",
 100              int (sizeSS ptrs), text "ptrs" ]
 101
 102 -- -----------------------------------------------------------------------------
 103 -- The bytecode assembler
 104
 105 -- The object format for bytecodes is: 16 bits for the opcode, and 16
 106 -- for each field -- so the code can be considered a sequence of
 107 -- 16-bit ints.  Each field denotes either a stack offset or number of
 108 -- items on the stack (eg SLIDE), and index into the pointer table (eg
 109 -- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
 110 -- bytecode address in this BCO.
 111
 112 -- Top level assembler fn.
 113 assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
 114 assembleBCOs proto_bcos tycons
 115   = do  itblenv <- mkITbls tycons
 116         bcos    <- mapM assembleBCO proto_bcos
 117         return (ByteCode bcos itblenv)
 118
 119 assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
 120 assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
 121    = let
 122          -- pass 1: collect up the offsets of the local labels.
 123          -- Remember that the first insn starts at offset 1 since offset 0
 124          -- (eventually) will hold the total # of insns.
 125          label_env = mkLabelEnv emptyFM 1 instrs
 126
 127          mkLabelEnv env _ [] = env
 128          mkLabelEnv env i_offset (i:is)
 129             = let new_env
 130                      = case i of LABEL n -> addToFM env n i_offset ; _ -> env
 131               in  mkLabelEnv new_env (i_offset + instrSize16s i) is
 132
 133          findLabel lab
 134             = case lookupFM label_env lab of
 135                  Just bco_offset -> bco_offset
 136                  Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
 137      in
 138      do  -- pass 2: generate the instruction, ptr and nonptr bits
 139          insns <- return emptySS :: IO (SizedSeq Word16)
 140          lits  <- return emptySS :: IO (SizedSeq BCONPtr)
 141          ptrs  <- return emptySS :: IO (SizedSeq BCOPtr)
 142          let init_asm_state = (insns,lits,ptrs)
 143          (final_insns, final_lits, final_ptrs)
 144             <- mkBits findLabel init_asm_state instrs
 145
 146          let asm_insns = ssElts final_insns
 147              n_insns   = sizeSS final_insns
 148
 149              insns_arr
 150                  | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
 151                  | otherwise = mkInstrArray n_insns asm_insns
 152              !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
 153
 154              bitmap_arr = mkBitmapArray bsize bitmap
 155              !bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr
 156
 157          let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
 158
 159          -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
 160          -- objects, since they might get run too early.  Disable this until
 161          -- we figure out what to do.
 162          -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
 163
 164          return ul_bco
 165      -- where
 166      --     zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
 167      --                      free ptr
 168
 169 mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
 170 mkBitmapArray bsize bitmap
 171   = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
 172
 173 mkInstrArray :: Int -> [Word16] -> UArray Int Word16
 174 mkInstrArray n_insns asm_insns
 175   = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
 176
 177 -- instrs nonptrs ptrs
 178 type AsmState = (SizedSeq Word16,
 179                  SizedSeq BCONPtr,
 180                  SizedSeq BCOPtr)
 181
 182 data SizedSeq a = SizedSeq !Int [a]
 183 emptySS :: SizedSeq a
 184 emptySS = SizedSeq 0 []
 185
 186 -- Why are these two monadic???
 187 addToSS :: SizedSeq a -> a -> IO (SizedSeq a)
 188 addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
 189 addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a)
 190 addListToSS (SizedSeq n r_xs) xs
 191    = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
 192
 193 ssElts :: SizedSeq a -> [a]
 194 ssElts (SizedSeq _ r_xs) = reverse r_xs
 195
 196 sizeSS :: SizedSeq a -> Int
 197 sizeSS (SizedSeq n _) = n
 198
 199 -- Bring in all the bci_ bytecode constants.
 200 #include "Bytecodes.h"
 201
 202 largeArgInstr :: Int -> Int
 203 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
 204
 205 largeArg :: Int -> [Int]
 206 largeArg i
 207  | wORD_SIZE_IN_BITS == 64
 208            = [(i .&. 0xFFFF000000000000) `shiftR` 48,
 209               (i .&. 0x0000FFFF00000000) `shiftR` 32,
 210               (i .&. 0x00000000FFFF0000) `shiftR` 16,
 211               (i .&. 0x000000000000FFFF)]
 212  | wORD_SIZE_IN_BITS == 32
 213            = [(i .&. 0xFFFF0000) `shiftR` 16,
 214               (i .&. 0x0000FFFF)]
 215  | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
 216
 217 -- This is where all the action is (pass 2 of the assembler)
 218 mkBits :: (Int -> Int)                  -- label finder
 219        -> AsmState
 220        -> [BCInstr]                     -- instructions (in)
 221        -> IO AsmState
 222
 223 mkBits findLabel st proto_insns
 224   = foldM doInstr st proto_insns
 225     where
 226        doInstr :: AsmState -> BCInstr -> IO AsmState
 227        doInstr st i
 228           = case i of
 229                STKCHECK  n
 230                 | n > 65535 ->
 231                        instrn st (largeArgInstr bci_STKCHECK : largeArg n)
 232                 | otherwise -> instr2 st bci_STKCHECK n
 233                PUSH_L    o1       -> instr2 st bci_PUSH_L o1
 234                PUSH_LL   o1 o2    -> instr3 st bci_PUSH_LL o1 o2
 235                PUSH_LLL  o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
 236                PUSH_G    nm       -> do (p, st2) <- ptr st (BCOPtrName nm)
 237                                         instr2 st2 bci_PUSH_G p
 238                PUSH_PRIMOP op     -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
 239                                         instr2 st2 bci_PUSH_G p
 240                PUSH_BCO proto     -> do ul_bco <- assembleBCO proto
 241                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
 242                                         instr2 st2 bci_PUSH_G p
 243                PUSH_ALTS proto    -> do ul_bco <- assembleBCO proto
 244                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
 245                                         instr2 st2 bci_PUSH_ALTS p
 246                PUSH_ALTS_UNLIFTED proto pk -> do
 247                                         ul_bco <- assembleBCO proto
 248                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
 249                                         instr2 st2 (push_alts pk) p
 250                PUSH_UBX  (Left lit) nws
 251                                   -> do (np, st2) <- literal st lit
 252                                         instr3 st2 bci_PUSH_UBX np nws
 253                PUSH_UBX  (Right aa) nws
 254                                   -> do (np, st2) <- addr st aa
 255                                         instr3 st2 bci_PUSH_UBX np nws
 256
 257                PUSH_APPLY_N         -> do instr1 st bci_PUSH_APPLY_N
 258                PUSH_APPLY_V         -> do instr1 st bci_PUSH_APPLY_V
 259                PUSH_APPLY_F         -> do instr1 st bci_PUSH_APPLY_F
 260                PUSH_APPLY_D         -> do instr1 st bci_PUSH_APPLY_D
 261                PUSH_APPLY_L         -> do instr1 st bci_PUSH_APPLY_L
 262                PUSH_APPLY_P         -> do instr1 st bci_PUSH_APPLY_P
 263                PUSH_APPLY_PP        -> do instr1 st bci_PUSH_APPLY_PP
 264                PUSH_APPLY_PPP       -> do instr1 st bci_PUSH_APPLY_PPP
 265                PUSH_APPLY_PPPP      -> do instr1 st bci_PUSH_APPLY_PPPP
 266                PUSH_APPLY_PPPPP     -> do instr1 st bci_PUSH_APPLY_PPPPP
 267                PUSH_APPLY_PPPPPP    -> do instr1 st bci_PUSH_APPLY_PPPPPP
 268
 269                SLIDE     n by     -> instr3 st bci_SLIDE n by
 270                ALLOC_AP  n        -> instr2 st bci_ALLOC_AP n
 271                ALLOC_AP_NOUPD n   -> instr2 st bci_ALLOC_AP_NOUPD n
 272                ALLOC_PAP arity n  -> instr3 st bci_ALLOC_PAP arity n
 273                MKAP      off sz   -> instr3 st bci_MKAP off sz
 274                MKPAP     off sz   -> instr3 st bci_MKPAP off sz
 275                UNPACK    n        -> instr2 st bci_UNPACK n
 276                PACK      dcon sz  -> do (itbl_no,st2) <- itbl st dcon
 277                                         instr3 st2 bci_PACK itbl_no sz
 278                LABEL     _        -> return st
 279                TESTLT_I  i l      -> do (np, st2) <- int st i
 280                                         instr3 st2 bci_TESTLT_I np (findLabel l)
 281                TESTEQ_I  i l      -> do (np, st2) <- int st i
 282                                         instr3 st2 bci_TESTEQ_I np (findLabel l)
 283                TESTLT_F  f l      -> do (np, st2) <- float st f
 284                                         instr3 st2 bci_TESTLT_F np (findLabel l)
 285                TESTEQ_F  f l      -> do (np, st2) <- float st f
 286                                         instr3 st2 bci_TESTEQ_F np (findLabel l)
 287                TESTLT_D  d l      -> do (np, st2) <- double st d
 288                                         instr3 st2 bci_TESTLT_D np (findLabel l)
 289                TESTEQ_D  d l      -> do (np, st2) <- double st d
 290                                         instr3 st2 bci_TESTEQ_D np (findLabel l)
 291                TESTLT_P  i l      -> instr3 st bci_TESTLT_P i (findLabel l)
 292                TESTEQ_P  i l      -> instr3 st bci_TESTEQ_P i (findLabel l)
 293                CASEFAIL           -> instr1 st bci_CASEFAIL
 294                SWIZZLE   stkoff n -> instr3 st bci_SWIZZLE stkoff n
 295                JMP       l        -> instr2 st bci_JMP (findLabel l)
 296                ENTER              -> instr1 st bci_ENTER
 297                RETURN             -> instr1 st bci_RETURN
 298                RETURN_UBX rep     -> instr1 st (return_ubx rep)
 299                CCALL off m_addr   -> do (np, st2) <- addr st m_addr
 300                                         instr3 st2 bci_CCALL off np
 301                BRK_FUN array index info -> do
 302                   (p1, st2) <- ptr st  (BCOPtrArray array)
 303                   (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
 304                   instr4 st3 bci_BRK_FUN p1 index p2
 305
 306        i2s :: Int -> Word16
 307        i2s = fromIntegral
 308
 309        instrn :: AsmState -> [Int] -> IO AsmState
 310        instrn st [] = return st
 311        instrn (st_i, st_l, st_p) (i:is)
 312           = do st_i' <- addToSS st_i (i2s i)
 313                instrn (st_i', st_l, st_p) is
 314
 315        instr1 (st_i0,st_l0,st_p0) i1
 316           = do st_i1 <- addToSS st_i0 i1
 317                return (st_i1,st_l0,st_p0)
 318
 319        instr2 (st_i0,st_l0,st_p0) i1 i2
 320           = do st_i1 <- addToSS st_i0 (i2s i1)
 321                st_i2 <- addToSS st_i1 (i2s i2)
 322                return (st_i2,st_l0,st_p0)
 323
 324        instr3 (st_i0,st_l0,st_p0) i1 i2 i3
 325           = do st_i1 <- addToSS st_i0 (i2s i1)
 326                st_i2 <- addToSS st_i1 (i2s i2)
 327                st_i3 <- addToSS st_i2 (i2s i3)
 328                return (st_i3,st_l0,st_p0)
 329
 330        instr4 (st_i0,st_l0,st_p0) i1 i2 i3 i4
 331           = do st_i1 <- addToSS st_i0 (i2s i1)
 332                st_i2 <- addToSS st_i1 (i2s i2)
 333                st_i3 <- addToSS st_i2 (i2s i3)
 334                st_i4 <- addToSS st_i3 (i2s i4)
 335                return (st_i4,st_l0,st_p0)
 336
 337        float (st_i0,st_l0,st_p0) f
 338           = do let ws = mkLitF f
 339                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
 340                return (sizeSS st_l0, (st_i0,st_l1,st_p0))
 341
 342        double (st_i0,st_l0,st_p0) d
 343           = do let ws = mkLitD d
 344                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
 345                return (sizeSS st_l0, (st_i0,st_l1,st_p0))
 346
 347        int (st_i0,st_l0,st_p0) i
 348           = do let ws = mkLitI i
 349                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
 350                return (sizeSS st_l0, (st_i0,st_l1,st_p0))
 351
 352        int64 (st_i0,st_l0,st_p0) i
 353           = do let ws = mkLitI64 i
 354                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
 355                return (sizeSS st_l0, (st_i0,st_l1,st_p0))
 356
 357        addr (st_i0,st_l0,st_p0) a
 358           = do let ws = mkLitPtr a
 359                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
 360                return (sizeSS st_l0, (st_i0,st_l1,st_p0))
 361
 362        litlabel (st_i0,st_l0,st_p0) fs
 363           = do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs]
 364                return (sizeSS st_l0, (st_i0,st_l1,st_p0))
 365
 366        ptr (st_i0,st_l0,st_p0) p
 367           = do st_p1 <- addToSS st_p0 p
 368                return (sizeSS st_p0, (st_i0,st_l0,st_p1))
 369
 370        itbl (st_i0,st_l0,st_p0) dcon
 371           = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
 372                return (sizeSS st_l0, (st_i0,st_l1,st_p0))
 373
 374 #ifdef mingw32_TARGET_OS
 375        literal st (MachLabel fs (Just sz) _)
 376             = litlabel st (appendFS fs (mkFastString ('@':show sz)))
 377         -- On Windows, stdcall labels have a suffix indicating the no. of
 378         -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
 379 #endif
 380        literal st (MachLabel fs _ _) = litlabel st fs
 381        literal st (MachWord w)     = int st (fromIntegral w)
 382        literal st (MachInt j)      = int st (fromIntegral j)
 383        literal st MachNullAddr     = int st 0
 384        literal st (MachFloat r)    = float st (fromRational r)
 385        literal st (MachDouble r)   = double st (fromRational r)
 386        literal st (MachChar c)     = int st (ord c)
 387        literal st (MachInt64 ii)   = int64 st (fromIntegral ii)
 388        literal st (MachWord64 ii)  = int64 st (fromIntegral ii)
 389        literal _  other            = pprPanic "ByteCodeAsm.literal" (ppr other)
 390
 391
 392 push_alts :: CgRep -> Int
 393 push_alts NonPtrArg = bci_PUSH_ALTS_N
 394 push_alts FloatArg  = bci_PUSH_ALTS_F
 395 push_alts DoubleArg = bci_PUSH_ALTS_D
 396 push_alts VoidArg   = bci_PUSH_ALTS_V
 397 push_alts LongArg   = bci_PUSH_ALTS_L
 398 push_alts PtrArg    = bci_PUSH_ALTS_P
 399
 400 return_ubx :: CgRep -> Word16
 401 return_ubx NonPtrArg = bci_RETURN_N
 402 return_ubx FloatArg  = bci_RETURN_F
 403 return_ubx DoubleArg = bci_RETURN_D
 404 return_ubx VoidArg   = bci_RETURN_V
 405 return_ubx LongArg   = bci_RETURN_L
 406 return_ubx PtrArg    = bci_RETURN_P
 407
 408
 409 -- The size in 16-bit entities of an instruction.
 410 instrSize16s :: BCInstr -> Int
 411 instrSize16s instr
 412    = case instr of
 413         STKCHECK{}              -> 2
 414         PUSH_L{}                -> 2
 415         PUSH_LL{}               -> 3
 416         PUSH_LLL{}              -> 4
 417         PUSH_G{}                -> 2
 418         PUSH_PRIMOP{}           -> 2
 419         PUSH_BCO{}              -> 2
 420         PUSH_ALTS{}             -> 2
 421         PUSH_ALTS_UNLIFTED{}    -> 2
 422         PUSH_UBX{}              -> 3
 423         PUSH_APPLY_N{}          -> 1
 424         PUSH_APPLY_V{}          -> 1
 425         PUSH_APPLY_F{}          -> 1
 426         PUSH_APPLY_D{}          -> 1
 427         PUSH_APPLY_L{}          -> 1
 428         PUSH_APPLY_P{}          -> 1
 429         PUSH_APPLY_PP{}         -> 1
 430         PUSH_APPLY_PPP{}        -> 1
 431         PUSH_APPLY_PPPP{}       -> 1
 432         PUSH_APPLY_PPPPP{}      -> 1
 433         PUSH_APPLY_PPPPPP{}     -> 1
 434         SLIDE{}                 -> 3
 435         ALLOC_AP{}              -> 2
 436         ALLOC_AP_NOUPD{}        -> 2
 437         ALLOC_PAP{}             -> 3
 438         MKAP{}                  -> 3
 439         MKPAP{}                 -> 3
 440         UNPACK{}                -> 2
 441         PACK{}                  -> 3
 442         LABEL{}                 -> 0    -- !!
 443         TESTLT_I{}              -> 3
 444         TESTEQ_I{}              -> 3
 445         TESTLT_F{}              -> 3
 446         TESTEQ_F{}              -> 3
 447         TESTLT_D{}              -> 3
 448         TESTEQ_D{}              -> 3
 449         TESTLT_P{}              -> 3
 450         TESTEQ_P{}              -> 3
 451         JMP{}                   -> 2
 452         CASEFAIL{}              -> 1
 453         ENTER{}                 -> 1
 454         RETURN{}                -> 1
 455         RETURN_UBX{}            -> 1
 456         CCALL{}                 -> 3
 457         SWIZZLE{}               -> 3
 458         BRK_FUN{}               -> 4
 459
 460 -- Make lists of host-sized words for literals, so that when the
 461 -- words are placed in memory at increasing addresses, the
 462 -- bit pattern is correct for the host's word size and endianness.
 463 mkLitI   :: Int    -> [Word]
 464 mkLitF   :: Float  -> [Word]
 465 mkLitD   :: Double -> [Word]
 466 mkLitPtr :: Ptr () -> [Word]
 467 mkLitI64 :: Int64  -> [Word]
 468
 469 mkLitF f
 470    = runST (do
 471         arr <- newArray_ ((0::Int),0)
 472         writeArray arr 0 f
 473         f_arr <- castSTUArray arr
 474         w0 <- readArray f_arr 0
 475         return [w0 :: Word]
 476      )
 477
 478 mkLitD d
 479    | wORD_SIZE == 4
 480    = runST (do
 481         arr <- newArray_ ((0::Int),1)
 482         writeArray arr 0 d
 483         d_arr <- castSTUArray arr
 484         w0 <- readArray d_arr 0
 485         w1 <- readArray d_arr 1
 486         return [w0 :: Word, w1]
 487      )
 488    | wORD_SIZE == 8
 489    = runST (do
 490         arr <- newArray_ ((0::Int),0)
 491         writeArray arr 0 d
 492         d_arr <- castSTUArray arr
 493         w0 <- readArray d_arr 0
 494         return [w0 :: Word]
 495      )
 496    | otherwise
 497    = panic "mkLitD: Bad wORD_SIZE"
 498
 499 mkLitI64 ii
 500    | wORD_SIZE == 4
 501    = runST (do
 502         arr <- newArray_ ((0::Int),1)
 503         writeArray arr 0 ii
 504         d_arr <- castSTUArray arr
 505         w0 <- readArray d_arr 0
 506         w1 <- readArray d_arr 1
 507         return [w0 :: Word,w1]
 508      )
 509    | wORD_SIZE == 8
 510    = runST (do
 511         arr <- newArray_ ((0::Int),0)
 512         writeArray arr 0 ii
 513         d_arr <- castSTUArray arr
 514         w0 <- readArray d_arr 0
 515         return [w0 :: Word]
 516      )
 517    | otherwise
 518    = panic "mkLitI64: Bad wORD_SIZE"
 519
 520 mkLitI i
 521    = runST (do
 522         arr <- newArray_ ((0::Int),0)
 523         writeArray arr 0 i
 524         i_arr <- castSTUArray arr
 525         w0 <- readArray i_arr 0
 526         return [w0 :: Word]
 527      )
 528
 529 mkLitPtr a
 530    = runST (do
 531         arr <- newArray_ ((0::Int),0)
 532         writeArray arr 0 a
 533         a_arr <- castSTUArray arr
 534         w0 <- readArray a_arr 0
 535         return [w0 :: Word]
 536      )
 537
 538 iNTERP_STACK_CHECK_THRESH :: Int
 539 iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
 540 \end{code}