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