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