ByteCodeAsm.lhs 18.7 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2002-2006
3
%
4
5

ByteCodeLink: Bytecode assembler and linker
6
7
8
9
10
11
12
13

\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}

module ByteCodeAsm (  
	assembleBCOs, assembleBCO,

	CompiledByteCode(..), 
14
	UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames,
15
16
17
18
19
20
	SizedSeq, sizeSS, ssElts,
	iNTERP_STACK_CHECK_THRESH
  ) where

#include "HsVersions.h"

21
import ByteCodeInstr
22
import ByteCodeItbls
23

24
import Name
25
import NameSet
26
27
28
29
30
31
32
import FiniteMap
import Literal
import TyCon
import PrimOp
import Constants
import FastString
import SMRep
33
34
35
import FiniteMap
import Outputable

36
37
import Control.Monad	( foldM )
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 )
Ian Lynagh's avatar
Ian Lynagh committed
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
50
51
import GHC.IOBase	( IO(..) )
import GHC.Ptr		( Ptr(..) )

52
53
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
54
55
56
57
58
59
60
61
62
63
64
65
66

-- CompiledByteCode represents the result of byte-code 
-- compiling a bunch of functions and data types

data CompiledByteCode 
  = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
	     ItblEnv       -- A mapping from DataCons to their itbls

instance Outputable CompiledByteCode where
  ppr (ByteCode bcos _) = ppr bcos


data UnlinkedBCO
67
68
69
   = UnlinkedBCO {
	unlinkedBCOName   :: Name,
	unlinkedBCOArity  :: Int,
70
71
72
	unlinkedBCOInstrs :: ByteArray#,		 -- insns
	unlinkedBCOBitmap :: ByteArray#,		 -- bitmap
        unlinkedBCOLits   :: (SizedSeq BCONPtr),        -- non-ptrs
73
        unlinkedBCOPtrs   :: (SizedSeq BCOPtr)   	-- ptrs
74
   }
75

76
77
78
79
data BCOPtr
  = BCOPtrName   Name
  | BCOPtrPrimOp PrimOp
  | BCOPtrBCO    UnlinkedBCO
80
81
  | BCOPtrBreakInfo  BreakInfo
  | BCOPtrArray (MutableByteArray# RealWorld)
82

83
84
85
86
87
data BCONPtr
  = BCONPtrWord  Word
  | BCONPtrLbl   FastString
  | BCONPtrItbl  Name

88
-- | Finds external references.  Remember to remove the names
89
-- defined by this group of BCOs themselves
90
91
92
bcoFreeNames :: UnlinkedBCO -> NameSet
bcoFreeNames bco
  = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
93
  where
94
    bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
95
96
	= unionManyNameSets (
	     mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
97
	     mkNameSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
98
99
	     map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
	  )
100
101

instance Outputable UnlinkedBCO where
Ian Lynagh's avatar
Ian Lynagh committed
102
   ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
103
104
      = sep [text "BCO", ppr nm, text "with", 
             int (sizeSS lits), text "lits",
105
             int (sizeSS ptrs), text "ptrs" ]
106

107
108
-- -----------------------------------------------------------------------------
-- The bytecode assembler
109

110
111
112
113
114
115
-- The object format for bytecodes is: 16 bits for the opcode, and 16
-- for each field -- so the code can be considered a sequence of
-- 16-bit ints.  Each field denotes either a stack offset or number of
-- items on the stack (eg SLIDE), and index into the pointer table (eg
-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
-- bytecode address in this BCO.
116
117
118
119
120
121
122
123
124

-- Top level assembler fn.
assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs proto_bcos tycons
  = do	itblenv <- mkITbls tycons
	bcos    <- mapM assembleBCO proto_bcos
        return (ByteCode bcos itblenv)

assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
Ian Lynagh's avatar
Ian Lynagh committed
125
assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
126
127
128
129
130
131
   = let
         -- pass 1: collect up the offsets of the local labels.
         -- Remember that the first insn starts at offset 1 since offset 0
         -- (eventually) will hold the total # of insns.
         label_env = mkLabelEnv emptyFM 1 instrs

Ian Lynagh's avatar
Ian Lynagh committed
132
         mkLabelEnv env _ [] = env
133
134
135
136
137
138
139
140
141
142
143
144
         mkLabelEnv env i_offset (i:is)
            = let new_env 
                     = case i of LABEL n -> addToFM env n i_offset ; _ -> env
              in  mkLabelEnv new_env (i_offset + instrSize16s i) is

         findLabel lab
            = case lookupFM label_env lab of
                 Just bco_offset -> bco_offset
                 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
     in
     do  -- pass 2: generate the instruction, ptr and nonptr bits
         insns <- return emptySS :: IO (SizedSeq Word16)
145
         lits  <- return emptySS :: IO (SizedSeq BCONPtr)
146
         ptrs  <- return emptySS :: IO (SizedSeq BCOPtr)
147
148
         let init_asm_state = (insns,lits,ptrs)
         (final_insns, final_lits, final_ptrs) 
149
150
            <- mkBits findLabel init_asm_state instrs

151
152
153
154
155
	 let asm_insns = ssElts final_insns
	     n_insns   = sizeSS final_insns

             insns_arr
		 | 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
165
166
167
168
169

         -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
         -- objects, since they might get run too early.  Disable this until
         -- we figure out what to do.
         -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))

         return ul_bco
