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