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