Michael D. Adams's avatar
Michael D. Adams committed
170
171
172
     -- where
     --     zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
     --                      free ptr
173

174
175
mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
mkBitmapArray bsize bitmap
176
  = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
177

178
179
mkInstrArray :: Int -> [Word16]	-> UArray Int Word16
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
185
                 SizedSeq BCONPtr,
                 SizedSeq BCOPtr)
186
187

data SizedSeq a = SizedSeq !Int [a]
Ian Lynagh's avatar
Ian Lynagh committed
188
emptySS :: SizedSeq a
189
190
191
emptySS = SizedSeq 0 []

-- Why are these two monadic???
Ian Lynagh's avatar
Ian Lynagh committed
192
addToSS :: SizedSeq a -> a -> IO (SizedSeq a)
193
addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
Ian Lynagh's avatar
Ian Lynagh committed
194
addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a)
195
196
197
198
addListToSS (SizedSeq n r_xs) xs 
   = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))

ssElts :: SizedSeq a -> [a]
Ian Lynagh's avatar
Ian Lynagh committed
199
ssElts (SizedSeq _ r_xs) = reverse r_xs
200
201

sizeSS :: SizedSeq a -> Int
Ian Lynagh's avatar
Ian Lynagh committed
202
sizeSS (SizedSeq n _) = n
203

204
205
206
-- Bring in all the bci_ bytecode constants.
#include "Bytecodes.h"

207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
largeArgInstr :: Int -> Int
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci

largeArg :: Int -> [Int]
largeArg i
 | wORD_SIZE_IN_BITS == 64
           = [(i .&. 0xFFFF000000000000) `shiftR` 48,
              (i .&. 0x0000FFFF00000000) `shiftR` 32,
              (i .&. 0x00000000FFFF0000) `shiftR` 16,
              (i .&. 0x000000000000FFFF)]
 | wORD_SIZE_IN_BITS == 32
           = [(i .&. 0xFFFF0000) `shiftR` 16,
              (i .&. 0x0000FFFF)]
 | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"

222
223
224
225
226
227
228
229
230
231
232
233
-- This is where all the action is (pass 2 of the assembler)
mkBits :: (Int -> Int) 			-- label finder
       -> AsmState
       -> [BCInstr]			-- instructions (in)
       -> IO AsmState

mkBits findLabel st proto_insns
  = foldM doInstr st proto_insns
    where
       doInstr :: AsmState -> BCInstr -> IO AsmState
       doInstr st i
          = case i of
