2 % (c) The University of Glasgow 2002
4 \section[ByteCodeLink]{Bytecode assembler and linker}
7 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
10 assembleBCOs, assembleBCO,
13 UnlinkedBCO(..), BCOPtr(..), bcoFreeNames,
14 SizedSeq, sizeSS, ssElts,
15 iNTERP_STACK_CHECK_THRESH
18 #include "HsVersions.h"
21 import ByteCodeItbls ( ItblEnv, mkITbls )
23 import Name ( Name, getName )
25 import FiniteMap ( addToFM, lookupFM, emptyFM )
26 import Literal ( Literal(..) )
27 import TyCon ( TyCon )
28 import PrimOp ( PrimOp )
29 import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep )
30 import Constants ( wORD_SIZE )
31 import FastString ( FastString(..) )
32 import SMRep ( StgWord )
36 import Control.Monad ( foldM )
37 import Control.Monad.ST ( runST )
39 import GHC.Word ( Word(..) )
40 import Data.Array.MArray
41 import Data.Array.Unboxed ( listArray )
42 import Data.Array.Base ( UArray(..) )
43 import Data.Array.ST ( castSTUArray )
44 import Foreign ( Word16, free )
45 import Data.Int ( Int64 )
46 import Data.Char ( ord )
48 import GHC.Base ( ByteArray# )
49 import GHC.IOBase ( IO(..) )
50 import GHC.Ptr ( Ptr(..) )
52 -- -----------------------------------------------------------------------------
55 -- CompiledByteCode represents the result of byte-code
56 -- compiling a bunch of functions and data types
59 = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
60 ItblEnv -- A mapping from DataCons to their itbls
62 instance Outputable CompiledByteCode where
63 ppr (ByteCode bcos _) = ppr bcos
68 unlinkedBCOName :: Name,
69 unlinkedBCOArity :: Int,
70 unlinkedBCOInstrs :: ByteArray#, -- insns
71 unlinkedBCOBitmap :: ByteArray#, -- bitmap
72 unlinkedBCOLits :: (SizedSeq (Either Word FastString)), -- literals
73 -- Either literal words or a pointer to a asciiz
74 -- string, denoting a label whose *address* should
75 -- be determined at link time
76 unlinkedBCOPtrs :: (SizedSeq BCOPtr), -- ptrs
77 unlinkedBCOItbls :: (SizedSeq Name) -- itbl refs
83 | BCOPtrBCO UnlinkedBCO
85 -- | Finds external references. Remember to remove the names
86 -- defined by this group of BCOs themselves
87 bcoFreeNames :: UnlinkedBCO -> NameSet
89 = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
91 bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls)
93 mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
94 mkNameSet (ssElts itbls) :
95 map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
98 instance Outputable UnlinkedBCO where
99 ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls)
100 = sep [text "BCO", ppr nm, text "with",
101 int (sizeSS lits), text "lits",
102 int (sizeSS ptrs), text "ptrs",
103 int (sizeSS itbls), text "itbls"]
105 -- -----------------------------------------------------------------------------
106 -- The bytecode assembler
108 -- The object format for bytecodes is: 16 bits for the opcode, and 16
109 -- for each field -- so the code can be considered a sequence of
110 -- 16-bit ints. Each field denotes either a stack offset or number of
111 -- items on the stack (eg SLIDE), and index into the pointer table (eg
112 -- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
113 -- bytecode address in this BCO.
115 -- Top level assembler fn.
116 assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
117 assembleBCOs proto_bcos tycons
118 = do itblenv <- mkITbls tycons
119 bcos <- mapM assembleBCO proto_bcos
120 return (ByteCode bcos itblenv)
122 assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
123 assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
125 -- pass 1: collect up the offsets of the local labels.
126 -- Remember that the first insn starts at offset 1 since offset 0
127 -- (eventually) will hold the total # of insns.
128 label_env = mkLabelEnv emptyFM 1 instrs
130 mkLabelEnv env i_offset [] = env
131 mkLabelEnv env i_offset (i:is)
133 = case i of LABEL n -> addToFM env n i_offset ; _ -> env
134 in mkLabelEnv new_env (i_offset + instrSize16s i) is
137 = case lookupFM label_env lab of
138 Just bco_offset -> bco_offset
139 Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
141 do -- pass 2: generate the instruction, ptr and nonptr bits
142 insns <- return emptySS :: IO (SizedSeq Word16)
143 lits <- return emptySS :: IO (SizedSeq (Either Word FastString))
144 ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
145 itbls <- return emptySS :: IO (SizedSeq Name)
146 let init_asm_state = (insns,lits,ptrs,itbls)
147 (final_insns, final_lits, final_ptrs, final_itbls)
148 <- mkBits findLabel init_asm_state instrs
150 let asm_insns = ssElts final_insns
151 n_insns = sizeSS final_insns
154 | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
155 | otherwise = mkInstrArray n_insns asm_insns
156 insns_barr = case insns_arr of UArray _lo _hi barr -> barr
158 bitmap_arr = mkBitmapArray bsize bitmap
159 bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
161 let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits
162 final_ptrs final_itbls
164 -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
165 -- objects, since they might get run too early. Disable this until
166 -- we figure out what to do.
167 -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
171 zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
174 mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
175 mkBitmapArray bsize bitmap
176 = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
178 mkInstrArray :: Int -> [Word16] -> UArray Int Word16
179 mkInstrArray n_insns asm_insns
180 = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
182 -- instrs nonptrs ptrs itbls
183 type AsmState = (SizedSeq Word16,
184 SizedSeq (Either Word FastString),
188 data SizedSeq a = SizedSeq !Int [a]
189 emptySS = SizedSeq 0 []
191 -- Why are these two monadic???
192 addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
193 addListToSS (SizedSeq n r_xs) xs
194 = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
196 ssElts :: SizedSeq a -> [a]
197 ssElts (SizedSeq n r_xs) = reverse r_xs
199 sizeSS :: SizedSeq a -> Int
200 sizeSS (SizedSeq n r_xs) = n
202 -- Bring in all the bci_ bytecode constants.
203 #include "Bytecodes.h"
205 -- This is where all the action is (pass 2 of the assembler)
206 mkBits :: (Int -> Int) -- label finder
208 -> [BCInstr] -- instructions (in)
211 mkBits findLabel st proto_insns
212 = foldM doInstr st proto_insns
214 doInstr :: AsmState -> BCInstr -> IO AsmState
217 STKCHECK n -> instr2 st bci_STKCHECK n
218 PUSH_L o1 -> instr2 st bci_PUSH_L o1
219 PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2
220 PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
221 PUSH_G nm -> do (p, st2) <- ptr st (BCOPtrName nm)
222 instr2 st2 bci_PUSH_G p
223 PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
224 instr2 st2 bci_PUSH_G p
225 PUSH_BCO proto -> do ul_bco <- assembleBCO proto
226 (p, st2) <- ptr st (BCOPtrBCO ul_bco)
227 instr2 st2 bci_PUSH_G p
228 PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
229 (p, st2) <- ptr st (BCOPtrBCO ul_bco)
230 instr2 st2 bci_PUSH_ALTS p
231 PUSH_ALTS_UNLIFTED proto pk -> do
232 ul_bco <- assembleBCO proto
233 (p, st2) <- ptr st (BCOPtrBCO ul_bco)
234 instr2 st2 (push_alts pk) p
235 PUSH_UBX (Left lit) nws
236 -> do (np, st2) <- literal st lit
237 instr3 st2 bci_PUSH_UBX np nws
238 PUSH_UBX (Right aa) nws
239 -> do (np, st2) <- addr st aa
240 instr3 st2 bci_PUSH_UBX np nws
242 PUSH_APPLY_N -> do instr1 st bci_PUSH_APPLY_N
243 PUSH_APPLY_V -> do instr1 st bci_PUSH_APPLY_V
244 PUSH_APPLY_F -> do instr1 st bci_PUSH_APPLY_F
245 PUSH_APPLY_D -> do instr1 st bci_PUSH_APPLY_D
246 PUSH_APPLY_L -> do instr1 st bci_PUSH_APPLY_L
247 PUSH_APPLY_P -> do instr1 st bci_PUSH_APPLY_P
248 PUSH_APPLY_PP -> do instr1 st bci_PUSH_APPLY_PP
249 PUSH_APPLY_PPP -> do instr1 st bci_PUSH_APPLY_PPP
250 PUSH_APPLY_PPPP -> do instr1 st bci_PUSH_APPLY_PPPP
251 PUSH_APPLY_PPPPP -> do instr1 st bci_PUSH_APPLY_PPPPP
252 PUSH_APPLY_PPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPP
253 PUSH_APPLY_PPPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPPP
255 SLIDE n by -> instr3 st bci_SLIDE n by
256 ALLOC_AP n -> instr2 st bci_ALLOC_AP n
257 ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n
258 MKAP off sz -> instr3 st bci_MKAP off sz
259 UNPACK n -> instr2 st bci_UNPACK n
260 PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
261 instr3 st2 bci_PACK itbl_no sz
262 LABEL lab -> return st
263 TESTLT_I i l -> do (np, st2) <- int st i
264 instr3 st2 bci_TESTLT_I np (findLabel l)
265 TESTEQ_I i l -> do (np, st2) <- int st i
266 instr3 st2 bci_TESTEQ_I np (findLabel l)
267 TESTLT_F f l -> do (np, st2) <- float st f
268 instr3 st2 bci_TESTLT_F np (findLabel l)
269 TESTEQ_F f l -> do (np, st2) <- float st f
270 instr3 st2 bci_TESTEQ_F np (findLabel l)
271 TESTLT_D d l -> do (np, st2) <- double st d
272 instr3 st2 bci_TESTLT_D np (findLabel l)
273 TESTEQ_D d l -> do (np, st2) <- double st d
274 instr3 st2 bci_TESTEQ_D np (findLabel l)
275 TESTLT_P i l -> instr3 st bci_TESTLT_P i (findLabel l)
276 TESTEQ_P i l -> instr3 st bci_TESTEQ_P i (findLabel l)
277 CASEFAIL -> instr1 st bci_CASEFAIL
278 SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n
279 JMP l -> instr2 st bci_JMP (findLabel l)
280 ENTER -> instr1 st bci_ENTER
281 RETURN -> instr1 st bci_RETURN
282 RETURN_UBX rep -> instr1 st (return_ubx rep)
283 CCALL off m_addr -> do (np, st2) <- addr st m_addr
284 instr3 st2 bci_CCALL off np
289 instr1 (st_i0,st_l0,st_p0,st_I0) i1
290 = do st_i1 <- addToSS st_i0 i1
291 return (st_i1,st_l0,st_p0,st_I0)
293 instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
294 = do st_i1 <- addToSS st_i0 (i2s i1)
295 st_i2 <- addToSS st_i1 (i2s i2)
296 return (st_i2,st_l0,st_p0,st_I0)
298 instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
299 = do st_i1 <- addToSS st_i0 (i2s i1)
300 st_i2 <- addToSS st_i1 (i2s i2)
301 st_i3 <- addToSS st_i2 (i2s i3)
302 return (st_i3,st_l0,st_p0,st_I0)
304 instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
305 = do st_i1 <- addToSS st_i0 (i2s i1)
306 st_i2 <- addToSS st_i1 (i2s i2)
307 st_i3 <- addToSS st_i2 (i2s i3)
308 st_i4 <- addToSS st_i3 (i2s i4)
309 return (st_i4,st_l0,st_p0,st_I0)
311 float (st_i0,st_l0,st_p0,st_I0) f
312 = do let ws = mkLitF f
313 st_l1 <- addListToSS st_l0 (map Left ws)
314 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
316 double (st_i0,st_l0,st_p0,st_I0) d
317 = do let ws = mkLitD d
318 st_l1 <- addListToSS st_l0 (map Left ws)
319 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
321 int (st_i0,st_l0,st_p0,st_I0) i
322 = do let ws = mkLitI i
323 st_l1 <- addListToSS st_l0 (map Left ws)
324 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
326 int64 (st_i0,st_l0,st_p0,st_I0) i
327 = do let ws = mkLitI64 i
328 st_l1 <- addListToSS st_l0 (map Left ws)
329 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
331 addr (st_i0,st_l0,st_p0,st_I0) a
332 = do let ws = mkLitPtr a
333 st_l1 <- addListToSS st_l0 (map Left ws)
334 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
336 litlabel (st_i0,st_l0,st_p0,st_I0) fs
337 = do st_l1 <- addListToSS st_l0 [Right fs]
338 return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
340 ptr (st_i0,st_l0,st_p0,st_I0) p
341 = do st_p1 <- addToSS st_p0 p
342 return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
344 itbl (st_i0,st_l0,st_p0,st_I0) dcon
345 = do st_I1 <- addToSS st_I0 (getName dcon)
346 return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
348 literal st (MachLabel fs _) = litlabel st fs
349 literal st (MachWord w) = int st (fromIntegral w)
350 literal st (MachInt j) = int st (fromIntegral j)
351 literal st (MachFloat r) = float st (fromRational r)
352 literal st (MachDouble r) = double st (fromRational r)
353 literal st (MachChar c) = int st (ord c)
354 literal st (MachInt64 ii) = int64 st (fromIntegral ii)
355 literal st (MachWord64 ii) = int64 st (fromIntegral ii)
356 literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
359 push_alts WordRep = bci_PUSH_ALTS_N
360 push_alts IntRep = bci_PUSH_ALTS_N
361 push_alts AddrRep = bci_PUSH_ALTS_N
362 push_alts CharRep = bci_PUSH_ALTS_N
363 push_alts FloatRep = bci_PUSH_ALTS_F
364 push_alts DoubleRep = bci_PUSH_ALTS_D
365 push_alts VoidRep = bci_PUSH_ALTS_V
367 | is64BitRep pk = bci_PUSH_ALTS_L
368 | isFollowableRep pk = bci_PUSH_ALTS_P
370 return_ubx WordRep = bci_RETURN_N
371 return_ubx IntRep = bci_RETURN_N
372 return_ubx AddrRep = bci_RETURN_N
373 return_ubx CharRep = bci_RETURN_N
374 return_ubx FloatRep = bci_RETURN_F
375 return_ubx DoubleRep = bci_RETURN_D
376 return_ubx VoidRep = bci_RETURN_V
378 | is64BitRep pk = bci_RETURN_L
379 | isFollowableRep pk = bci_RETURN_P
382 -- The size in 16-bit entities of an instruction.
383 instrSize16s :: BCInstr -> Int
394 PUSH_ALTS_UNLIFTED{} -> 2
403 PUSH_APPLY_PPP{} -> 1
404 PUSH_APPLY_PPPP{} -> 1
405 PUSH_APPLY_PPPPP{} -> 1
406 PUSH_APPLY_PPPPPP{} -> 1
407 PUSH_APPLY_PPPPPPP{} -> 1
431 -- Make lists of host-sized words for literals, so that when the
432 -- words are placed in memory at increasing addresses, the
433 -- bit pattern is correct for the host's word size and endianness.
434 mkLitI :: Int -> [Word]
435 mkLitF :: Float -> [Word]
436 mkLitD :: Double -> [Word]
437 mkLitPtr :: Ptr () -> [Word]
438 mkLitI64 :: Int64 -> [Word]
442 arr <- newArray_ ((0::Int),0)
444 f_arr <- castSTUArray arr
445 w0 <- readArray f_arr 0
452 arr <- newArray_ ((0::Int),1)
454 d_arr <- castSTUArray arr
455 w0 <- readArray d_arr 0
456 w1 <- readArray d_arr 1
457 return [w0 :: Word, w1]
461 arr <- newArray_ ((0::Int),0)
463 d_arr <- castSTUArray arr
464 w0 <- readArray d_arr 0
471 arr <- newArray_ ((0::Int),1)
473 d_arr <- castSTUArray arr
474 w0 <- readArray d_arr 0
475 w1 <- readArray d_arr 1
476 return [w0 :: Word,w1]
480 arr <- newArray_ ((0::Int),0)
482 d_arr <- castSTUArray arr
483 w0 <- readArray d_arr 0
489 arr <- newArray_ ((0::Int),0)
491 i_arr <- castSTUArray arr
492 w0 <- readArray i_arr 0
498 arr <- newArray_ ((0::Int),0)
500 a_arr <- castSTUArray arr
501 w0 <- readArray a_arr 0
505 iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)