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