234
235
236
237
               STKCHECK  n
                | n > 65535 ->
                       instrn st (largeArgInstr bci_STKCHECK : largeArg n)
                | otherwise -> instr2 st bci_STKCHECK n
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
               PUSH_L    o1       -> instr2 st bci_PUSH_L o1
               PUSH_LL   o1 o2    -> instr3 st bci_PUSH_LL o1 o2
               PUSH_LLL  o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
               PUSH_G    nm       -> do (p, st2) <- ptr st (BCOPtrName nm)
                                        instr2 st2 bci_PUSH_G p
               PUSH_PRIMOP op     -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
                                        instr2 st2 bci_PUSH_G p
               PUSH_BCO proto     -> do ul_bco <- assembleBCO proto
 					(p, st2) <- ptr st (BCOPtrBCO ul_bco)
                                        instr2 st2 bci_PUSH_G p
               PUSH_ALTS proto    -> do ul_bco <- assembleBCO proto
 					(p, st2) <- ptr st (BCOPtrBCO ul_bco)
                                        instr2 st2 bci_PUSH_ALTS p
               PUSH_ALTS_UNLIFTED proto pk -> do 
					ul_bco <- assembleBCO proto
 					(p, st2) <- ptr st (BCOPtrBCO ul_bco)
                                        instr2 st2 (push_alts pk) p
255
256
               PUSH_UBX  (Left lit) nws  
                                  -> do (np, st2) <- literal st lit
257
                                        instr3 st2 bci_PUSH_UBX np nws
258
259
               PUSH_UBX  (Right aa) nws  
                                  -> do (np, st2) <- addr st aa
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
                                        instr3 st2 bci_PUSH_UBX np nws

	       PUSH_APPLY_N	    -> do instr1 st bci_PUSH_APPLY_N
	       PUSH_APPLY_V	    -> do instr1 st bci_PUSH_APPLY_V
	       PUSH_APPLY_F	    -> do instr1 st bci_PUSH_APPLY_F
	       PUSH_APPLY_D	    -> do instr1 st bci_PUSH_APPLY_D
	       PUSH_APPLY_L	    -> do instr1 st bci_PUSH_APPLY_L
	       PUSH_APPLY_P	    -> do instr1 st bci_PUSH_APPLY_P
	       PUSH_APPLY_PP	    -> do instr1 st bci_PUSH_APPLY_PP
	       PUSH_APPLY_PPP	    -> do instr1 st bci_PUSH_APPLY_PPP
	       PUSH_APPLY_PPPP	    -> do instr1 st bci_PUSH_APPLY_PPPP
	       PUSH_APPLY_PPPPP	    -> do instr1 st bci_PUSH_APPLY_PPPPP
	       PUSH_APPLY_PPPPPP    -> do instr1 st bci_PUSH_APPLY_PPPPPP

               SLIDE     n by     -> instr3 st bci_SLIDE n by
               ALLOC_AP  n        -> instr2 st bci_ALLOC_AP n
276
               ALLOC_AP_NOUPD n   -> instr2 st bci_ALLOC_AP_NOUPD n
277
278
               ALLOC_PAP arity n  -> instr3 st bci_ALLOC_PAP arity n
               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
Ian Lynagh's avatar
Ian Lynagh committed
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
296
297
298
299
300
301
302
303
304
305
                                        instr3 st2 bci_TESTEQ_D np (findLabel l)
               TESTLT_P  i l      -> instr3 st bci_TESTLT_P i (findLabel l)
               TESTEQ_P  i l      -> instr3 st bci_TESTEQ_P i (findLabel l)
               CASEFAIL           -> instr1 st bci_CASEFAIL
               SWIZZLE   stkoff n -> instr3 st bci_SWIZZLE stkoff n
               JMP       l        -> instr2 st bci_JMP (findLabel l)
               ENTER              -> instr1 st bci_ENTER
               RETURN             -> instr1 st bci_RETURN
               RETURN_UBX rep     -> instr1 st (return_ubx rep)
               CCALL off m_addr   -> do (np, st2) <- addr st m_addr
                                        instr3 st2 bci_CCALL off np
