never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE RecordWildCards #-}
4 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
5 --
6 -- (c) The University of Glasgow 2002-2006
7 --
8
9 -- | Bytecode assembler and linker
10 module GHC.ByteCode.Asm (
11 assembleBCOs, assembleOneBCO,
12 bcoFreeNames,
13 SizedSeq, sizeSS, ssElts,
14 iNTERP_STACK_CHECK_THRESH,
15 mkTupleInfoLit
16 ) where
17
18 import GHC.Prelude
19
20 import GHC.ByteCode.Instr
21 import GHC.ByteCode.InfoTable
22 import GHC.ByteCode.Types
23 import GHCi.RemoteTypes
24 import GHC.Runtime.Interpreter
25 import GHC.Runtime.Heap.Layout hiding ( WordOff )
26
27 import GHC.Types.Name
28 import GHC.Types.Name.Set
29 import GHC.Types.Literal
30 import GHC.Types.Unique
31 import GHC.Types.Unique.DSet
32
33 import GHC.Utils.Outputable
34 import GHC.Utils.Panic
35 import GHC.Utils.Panic.Plain
36
37 import GHC.Core.TyCon
38 import GHC.Data.FastString
39 import GHC.Data.SizedSeq
40
41 import GHC.StgToCmm.Layout ( ArgRep(..) )
42 import GHC.Cmm.Expr
43 import GHC.Cmm.CallConv ( tupleRegsCover )
44 import GHC.Platform
45 import GHC.Platform.Profile
46
47 import Control.Monad
48 import Control.Monad.ST ( runST )
49 import Control.Monad.Trans.Class
50 import Control.Monad.Trans.State.Strict
51
52 import Data.Array.MArray
53
54 import qualified Data.Array.Unboxed as Array
55 import Data.Array.Base ( UArray(..) )
56
57 import Data.Array.Unsafe( castSTUArray )
58
59 import Foreign hiding (shiftL, shiftR)
60 import Data.Char ( ord )
61 import Data.List ( genericLength )
62 import Data.Map.Strict (Map)
63 import Data.Maybe (fromMaybe)
64 import qualified Data.Map.Strict as Map
65
66 -- -----------------------------------------------------------------------------
67 -- Unlinked BCOs
68
69 -- CompiledByteCode represents the result of byte-code
70 -- compiling a bunch of functions and data types
71
72 -- | Finds external references. Remember to remove the names
73 -- defined by this group of BCOs themselves
74 bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
75 bcoFreeNames bco
76 = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]
77 where
78 bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
79 = unionManyUniqDSets (
80 mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :
81 mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
82 map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
83 )
84
85 -- -----------------------------------------------------------------------------
86 -- The bytecode assembler
87
88 -- The object format for bytecodes is: 16 bits for the opcode, and 16
89 -- for each field -- so the code can be considered a sequence of
90 -- 16-bit ints. Each field denotes either a stack offset or number of
91 -- items on the stack (eg SLIDE), and index into the pointer table (eg
92 -- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
93 -- bytecode address in this BCO.
94
95 -- Top level assembler fn.
96 assembleBCOs
97 :: Interp
98 -> Profile
99 -> [ProtoBCO Name]
100 -> [TyCon]
101 -> [RemotePtr ()]
102 -> Maybe ModBreaks
103 -> IO CompiledByteCode
104 assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
105 -- TODO: the profile should be bundled with the interpreter: the rts ways are
106 -- fixed for an interpreter
107 itblenv <- mkITbls interp profile tycons
108 bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
109 (bcos',ptrs) <- mallocStrings interp bcos
110 return CompiledByteCode
111 { bc_bcos = bcos'
112 , bc_itbls = itblenv
113 , bc_ffis = concatMap protoBCOFFIs proto_bcos
114 , bc_strs = top_strs ++ ptrs
115 , bc_breaks = modbreaks
116 }
117
118 -- Find all the literal strings and malloc them together. We want to
119 -- do this because:
120 --
121 -- a) It should be done when we compile the module, not each time we relink it
122 -- b) For -fexternal-interpreter It's more efficient to malloc the strings
123 -- as a single batch message, especially when compiling in parallel.
124 --
125 mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
126 mallocStrings interp ulbcos = do
127 let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
128 ptrs <- interpCmd interp (MallocStrings bytestrings)
129 return (evalState (mapM splice ulbcos) ptrs, ptrs)
130 where
131 splice bco@UnlinkedBCO{..} = do
132 lits <- mapM spliceLit unlinkedBCOLits
133 ptrs <- mapM splicePtr unlinkedBCOPtrs
134 return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
135
136 spliceLit (BCONPtrStr _) = do
137 rptrs <- get
138 case rptrs of
139 (RemotePtr p : rest) -> do
140 put rest
141 return (BCONPtrWord (fromIntegral p))
142 _ -> panic "mallocStrings:spliceLit"
143 spliceLit other = return other
144
145 splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
146 splicePtr other = return other
147
148 collect UnlinkedBCO{..} = do
149 mapM_ collectLit unlinkedBCOLits
150 mapM_ collectPtr unlinkedBCOPtrs
151
152 collectLit (BCONPtrStr bs) = do
153 strs <- get
154 put (bs:strs)
155 collectLit _ = return ()
156
157 collectPtr (BCOPtrBCO bco) = collect bco
158 collectPtr _ = return ()
159
160
161 assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
162 assembleOneBCO interp profile pbco = do
163 -- TODO: the profile should be bundled with the interpreter: the rts ways are
164 -- fixed for an interpreter
165 ubco <- assembleBCO (profilePlatform profile) pbco
166 ([ubco'], _ptrs) <- mallocStrings interp [ubco]
167 return ubco'
168
169 assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
170 assembleBCO platform (ProtoBCO { protoBCOName = nm
171 , protoBCOInstrs = instrs
172 , protoBCOBitmap = bitmap
173 , protoBCOBitmapSize = bsize
174 , protoBCOArity = arity }) = do
175 -- pass 1: collect up the offsets of the local labels.
176 let asm = mapM_ (assembleI platform) instrs
177
178 initial_offset = 0
179
180 -- Jump instructions are variable-sized, there are long and short variants
181 -- depending on the magnitude of the offset. However, we can't tell what
182 -- size instructions we will need until we have calculated the offsets of
183 -- the labels, which depends on the size of the instructions... So we
184 -- first create the label environment assuming that all jumps are short,
185 -- and if the final size is indeed small enough for short jumps, we are
186 -- done. Otherwise, we repeat the calculation, and we force all jumps in
187 -- this BCO to be long.
188 (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm
189 ((n_insns, lbl_map), long_jumps)
190 | isLarge (fromIntegral $ Map.size lbl_map0)
191 || isLarge n_insns0
192 = (inspectAsm platform True initial_offset asm, True)
193 | otherwise = ((n_insns0, lbl_map0), False)
194
195 env :: LocalLabel -> Word
196 env lbl = fromMaybe
197 (pprPanic "assembleBCO.findLabel" (ppr lbl))
198 (Map.lookup lbl lbl_map)
199
200 -- pass 2: run assembler and generate instructions, literals and pointers
201 let initial_state = (emptySS, emptySS, emptySS)
202 (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm
203
204 -- precomputed size should be equal to final size
205 massert (n_insns == sizeSS final_insns)
206
207 let asm_insns = ssElts final_insns
208 insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
209 bitmap_arr = mkBitmapArray bsize bitmap
210 ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
211
212 -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
213 -- objects, since they might get run too early. Disable this until
214 -- we figure out what to do.
215 -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
216
217 return ul_bco
218
219 mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64
220 -- Here the return type must be an array of Words, not StgWords,
221 -- because the underlying ByteArray# will end up as a component
222 -- of a BCO object.
223 mkBitmapArray bsize bitmap
224 = Array.listArray (0, length bitmap) $
225 fromIntegral bsize : map (fromInteger . fromStgWord) bitmap
226
227 -- instrs nonptrs ptrs
228 type AsmState = (SizedSeq Word16,
229 SizedSeq BCONPtr,
230 SizedSeq BCOPtr)
231
232 data Operand
233 = Op Word
234 | SmallOp Word16
235 | LabelOp LocalLabel
236 -- (unused) | LargeOp Word
237
238 data Assembler a
239 = AllocPtr (IO BCOPtr) (Word -> Assembler a)
240 | AllocLit [BCONPtr] (Word -> Assembler a)
241 | AllocLabel LocalLabel (Assembler a)
242 | Emit Word16 [Operand] (Assembler a)
243 | NullAsm a
244 deriving (Functor)
245
246 instance Applicative Assembler where
247 pure = NullAsm
248 (<*>) = ap
249
250 instance Monad Assembler where
251 NullAsm x >>= f = f x
252 AllocPtr p k >>= f = AllocPtr p (k >=> f)
253 AllocLit l k >>= f = AllocLit l (k >=> f)
254 AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)
255 Emit w ops k >>= f = Emit w ops (k >>= f)
256
257 ioptr :: IO BCOPtr -> Assembler Word
258 ioptr p = AllocPtr p return
259
260 ptr :: BCOPtr -> Assembler Word
261 ptr = ioptr . return
262
263 lit :: [BCONPtr] -> Assembler Word
264 lit l = AllocLit l return
265
266 label :: LocalLabel -> Assembler ()
267 label w = AllocLabel w (return ())
268
269 emit :: Word16 -> [Operand] -> Assembler ()
270 emit w ops = Emit w ops (return ())
271
272 type LabelEnv = LocalLabel -> Word
273
274 largeOp :: Bool -> Operand -> Bool
275 largeOp long_jumps op = case op of
276 SmallOp _ -> False
277 Op w -> isLarge w
278 LabelOp _ -> long_jumps
279 -- LargeOp _ -> True
280
281 runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
282 runAsm platform long_jumps e = go
283 where
284 go (NullAsm x) = return x
285 go (AllocPtr p_io k) = do
286 p <- lift p_io
287 w <- state $ \(st_i0,st_l0,st_p0) ->
288 let st_p1 = addToSS st_p0 p
289 in (sizeSS st_p0, (st_i0,st_l0,st_p1))
290 go $ k w
291 go (AllocLit lits k) = do
292 w <- state $ \(st_i0,st_l0,st_p0) ->
293 let st_l1 = addListToSS st_l0 lits
294 in (sizeSS st_l0, (st_i0,st_l1,st_p0))
295 go $ k w
296 go (AllocLabel _ k) = go k
297 go (Emit w ops k) = do
298 let largeOps = any (largeOp long_jumps) ops
299 opcode
300 | largeOps = largeArgInstr w
301 | otherwise = w
302 words = concatMap expand ops
303 expand (SmallOp w) = [w]
304 expand (LabelOp w) = expand (Op (e w))
305 expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]
306 -- expand (LargeOp w) = largeArg platform w
307 state $ \(st_i0,st_l0,st_p0) ->
308 let st_i1 = addListToSS st_i0 (opcode : words)
309 in ((), (st_i1,st_l0,st_p0))
310 go k
311
312 type LabelEnvMap = Map LocalLabel Word
313
314 data InspectState = InspectState
315 { instrCount :: !Word
316 , ptrCount :: !Word
317 , litCount :: !Word
318 , lblEnv :: LabelEnvMap
319 }
320
321 inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
322 inspectAsm platform long_jumps initial_offset
323 = go (InspectState initial_offset 0 0 Map.empty)
324 where
325 go s (NullAsm _) = (instrCount s, lblEnv s)
326 go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
327 where n = ptrCount s
328 go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
329 where n = litCount s
330 go s (AllocLabel lbl k) = go s' k
331 where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
332 go s (Emit _ ops k) = go s' k
333 where
334 s' = s { instrCount = instrCount s + size }
335 size = sum (map count ops) + 1
336 largeOps = any (largeOp long_jumps) ops
337 count (SmallOp _) = 1
338 count (LabelOp _) = count (Op 0)
339 count (Op _) = if largeOps then largeArg16s platform else 1
340 -- count (LargeOp _) = largeArg16s platform
341
342 -- Bring in all the bci_ bytecode constants.
343 #include "Bytecodes.h"
344
345 largeArgInstr :: Word16 -> Word16
346 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
347
348 largeArg :: Platform -> Word -> [Word16]
349 largeArg platform w = case platformWordSize platform of
350 PW8 -> [fromIntegral (w `shiftR` 48),
351 fromIntegral (w `shiftR` 32),
352 fromIntegral (w `shiftR` 16),
353 fromIntegral w]
354 PW4 -> [fromIntegral (w `shiftR` 16),
355 fromIntegral w]
356
357 largeArg16s :: Platform -> Word
358 largeArg16s platform = case platformWordSize platform of
359 PW8 -> 4
360 PW4 -> 2
361
362 assembleI :: Platform
363 -> BCInstr
364 -> Assembler ()
365 assembleI platform i = case i of
366 STKCHECK n -> emit bci_STKCHECK [Op n]
367 PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1]
368 PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
369 PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
370 PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1]
371 PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1]
372 PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1]
373 PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1]
374 PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1]
375 PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp o1]
376 PUSH_G nm -> do p <- ptr (BCOPtrName nm)
377 emit bci_PUSH_G [Op p]
378 PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op)
379 emit bci_PUSH_G [Op p]
380 PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto
381 p <- ioptr (liftM BCOPtrBCO ul_bco)
382 emit bci_PUSH_G [Op p]
383 PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto
384 p <- ioptr (liftM BCOPtrBCO ul_bco)
385 emit bci_PUSH_ALTS [Op p]
386 PUSH_ALTS_UNLIFTED proto pk
387 -> do let ul_bco = assembleBCO platform proto
388 p <- ioptr (liftM BCOPtrBCO ul_bco)
389 emit (push_alts pk) [Op p]
390 PUSH_ALTS_TUPLE proto tuple_info tuple_proto
391 -> do let ul_bco = assembleBCO platform proto
392 ul_tuple_bco = assembleBCO platform
393 tuple_proto
394 p <- ioptr (liftM BCOPtrBCO ul_bco)
395 p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
396 info <- int (fromIntegral $
397 mkTupleInfoSig platform tuple_info)
398 emit bci_PUSH_ALTS_T
399 [Op p, Op info, Op p_tup]
400 PUSH_PAD8 -> emit bci_PUSH_PAD8 []
401 PUSH_PAD16 -> emit bci_PUSH_PAD16 []
402 PUSH_PAD32 -> emit bci_PUSH_PAD32 []
403 PUSH_UBX8 lit -> do np <- literal lit
404 emit bci_PUSH_UBX8 [Op np]
405 PUSH_UBX16 lit -> do np <- literal lit
406 emit bci_PUSH_UBX16 [Op np]
407 PUSH_UBX32 lit -> do np <- literal lit
408 emit bci_PUSH_UBX32 [Op np]
409 PUSH_UBX lit nws -> do np <- literal lit
410 emit bci_PUSH_UBX [Op np, SmallOp nws]
411
412 PUSH_APPLY_N -> emit bci_PUSH_APPLY_N []
413 PUSH_APPLY_V -> emit bci_PUSH_APPLY_V []
414 PUSH_APPLY_F -> emit bci_PUSH_APPLY_F []
415 PUSH_APPLY_D -> emit bci_PUSH_APPLY_D []
416 PUSH_APPLY_L -> emit bci_PUSH_APPLY_L []
417 PUSH_APPLY_P -> emit bci_PUSH_APPLY_P []
418 PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP []
419 PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP []
420 PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP []
421 PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP []
422 PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP []
423
424 SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by]
425 ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n]
426 ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n]
427 ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
428 MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz]
429 MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz]
430 UNPACK n -> emit bci_UNPACK [SmallOp n]
431 PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]
432 emit bci_PACK [Op itbl_no, SmallOp sz]
433 LABEL lbl -> label lbl
434 TESTLT_I i l -> do np <- int i
435 emit bci_TESTLT_I [Op np, LabelOp l]
436 TESTEQ_I i l -> do np <- int i
437 emit bci_TESTEQ_I [Op np, LabelOp l]
438 TESTLT_W w l -> do np <- word w
439 emit bci_TESTLT_W [Op np, LabelOp l]
440 TESTEQ_W w l -> do np <- word w
441 emit bci_TESTEQ_W [Op np, LabelOp l]
442 TESTLT_F f l -> do np <- float f
443 emit bci_TESTLT_F [Op np, LabelOp l]
444 TESTEQ_F f l -> do np <- float f
445 emit bci_TESTEQ_F [Op np, LabelOp l]
446 TESTLT_D d l -> do np <- double d
447 emit bci_TESTLT_D [Op np, LabelOp l]
448 TESTEQ_D d l -> do np <- double d
449 emit bci_TESTEQ_D [Op np, LabelOp l]
450 TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l]
451 TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]
452 CASEFAIL -> emit bci_CASEFAIL []
453 SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
454 JMP l -> emit bci_JMP [LabelOp l]
455 ENTER -> emit bci_ENTER []
456 RETURN -> emit bci_RETURN []
457 RETURN_UNLIFTED rep -> emit (return_unlifted rep) []
458 RETURN_TUPLE -> emit bci_RETURN_T []
459 CCALL off m_addr i -> do np <- addr m_addr
460 emit bci_CCALL [SmallOp off, Op np, SmallOp i]
461 BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray
462 q <- int (getKey uniq)
463 np <- addr cc
464 emit bci_BRK_FUN [Op p1, SmallOp index,
465 Op q, Op np]
466
467 where
468 literal (LitLabel fs (Just sz) _)
469 | platformOS platform == OSMinGW32
470 = litlabel (appendFS fs (mkFastString ('@':show sz)))
471 -- On Windows, stdcall labels have a suffix indicating the no. of
472 -- arg words, e.g. foo@8. testcase: ffi012(ghci)
473 literal (LitLabel fs _ _) = litlabel fs
474 literal LitNullAddr = int 0
475 literal (LitFloat r) = float (fromRational r)
476 literal (LitDouble r) = double (fromRational r)
477 literal (LitChar c) = int (ord c)
478 literal (LitString bs) = lit [BCONPtrStr bs]
479 -- LitString requires a zero-terminator when emitted
480 literal (LitNumber nt i) = case nt of
481 LitNumInt -> int (fromIntegral i)
482 LitNumWord -> int (fromIntegral i)
483 LitNumInt8 -> int8 (fromIntegral i)
484 LitNumWord8 -> int8 (fromIntegral i)
485 LitNumInt16 -> int16 (fromIntegral i)
486 LitNumWord16 -> int16 (fromIntegral i)
487 LitNumInt32 -> int32 (fromIntegral i)
488 LitNumWord32 -> int32 (fromIntegral i)
489 LitNumInt64 -> int64 (fromIntegral i)
490 LitNumWord64 -> int64 (fromIntegral i)
491 LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"
492
493 -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
494 -- likely to elicit a crash (rather than corrupt memory) in case absence
495 -- analysis messed up.
496 literal (LitRubbish {}) = int 0
497
498 litlabel fs = lit [BCONPtrLbl fs]
499 addr (RemotePtr a) = words [fromIntegral a]
500 float = words . mkLitF
501 double = words . mkLitD platform
502 int = words . mkLitI
503 int8 = words . mkLitI64 platform
504 int16 = words . mkLitI64 platform
505 int32 = words . mkLitI64 platform
506 int64 = words . mkLitI64 platform
507 words ws = lit (map BCONPtrWord ws)
508 word w = words [w]
509
510 isLarge :: Word -> Bool
511 isLarge n = n > 65535
512
513 push_alts :: ArgRep -> Word16
514 push_alts V = bci_PUSH_ALTS_V
515 push_alts P = bci_PUSH_ALTS_P
516 push_alts N = bci_PUSH_ALTS_N
517 push_alts L = bci_PUSH_ALTS_L
518 push_alts F = bci_PUSH_ALTS_F
519 push_alts D = bci_PUSH_ALTS_D
520 push_alts V16 = error "push_alts: vector"
521 push_alts V32 = error "push_alts: vector"
522 push_alts V64 = error "push_alts: vector"
523
524 return_unlifted :: ArgRep -> Word16
525 return_unlifted V = bci_RETURN_V
526 return_unlifted P = bci_RETURN_P
527 return_unlifted N = bci_RETURN_N
528 return_unlifted L = bci_RETURN_L
529 return_unlifted F = bci_RETURN_F
530 return_unlifted D = bci_RETURN_D
531 return_unlifted V16 = error "return_unlifted: vector"
532 return_unlifted V32 = error "return_unlifted: vector"
533 return_unlifted V64 = error "return_unlifted: vector"
534
535 {-
536 we can only handle up to a fixed number of words on the stack,
537 because we need a stg_ctoi_tN stack frame for each size N. See
538 Note [unboxed tuple bytecodes and tuple_BCO].
539
540 If needed, you can support larger tuples by adding more in
541 StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
542 raising this limit.
543
544 Note that the limit is the number of words passed on the stack.
545 If the calling convention passes part of the tuple in registers, the
546 maximum number of tuple elements may be larger. Elements can also
547 take multiple words on the stack (for example Double# on a 32 bit
548 platform).
549
550 -}
551 maxTupleNativeStackSize :: WordOff
552 maxTupleNativeStackSize = 62
553
554 {-
555 Construct the tuple_info word that stg_ctoi_t and stg_ret_t use
556 to convert a tuple between the native calling convention and the
557 interpreter.
558
559 See Note [GHCi tuple layout] for more information.
560 -}
561 mkTupleInfoSig :: Platform -> TupleInfo -> Word32
562 mkTupleInfoSig platform TupleInfo{..}
563 | tupleNativeStackSize > maxTupleNativeStackSize
564 = pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"
565 (ppr tupleNativeStackSize <+> text "stack words." <+>
566 text "Use -fobject-code to get around this limit"
567 )
568 | otherwise
569 = assert (length regs <= 24) {- 24 bits for bitmap -}
570 assert (tupleNativeStackSize < 255) {- 8 bits for stack size -}
571 assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}
572 foldl' reg_bit 0 (zip regs [0..]) .|.
573 (fromIntegral tupleNativeStackSize `shiftL` 24)
574 where
575 reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
576 reg_bit x (r, n)
577 | r `elemRegSet` tupleRegs = x .|. 1 `shiftL` n
578 | otherwise = x
579 regs = tupleRegsCover platform
580
581 mkTupleInfoLit :: Platform -> TupleInfo -> Literal
582 mkTupleInfoLit platform tuple_info =
583 mkLitWord platform . fromIntegral $ mkTupleInfoSig platform tuple_info
584
585 -- Make lists of host-sized words for literals, so that when the
586 -- words are placed in memory at increasing addresses, the
587 -- bit pattern is correct for the host's word size and endianness.
588 mkLitI :: Int -> [Word]
589 mkLitF :: Float -> [Word]
590 mkLitD :: Platform -> Double -> [Word]
591 mkLitI64 :: Platform -> Int64 -> [Word]
592
593 mkLitF f
594 = runST (do
595 arr <- newArray_ ((0::Int),0)
596 writeArray arr 0 f
597 f_arr <- castSTUArray arr
598 w0 <- readArray f_arr 0
599 return [w0 :: Word]
600 )
601
602 mkLitD platform d = case platformWordSize platform of
603 PW4 -> runST (do
604 arr <- newArray_ ((0::Int),1)
605 writeArray arr 0 d
606 d_arr <- castSTUArray arr
607 w0 <- readArray d_arr 0
608 w1 <- readArray d_arr 1
609 return [w0 :: Word, w1]
610 )
611 PW8 -> runST (do
612 arr <- newArray_ ((0::Int),0)
613 writeArray arr 0 d
614 d_arr <- castSTUArray arr
615 w0 <- readArray d_arr 0
616 return [w0 :: Word]
617 )
618
619 mkLitI64 platform ii = case platformWordSize platform of
620 PW4 -> runST (do
621 arr <- newArray_ ((0::Int),1)
622 writeArray arr 0 ii
623 d_arr <- castSTUArray arr
624 w0 <- readArray d_arr 0
625 w1 <- readArray d_arr 1
626 return [w0 :: Word,w1]
627 )
628 PW8 -> runST (do
629 arr <- newArray_ ((0::Int),0)
630 writeArray arr 0 ii
631 d_arr <- castSTUArray arr
632 w0 <- readArray d_arr 0
633 return [w0 :: Word]
634 )
635
636 mkLitI i = [fromIntegral i :: Word]
637
638 iNTERP_STACK_CHECK_THRESH :: Int
639 iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH