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