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