306
307
308
309
               BRK_FUN array index info -> do 
                  (p1, st2) <- ptr st  (BCOPtrArray array) 
                  (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
                  instr4 st3 bci_BRK_FUN p1 index p2
310
311
312
313

       i2s :: Int -> Word16
       i2s = fromIntegral

314
315
       instrn :: AsmState -> [Int] -> IO AsmState
       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
326
          = do st_i1 <- addToSS st_i0 (i2s i1)
               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
331
332
          = do st_i1 <- addToSS st_i0 (i2s i1)
               st_i2 <- addToSS st_i1 (i2s i2)
               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
337
338
339
          = do st_i1 <- addToSS st_i0 (i2s i1)
               st_i2 <- addToSS st_i1 (i2s i2)
               st_i3 <- addToSS st_i2 (i2s i3)
               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
345
               st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
               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
350
               st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
               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
355
               st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
               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
360
               st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
               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
365
               st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
               return (sizeSS st_l0, (st_i0,st_l1,st_p0))
366

367
368
369
       litlabel (st_i0,st_l0,st_p0) fs
          = do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs]
               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
376
377
       itbl (st_i0,st_l0,st_p0) dcon
          = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
               return (sizeSS st_l0, (st_i0,st_l1,st_p0))
378

379
#ifdef mingw32_TARGET_OS
380
       literal st (MachLabel fs (Just sz) _)
381
382
383
384
            = litlabel st (appendFS fs (mkFastString ('@':show sz)))
        -- On Windows, stdcall labels have a suffix indicating the no. of 
        -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
#endif
385
       literal st (MachLabel fs _ _) = litlabel st fs
sof's avatar
sof committed
386
387
       literal st (MachWord w)     = int st (fromIntegral w)
       literal st (MachInt j)      = int st (fromIntegral j)
388
       literal st MachNullAddr     = int st 0
sof's avatar
sof committed
389
390
       literal st (MachFloat r)    = float st (fromRational r)
       literal st (MachDouble r)   = double st (fromRational r)
391
       literal st (MachChar c)     = int st (ord c)
sof's avatar
sof committed
392
393
       literal st (MachInt64 ii)   = int64 st (fromIntegral ii)
       literal st (MachWord64 ii)  = int64 st (fromIntegral ii)
Ian Lynagh's avatar
Ian Lynagh committed
394
       literal _  other            = pprPanic "ByteCodeAsm.literal" (ppr other)
395

396

Ian Lynagh's avatar
Ian Lynagh committed
397
push_alts :: CgRep -> Int
398
399
400
401
402
403
404
push_alts NonPtrArg = bci_PUSH_ALTS_N
push_alts FloatArg  = bci_PUSH_ALTS_F
push_alts DoubleArg = bci_PUSH_ALTS_D
push_alts VoidArg   = bci_PUSH_ALTS_V
push_alts LongArg   = bci_PUSH_ALTS_L
push_alts PtrArg    = bci_PUSH_ALTS_P

Ian Lynagh's avatar
Ian Lynagh committed
405
return_ubx :: CgRep -> Word16
406
407
408
409
410
411
return_ubx NonPtrArg = bci_RETURN_N
return_ubx FloatArg  = bci_RETURN_F
return_ubx DoubleArg = bci_RETURN_D
return_ubx VoidArg   = bci_RETURN_V
return_ubx LongArg   = bci_RETURN_L
return_ubx PtrArg    = bci_RETURN_P
412

413
414
415
416
417

