Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
[ghc.git] / compiler / ghci / ByteCodeLink.lhs
1 %
2 % (c) The University of Glasgow 2000-2006
3 %
4 ByteCodeLink: Bytecode assembler and linker
5
6 \begin{code}
7 {-# LANGUAGE BangPatterns #-}
8 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
9
10 module ByteCodeLink (
11         HValue,
12         ClosureEnv, emptyClosureEnv, extendClosureEnv,
13         linkBCO, lookupStaticPtr, lookupName
14        ,lookupIE
15   ) where
16
17 #include "HsVersions.h"
18
19 import ByteCodeItbls
20 import ByteCodeAsm
21 import ObjLink
22
23 import DynFlags
24 import Name
25 import NameEnv
26 import PrimOp
27 import Module
28 import FastString
29 import Panic
30 import Outputable
31 import Util
32
33 -- Standard libraries
34
35 import Data.Array.Base
36
37 import Control.Monad
38 import Control.Monad.ST ( stToIO )
39
40 import GHC.Arr          ( Array(..), STArray(..) )
41 import GHC.IO           ( IO(..) )
42 import GHC.Exts
43 import GHC.Ptr          ( castPtr )
44 \end{code}
45
46
47 %************************************************************************
48 %*                                                                      *
49 \subsection{Linking interpretables into something we can run}
50 %*                                                                      *
51 %************************************************************************
52
53 \begin{code}
54 type ClosureEnv = NameEnv (Name, HValue)
55 newtype HValue = HValue Any
56
57 emptyClosureEnv :: ClosureEnv
58 emptyClosureEnv = emptyNameEnv
59
60 extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
61 extendClosureEnv cl_env pairs
62   = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
63 \end{code}
64
65
66 %************************************************************************
67 %*                                                                      *
68 \subsection{Linking interpretables into something we can run}
69 %*                                                                      *
70 %************************************************************************
71
72 \begin{code}
73 {-
74 data BCO# = BCO# ByteArray#             -- instrs   :: Array Word16#
75                  ByteArray#             -- literals :: Array Word32#
76                  PtrArray#              -- ptrs     :: Array HValue
77                  ByteArray#             -- itbls    :: Array Addr#
78 -}
79
80 linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
81 linkBCO dflags ie ce ul_bco
82    = do BCO bco# <- linkBCO' dflags ie ce ul_bco
83         -- SDM: Why do we need mkApUpd0 here?  I *think* it's because
84         -- otherwise top-level interpreted CAFs don't get updated
85         -- after evaluation.   A top-level BCO will evaluate itself and
86         -- return its value when entered, but it won't update itself.
87         -- Wrapping the BCO in an AP_UPD thunk will take care of the
88         -- update for us.
89         --
90         -- Update: the above is true, but now we also have extra invariants:
91         --   (a) An AP thunk *must* point directly to a BCO
92         --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
93         --   (c) An AP is always fully saturated, so we *can't* wrap
94         --       non-zero arity BCOs in an AP thunk.
95         --
96         if (unlinkedBCOArity ul_bco > 0)
97            then return (HValue (unsafeCoerce# bco#))
98            else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) }
99
100
101 linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
102 linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS)
103    -- Raises an IO exception on failure
104    = do let literals = ssElts literalsSS
105             ptrs     = ssElts ptrsSS
106
107         linked_literals <- mapM (lookupLiteral dflags ie) literals
108
109         let n_literals = sizeSS literalsSS
110             n_ptrs     = sizeSS ptrsSS
111
112         ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs
113
114         let
115             !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
116
117             litRange
118              | n_literals > 0     = (0, fromIntegral n_literals - 1)
119              | otherwise          = (1, 0)
120             literals_arr :: UArray Word Word
121             literals_arr = listArray litRange linked_literals
122             !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
123
124             !(I# arity#)  = arity
125
126         newBCO insns_barr literals_barr ptrs_parr arity# bitmap
127
128
129 -- we recursively link any sub-BCOs while making the ptrs array
130 mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue)
131 mkPtrsArray dflags ie ce n_ptrs ptrs = do
132   let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0)
133   marr <- newArray_ ptrRange
134   let
135     fill (BCOPtrName n)     i = do
136         ptr <- lookupName ce n
137         unsafeWrite marr i ptr
138     fill (BCOPtrPrimOp op)  i = do
139         ptr <- lookupPrimOp op
140         unsafeWrite marr i ptr
141     fill (BCOPtrBCO ul_bco) i = do
142         BCO bco# <- linkBCO' dflags ie ce ul_bco
143         writeArrayBCO marr i bco#
144     fill (BCOPtrBreakInfo brkInfo) i =
145         unsafeWrite marr i (HValue (unsafeCoerce# brkInfo))
146     fill (BCOPtrArray brkArray) i =
147         unsafeWrite marr i (HValue (unsafeCoerce# brkArray))
148   zipWithM_ fill ptrs [0..]
149   unsafeFreeze marr
150
151 newtype IOArray i e = IOArray (STArray RealWorld i e)
152
153 instance MArray IOArray e IO where
154     getBounds (IOArray marr) = stToIO $ getBounds marr
155     getNumElements (IOArray marr) = stToIO $ getNumElements marr
156     newArray lu init = stToIO $ do
157         marr <- newArray lu init; return (IOArray marr)
158     newArray_ lu = stToIO $ do
159         marr <- newArray_ lu; return (IOArray marr)
160     unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
161     unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
162
163 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
164 writeArrayBCO :: IOArray Word a -> Int -> BCO# -> IO ()
165 writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
166   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
167   (# s#, () #) }
168
169 {-
170 writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
171 writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
172   case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
173   (# s#, () #) }
174 -}
175
176 data BCO = BCO BCO#
177
178 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
179 newBCO instrs lits ptrs arity bitmap
180    = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
181                   (# s1, bco #) -> (# s1, BCO bco #)
182
183
184 lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word
185 lookupLiteral _      _  (BCONPtrWord lit) = return lit
186 lookupLiteral _      _  (BCONPtrLbl  sym) = do Ptr a# <- lookupStaticPtr sym
187                                                return (W# (int2Word# (addr2Int# a#)))
188 lookupLiteral dflags ie (BCONPtrItbl nm)  = do Ptr a# <- lookupIE dflags ie nm
189                                                return (W# (int2Word# (addr2Int# a#)))
190
191 lookupStaticPtr :: FastString -> IO (Ptr ())
192 lookupStaticPtr addr_of_label_string
193    = do let label_to_find = unpackFS addr_of_label_string
194         m <- lookupSymbol label_to_find
195         case m of
196            Just ptr -> return ptr
197            Nothing  -> linkFail "ByteCodeLink: can't find label"
198                                 label_to_find
199
200 lookupPrimOp :: PrimOp -> IO HValue
201 lookupPrimOp primop
202    = do let sym_to_find = primopToCLabel primop "closure"
203         m <- lookupSymbol sym_to_find
204         case m of
205            Just (Ptr addr) -> case addrToAny# addr of
206                                  (# a #) -> return (HValue a)
207            Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
208
209 lookupName :: ClosureEnv -> Name -> IO HValue
210 lookupName ce nm
211    = case lookupNameEnv ce nm of
212         Just (_,aa) -> return aa
213         Nothing
214            -> ASSERT2(isExternalName nm, ppr nm)
215               do let sym_to_find = nameToCLabel nm "closure"
216                  m <- lookupSymbol sym_to_find
217                  case m of
218                     Just (Ptr addr) -> case addrToAny# addr of
219                                           (# a #) -> return (HValue a)
220                     Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
221
222 lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a)
223 lookupIE dflags ie con_nm
224    = case lookupNameEnv ie con_nm of
225         Just (_, a) -> return (castPtr (itblCode dflags a))
226         Nothing
227            -> do -- try looking up in the object files.
228                  let sym_to_find1 = nameToCLabel con_nm "con_info"
229                  m <- lookupSymbol sym_to_find1
230                  case m of
231                     Just addr -> return addr
232                     Nothing
233                        -> do -- perhaps a nullary constructor?
234                              let sym_to_find2 = nameToCLabel con_nm "static_info"
235                              n <- lookupSymbol sym_to_find2
236                              case n of
237                                 Just addr -> return addr
238                                 Nothing   -> linkFail "ByteCodeLink.lookupIE"
239                                                 (sym_to_find1 ++ " or " ++ sym_to_find2)
240
241 linkFail :: String -> String -> IO a
242 linkFail who what
243    = ghcError (ProgramError $
244         unlines [ "",who
245                 , "During interactive linking, GHCi couldn't find the following symbol:"
246                 , ' ' : ' ' : what
247                 , "This may be due to you not asking GHCi to load extra object files,"
248                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
249                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
250                 , "flags, or simply by naming the relevant files on the GHCi command line."
251                 , "Alternatively, this link failure might indicate a bug in GHCi."
252                 , "If you suspect the latter, please send a bug report to:"
253                 , "  glasgow-haskell-bugs@haskell.org"
254                 ])
255
256 -- HACKS!!!  ToDo: cleaner
257 nameToCLabel :: Name -> String{-suffix-} -> String
258 nameToCLabel n suffix
259    = if pkgid /= mainPackageId
260         then package_part ++ '_': qual_name
261         else qual_name
262   where
263         pkgid = modulePackageId mod
264         mod = ASSERT( isExternalName n ) nameModule n
265         package_part = zString (zEncodeFS (packageIdFS (modulePackageId mod)))
266         module_part  = zString (zEncodeFS (moduleNameFS (moduleName mod)))
267         occ_part     = zString (zEncodeFS (occNameFS (nameOccName n)))
268         qual_name = module_part ++ '_':occ_part ++ '_':suffix
269
270
271 primopToCLabel :: PrimOp -> String{-suffix-} -> String
272 primopToCLabel primop suffix
273    = let str = "ghczmprim_GHCziPrimopWrappers_" ++ zString (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
274      in --trace ("primopToCLabel: " ++ str)
275         str
276 \end{code}
277