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