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