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