-- The size in 16-bit entities of an instruction.
instrSize16s :: BCInstr -> Int
instrSize16s instr
   = case instr of
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
        STKCHECK{}		-> 2
        PUSH_L{}		-> 2
        PUSH_LL{}		-> 3
        PUSH_LLL{}		-> 4
        PUSH_G{}		-> 2
        PUSH_PRIMOP{}		-> 2
        PUSH_BCO{}		-> 2
        PUSH_ALTS{}		-> 2
        PUSH_ALTS_UNLIFTED{}	-> 2
	PUSH_UBX{}		-> 3
	PUSH_APPLY_N{}		-> 1
	PUSH_APPLY_V{}		-> 1
	PUSH_APPLY_F{}		-> 1
	PUSH_APPLY_D{}		-> 1
	PUSH_APPLY_L{}		-> 1
	PUSH_APPLY_P{}		-> 1
	PUSH_APPLY_PP{}		-> 1
	PUSH_APPLY_PPP{}	-> 1
	PUSH_APPLY_PPPP{}	-> 1
	PUSH_APPLY_PPPPP{}	-> 1
	PUSH_APPLY_PPPPPP{}	-> 1
        SLIDE{}			-> 3
        ALLOC_AP{}		-> 2
441
        ALLOC_AP_NOUPD{}	-> 2
442
443
        ALLOC_PAP{}		-> 3
        MKAP{}			-> 3
444
        MKPAP{}			-> 3
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
        UNPACK{}		-> 2
        PACK{}			-> 3
        LABEL{}			-> 0	-- !!
        TESTLT_I{}		-> 3
        TESTEQ_I{}		-> 3
        TESTLT_F{}		-> 3
        TESTEQ_F{}		-> 3
        TESTLT_D{}		-> 3
        TESTEQ_D{}		-> 3
        TESTLT_P{}		-> 3
        TESTEQ_P{}		-> 3
        JMP{}			-> 2
        CASEFAIL{}		-> 1
        ENTER{}			-> 1
        RETURN{}		-> 1
        RETURN_UBX{}		-> 1
	CCALL{}			-> 3
        SWIZZLE{}		-> 3
463
        BRK_FUN{}               -> 4 
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
-- bit pattern is correct for the host's word size and endianness.
mkLitI   :: Int    -> [Word]
mkLitF   :: Float  -> [Word]
mkLitD   :: Double -> [Word]
mkLitPtr :: Ptr () -> [Word]
mkLitI64 :: Int64  -> [Word]

mkLitF f
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 f
        f_arr <- castSTUArray arr
        w0 <- readArray f_arr 0
        return [w0 :: Word]
     )

mkLitD d
   | wORD_SIZE == 4
   = runST (do
        arr <- newArray_ ((0::Int),1)
        writeArray arr 0 d
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        w1 <- readArray d_arr 1
        return [w0 :: Word, w1]
     )
   | wORD_SIZE == 8
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 d
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        return [w0 :: Word]
     )
Ian Lynagh's avatar
Ian Lynagh committed
501
502
   | otherwise
   = panic "mkLitD: Bad wORD_SIZE"
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521

mkLitI64 ii
   | wORD_SIZE == 4
   = runST (do
        arr <- newArray_ ((0::Int),1)
        writeArray arr 0 ii
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        w1 <- readArray d_arr 1
        return [w0 :: Word,w1]
     )
   | wORD_SIZE == 8
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 ii
        d_arr <- castSTUArray arr
        w0 <- readArray d_arr 0
        return [w0 :: Word]
     )
Ian Lynagh's avatar
Ian Lynagh committed
522
523
   | otherwise
   = panic "mkLitI64: Bad wORD_SIZE"
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542

mkLitI i
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 i
        i_arr <- castSTUArray arr
        w0 <- readArray i_arr 0
        return [w0 :: Word]
     )

mkLitPtr a
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 a
        a_arr <- castSTUArray arr
        w0 <- readArray a_arr 0
        return [w0 :: Word]
     )

Ian Lynagh's avatar
Ian Lynagh committed
543
544
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
545
\end{code}