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