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