2 % (c) The University of Glasgow 2002-2006
5 ByteCodeLink: Bytecode assembler and linker
8 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
11 assembleBCOs, assembleBCO,
14 UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames,
15 SizedSeq, sizeSS, ssElts,
16 iNTERP_STACK_CHECK_THRESH
19 #include "HsVersions.h"
35 import Control.Monad ( foldM )
36 import Control.Monad.ST ( runST )
38 import Data.Array.MArray
39 import Data.Array.Unboxed ( listArray )
40 import Data.Array.Base ( UArray(..) )
41 import Data.Array.ST ( castSTUArray )
43 import Data.Char ( ord )
45 import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
47 -- -----------------------------------------------------------------------------
50 -- CompiledByteCode represents the result of byte-code
51 -- compiling a bunch of functions and data types
54 = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
55 ItblEnv -- A mapping from DataCons to their itbls
57 instance Outputable CompiledByteCode where
58 ppr (ByteCode bcos _) = ppr bcos
63 unlinkedBCOName :: Name,
64 unlinkedBCOArity :: Int,
65 unlinkedBCOInstrs :: ByteArray#, -- insns
66 unlinkedBCOBitmap :: ByteArray#, -- bitmap
67 unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
68 unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
74 | BCOPtrBCO UnlinkedBCO
75 | BCOPtrBreakInfo BreakInfo
76 | BCOPtrArray (MutableByteArray# RealWorld)
80 | BCONPtrLbl FastString
83 -- | Finds external references. Remember to remove the names
84 -- defined by this group of BCOs themselves
85 bcoFreeNames :: UnlinkedBCO -> NameSet
87 = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
89 bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
91 mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
92 mkNameSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
93 map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
96 instance Outputable UnlinkedBCO where
97 ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
98 = sep [text "BCO", ppr nm, text "with",
99 int (sizeSS lits), text "lits",
100 int (sizeSS ptrs), text "ptrs" ]
102 -- -----------------------------------------------------------------------------
103 -- The bytecode assembler
105 -- The object format for bytecodes is: 16 bits for the opcode, and 16
106 -- for each field -- so the code can be considered a sequence of
107 -- 16-bit ints. Each field denotes either a stack offset or number of
108 -- items on the stack (eg SLIDE), and index into the pointer table (eg
109 -- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
110 -- bytecode address in this BCO.
112 -- Top level assembler fn.
113 assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
114 assembleBCOs proto_bcos tycons
115 = do itblenv <- mkITbls tycons
116 bcos <- mapM assembleBCO proto_bcos
117 return (ByteCode bcos itblenv)
119 assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
120 assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
122 -- pass 1: collect up the offsets of the local labels.
123 -- Remember that the first insn starts at offset 1 since offset 0
124 -- (eventually) will hold the total # of insns.
125 label_env = mkLabelEnv emptyFM 1 instrs
127 mkLabelEnv env _ [] = env
128 mkLabelEnv env i_offset (i:is)
130 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
131 in mkLabelEnv new_env (i_offset + instrSize16s i) is
134 = case lookupFM label_env lab of
135 Just bco_offset -> bco_offset
136 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
138 do -- pass 2: generate the instruction, ptr and nonptr bits
139 insns <- return emptySS :: IO (SizedSeq Word16)
140 lits <- return emptySS :: IO (SizedSeq BCONPtr)
141 ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
142 let init_asm_state = (insns,lits,ptrs)
143 (final_insns, final_lits, final_ptrs)
144 <- mkBits findLabel init_asm_state instrs
146 let asm_insns = ssElts final_insns
147 n_insns = sizeSS final_insns
150 | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
151 | otherwise = mkInstrArray n_insns asm_insns
152 !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
154 bitmap_arr = mkBitmapArray bsize bitmap
155 !bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr
157 let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
159 -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
160 -- objects, since they might get run too early. Disable this until
161 -- we figure out what to do.
162 -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
166 -- zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
169 mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
170 mkBitmapArray bsize bitmap
171 = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
173 mkInstrArray :: Int -> [Word16] -> UArray Int Word16
174 mkInstrArray n_insns asm_insns
175 = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
177 -- instrs nonptrs ptrs
178 type AsmState = (SizedSeq Word16,
182 data SizedSeq a = SizedSeq !Int [a]
183 emptySS :: SizedSeq a
184 emptySS = SizedSeq 0 []
186 -- Why are these two monadic???
187 addToSS :: SizedSeq a -> a -> IO (SizedSeq a)
188 addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
189 addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a)
190 addListToSS (SizedSeq n r_xs) xs
191 = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
193 ssElts :: SizedSeq a -> [a]
194 ssElts (SizedSeq _ r_xs) = reverse r_xs
196 sizeSS :: SizedSeq a -> Int
197 sizeSS (SizedSeq n _) = n
199 -- Bring in all the bci_ bytecode constants.
200 #include "Bytecodes.h"
202 largeArgInstr :: Int -> Int
203 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
205 largeArg :: Int -> [Int]
207 | wORD_SIZE_IN_BITS == 64
208 = [(i .&. 0xFFFF000000000000) `shiftR` 48,
209 (i .&. 0x0000FFFF00000000) `shiftR` 32,
210 (i .&. 0x00000000FFFF0000) `shiftR` 16,
211 (i .&. 0x000000000000FFFF)]
212 | wORD_SIZE_IN_BITS == 32
213 = [(i .&. 0xFFFF0000) `shiftR` 16,
215 | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
217 -- This is where all the action is (pass 2 of the assembler)
218 mkBits :: (Int -> Int) -- label finder
220 -> [BCInstr] -- instructions (in)
223 mkBits findLabel st proto_insns
224 = foldM doInstr st proto_insns
226 doInstr :: AsmState -> BCInstr -> IO AsmState
231 instrn st (largeArgInstr bci_STKCHECK : largeArg n)
232 | otherwise -> instr2 st bci_STKCHECK n
233 PUSH_L o1 -> instr2 st bci_PUSH_L o1
234 PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2
235 PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
236 PUSH_G nm -> do (p, st2) <- ptr st (BCOPtrName nm)
237 instr2 st2 bci_PUSH_G p
238 PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
239 instr2 st2 bci_PUSH_G p
240 PUSH_BCO proto -> do ul_bco <- assembleBCO proto
241 (p, st2) <- ptr st (BCOPtrBCO ul_bco)
242 instr2 st2 bci_PUSH_G p
243 PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
244 (p, st2) <- ptr st (BCOPtrBCO ul_bco)
245 instr2 st2 bci_PUSH_ALTS p
246 PUSH_ALTS_UNLIFTED proto pk -> do
247 ul_bco <- assembleBCO proto
248 (p, st2) <- ptr st (BCOPtrBCO ul_bco)
249 instr2 st2 (push_alts pk) p
250 PUSH_UBX (Left lit) nws
251 -> do (np, st2) <- literal st lit
252 instr3 st2 bci_PUSH_UBX np nws
253 PUSH_UBX (Right aa) nws
254 -> do (np, st2) <- addr st aa
255 instr3 st2 bci_PUSH_UBX np nws
257 PUSH_APPLY_N -> do instr1 st bci_PUSH_APPLY_N
258 PUSH_APPLY_V -> do instr1 st bci_PUSH_APPLY_V
259 PUSH_APPLY_F -> do instr1 st bci_PUSH_APPLY_F
260 PUSH_APPLY_D -> do instr1 st bci_PUSH_APPLY_D
261 PUSH_APPLY_L -> do instr1 st bci_PUSH_APPLY_L
262 PUSH_APPLY_P -> do instr1 st bci_PUSH_APPLY_P
263 PUSH_APPLY_PP -> do instr1 st bci_PUSH_APPLY_PP
264 PUSH_APPLY_PPP -> do instr1 st bci_PUSH_APPLY_PPP
265 PUSH_APPLY_PPPP -> do instr1 st bci_PUSH_APPLY_PPPP
266 PUSH_APPLY_PPPPP -> do instr1 st bci_PUSH_APPLY_PPPPP
267 PUSH_APPLY_PPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPP
269 SLIDE n by -> instr3 st bci_SLIDE n by
270 ALLOC_AP n -> instr2 st bci_ALLOC_AP n
271 ALLOC_AP_NOUPD n -> instr2 st bci_ALLOC_AP_NOUPD n
272 ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n
273 MKAP off sz -> instr3 st bci_MKAP off sz
274 MKPAP off sz -> instr3 st bci_MKPAP off sz
275 UNPACK n -> instr2 st bci_UNPACK n
276 PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
277 instr3 st2 bci_PACK itbl_no sz
279 TESTLT_I i l -> do (np, st2) <- int st i
280 instr3 st2 bci_TESTLT_I np (findLabel l)
281 TESTEQ_I i l -> do (np, st2) <- int st i
282 instr3 st2 bci_TESTEQ_I np (findLabel l)
283 TESTLT_F f l -> do (np, st2) <- float st f
284 instr3 st2 bci_TESTLT_F np (findLabel l)
285 TESTEQ_F f l -> do (np, st2) <- float st f
286 instr3 st2 bci_TESTEQ_F np (findLabel l)
287 TESTLT_D d l -> do (np, st2) <- double st d
288 instr3 st2 bci_TESTLT_D np (findLabel l)
289 TESTEQ_D d l -> do (np, st2) <- double st d
290 instr3 st2 bci_TESTEQ_D np (findLabel l)
291 TESTLT_P i l -> instr3 st bci_TESTLT_P i (findLabel l)
292 TESTEQ_P i l -> instr3 st bci_TESTEQ_P i (findLabel l)
293 CASEFAIL -> instr1 st bci_CASEFAIL
294 SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n
295 JMP l -> instr2 st bci_JMP (findLabel l)
296 ENTER -> instr1 st bci_ENTER
297 RETURN -> instr1 st bci_RETURN
298 RETURN_UBX rep -> instr1 st (return_ubx rep)
299 CCALL off m_addr -> do (np, st2) <- addr st m_addr
300 instr3 st2 bci_CCALL off np
301 BRK_FUN array index info -> do
302 (p1, st2) <- ptr st (BCOPtrArray array)
303 (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
304 instr4 st3 bci_BRK_FUN p1 index p2
309 instrn :: AsmState -> [Int] -> IO AsmState
310 instrn st [] = return st
311 instrn (st_i, st_l, st_p) (i:is)
312 = do st_i' <- addToSS st_i (i2s i)
313 instrn (st_i', st_l, st_p) is
315 instr1 (st_i0,st_l0,st_p0) i1
316 = do st_i1 <- addToSS st_i0 i1
317 return (st_i1,st_l0,st_p0)
319 instr2 (st_i0,st_l0,st_p0) i1 i2
320 = do st_i1 <- addToSS st_i0 (i2s i1)
321 st_i2 <- addToSS st_i1 (i2s i2)
322 return (st_i2,st_l0,st_p0)
324 instr3 (st_i0,st_l0,st_p0) i1 i2 i3
325 = do st_i1 <- addToSS st_i0 (i2s i1)
326 st_i2 <- addToSS st_i1 (i2s i2)
327 st_i3 <- addToSS st_i2 (i2s i3)
328 return (st_i3,st_l0,st_p0)
330 instr4 (st_i0,st_l0,st_p0) i1 i2 i3 i4
331 = do st_i1 <- addToSS st_i0 (i2s i1)
332 st_i2 <- addToSS st_i1 (i2s i2)
333 st_i3 <- addToSS st_i2 (i2s i3)
334 st_i4 <- addToSS st_i3 (i2s i4)
335 return (st_i4,st_l0,st_p0)
337 float (st_i0,st_l0,st_p0) f
338 = do let ws = mkLitF f
339 st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
340 return (sizeSS st_l0, (st_i0,st_l1,st_p0))
342 double (st_i0,st_l0,st_p0) d
343 = do let ws = mkLitD d
344 st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
345 return (sizeSS st_l0, (st_i0,st_l1,st_p0))
347 int (st_i0,st_l0,st_p0) i
348 = do let ws = mkLitI i
349 st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
350 return (sizeSS st_l0, (st_i0,st_l1,st_p0))
352 int64 (st_i0,st_l0,st_p0) i
353 = do let ws = mkLitI64 i
354 st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
355 return (sizeSS st_l0, (st_i0,st_l1,st_p0))
357 addr (st_i0,st_l0,st_p0) a
358 = do let ws = mkLitPtr a
359 st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
360 return (sizeSS st_l0, (st_i0,st_l1,st_p0))
362 litlabel (st_i0,st_l0,st_p0) fs
363 = do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs]
364 return (sizeSS st_l0, (st_i0,st_l1,st_p0))
366 ptr (st_i0,st_l0,st_p0) p
367 = do st_p1 <- addToSS st_p0 p
368 return (sizeSS st_p0, (st_i0,st_l0,st_p1))
370 itbl (st_i0,st_l0,st_p0) dcon
371 = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
372 return (sizeSS st_l0, (st_i0,st_l1,st_p0))
374 #ifdef mingw32_TARGET_OS
375 literal st (MachLabel fs (Just sz) _)
376 = litlabel st (appendFS fs (mkFastString ('@':show sz)))
377 -- On Windows, stdcall labels have a suffix indicating the no. of
378 -- arg words, e.g. foo@8. testcase: ffi012(ghci)
380 literal st (MachLabel fs _ _) = litlabel st fs
381 literal st (MachWord w) = int st (fromIntegral w)
382 literal st (MachInt j) = int st (fromIntegral j)
383 literal st MachNullAddr = int st 0
384 literal st (MachFloat r) = float st (fromRational r)
385 literal st (MachDouble r) = double st (fromRational r)
386 literal st (MachChar c) = int st (ord c)
387 literal st (MachInt64 ii) = int64 st (fromIntegral ii)
388 literal st (MachWord64 ii) = int64 st (fromIntegral ii)
389 literal _ other = pprPanic "ByteCodeAsm.literal" (ppr other)
392 push_alts :: CgRep -> Int
393 push_alts NonPtrArg = bci_PUSH_ALTS_N
394 push_alts FloatArg = bci_PUSH_ALTS_F
395 push_alts DoubleArg = bci_PUSH_ALTS_D
396 push_alts VoidArg = bci_PUSH_ALTS_V
397 push_alts LongArg = bci_PUSH_ALTS_L
398 push_alts PtrArg = bci_PUSH_ALTS_P
400 return_ubx :: CgRep -> Word16
401 return_ubx NonPtrArg = bci_RETURN_N
402 return_ubx FloatArg = bci_RETURN_F
403 return_ubx DoubleArg = bci_RETURN_D
404 return_ubx VoidArg = bci_RETURN_V
405 return_ubx LongArg = bci_RETURN_L
406 return_ubx PtrArg = bci_RETURN_P
409 -- The size in 16-bit entities of an instruction.
410 instrSize16s :: BCInstr -> Int
421 PUSH_ALTS_UNLIFTED{} -> 2
430 PUSH_APPLY_PPP{} -> 1
431 PUSH_APPLY_PPPP{} -> 1
432 PUSH_APPLY_PPPPP{} -> 1
433 PUSH_APPLY_PPPPPP{} -> 1
436 ALLOC_AP_NOUPD{} -> 2
460 -- Make lists of host-sized words for literals, so that when the
461 -- words are placed in memory at increasing addresses, the
462 -- bit pattern is correct for the host's word size and endianness.
463 mkLitI :: Int -> [Word]
464 mkLitF :: Float -> [Word]
465 mkLitD :: Double -> [Word]
466 mkLitPtr :: Ptr () -> [Word]
467 mkLitI64 :: Int64 -> [Word]
471 arr <- newArray_ ((0::Int),0)
473 f_arr <- castSTUArray arr
474 w0 <- readArray f_arr 0
481 arr <- newArray_ ((0::Int),1)
483 d_arr <- castSTUArray arr
484 w0 <- readArray d_arr 0
485 w1 <- readArray d_arr 1
486 return [w0 :: Word, w1]
490 arr <- newArray_ ((0::Int),0)
492 d_arr <- castSTUArray arr
493 w0 <- readArray d_arr 0
497 = panic "mkLitD: Bad wORD_SIZE"
502 arr <- newArray_ ((0::Int),1)
504 d_arr <- castSTUArray arr
505 w0 <- readArray d_arr 0
506 w1 <- readArray d_arr 1
507 return [w0 :: Word,w1]
511 arr <- newArray_ ((0::Int),0)
513 d_arr <- castSTUArray arr
514 w0 <- readArray d_arr 0
518 = panic "mkLitI64: Bad wORD_SIZE"
522 arr <- newArray_ ((0::Int),0)
524 i_arr <- castSTUArray arr
525 w0 <- readArray i_arr 0
531 arr <- newArray_ ((0::Int),0)
533 a_arr <- castSTUArray arr
534 w0 <- readArray a_arr 0
538 iNTERP_STACK_CHECK_THRESH :: Int
539 iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH