e3935cf4464da66194d9f154049e90afafb21972
[ghc-hetmet.git] / ghc / compiler / compMan / CmLink.lhs
1 %
2 % (c) The University of Glasgow, 2000
3 %
4 \section[CmLink]{Linker for GHCI}
5
6 \begin{code}
7 module CmLink ( Linkable(..),  Unlinked(..),
8                 filterModuleLinkables, 
9                 findModuleLinkable_maybe,
10                 LinkResult(..),
11                 link, 
12                 unload,
13                 PersistentLinkerState{-abstractly!-}, emptyPLS,
14 #ifdef GHCI
15                 linkExpr
16 #endif
17   ) where
18
19
20 import Interpreter
21 import DriverPipeline
22 import CmTypes
23 import CmStaticInfo     ( GhciMode(..) )
24 import Outputable       ( SDoc )
25 import Digraph          ( SCC(..), flattenSCC )
26 import Module           ( ModuleName )
27 import FiniteMap
28 import Outputable
29 import ErrUtils         ( showPass )
30 import CmdLineOpts      ( DynFlags(..) )
31 import Panic            ( panic, GhcException(..) )
32
33 import Exception
34 import List
35 import Monad
36 import IO
37
38 #include "HsVersions.h"
39 \end{code}
40
41 \begin{code}
42 data PersistentLinkerState 
43    = PersistentLinkerState {
44
45
46 #ifdef GHCI
47         -- Current global mapping from RdrNames to closure addresses
48         closure_env :: ClosureEnv,
49
50         -- the current global mapping from RdrNames of DataCons to 
51         -- info table addresses.
52         -- When a new Unlinked is linked into the running image, or an existing
53         -- module in the image is replaced, the itbl_env must be updated
54         -- appropriately.
55         itbl_env    :: ItblEnv,
56
57         -- list of objects we've loaded (we'll need to unload them again
58         -- before re-loading the same module), together with the ClockTime
59         -- of the linkable they were loaded from.
60         objects_loaded :: [Linkable]
61
62         -- notionally here, but really lives in the C part of the linker:
63         --            object_symtab :: FiniteMap String Addr
64 #else
65         dummy :: ()     --  sigh, can't have an empty record
66 #endif
67
68      }
69
70 data LinkResult 
71    = LinkOK   PersistentLinkerState
72    | LinkErrs PersistentLinkerState [SDoc]
73
74 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
75 findModuleLinkable_maybe lis mod 
76    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
77         []   -> Nothing
78         [li] -> Just li
79         many -> pprPanic "findModuleLinkable" (ppr mod)
80
81
82 emptyPLS :: IO PersistentLinkerState
83 #ifdef GHCI
84 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, 
85                                            itbl_env    = emptyFM,
86                                            objects_loaded = [] })
87 #else
88 emptyPLS = return (PersistentLinkerState {})
89 #endif
90
91 -----------------------------------------------------------------------------
92 -- Unloading old objects ready for a new compilation sweep.
93 --
94 -- The compilation manager provides us with a list of linkables that it
95 -- considers "stable", i.e. won't be recompiled this time around.  For
96 -- each of the modules current linked in memory,
97 --
98 --      * if the linkable is stable (and it's the same one - the
99 --        user may have recompiled the module on the side), we keep it,
100 --
101 --      * otherwise, we unload it.
102 --
103
104 unload :: GhciMode
105        -> DynFlags
106        -> [Linkable]            -- stable linkables
107        -> PersistentLinkerState
108        -> IO PersistentLinkerState 
109
110 #ifdef GHCI
111 unload Batch       dflags linkables pls = return pls
112 unload Interactive dflags linkables pls
113   = do new_loaded <- filterM maybeUnload (objects_loaded pls)
114        let mods_retained = map linkableModName new_loaded
115            itbl_env'     = filterNameMap mods_retained (itbl_env pls)
116            closure_env'  = filterNameMap mods_retained (closure_env pls)
117
118        let verb = verbosity dflags
119        when (verb >= 3) $ do
120             hPutStrLn stderr (showSDoc 
121                 (text "CmLink.unload: retaining" <+> ppr mods_retained))
122
123        return pls{ objects_loaded = new_loaded,
124                    itbl_env = itbl_env',
125                    closure_env = closure_env' }
126   where
127         maybeUnload :: Linkable -> IO Bool
128         maybeUnload (LM time mod objs) = do
129           case findModuleLinkable_maybe linkables mod of
130                 Nothing -> do unloadObjs; return False
131                 Just l | linkableTime l /= time -> do unloadObjs; return False
132                        | otherwise              -> return True
133           where
134              unloadObjs = mapM unloadObj [ f | DotO f <- objs ]
135 #else
136 unload = panic "CmLink.unload: no interpreter"
137 #endif
138 -----------------------------------------------------------------------------
139 -- Linking
140
141 link :: GhciMode                -- interactive or batch
142      -> DynFlags                -- dynamic flags
143      -> Bool                    -- attempt linking in batch mode?
144      -> [Linkable]
145      -> PersistentLinkerState 
146      -> IO LinkResult
147
148 -- For the moment, in the batch linker, we don't bother to tell doLink
149 -- which packages to link -- it just tries all that are available.
150 -- batch_attempt_linking should only be *looked at* in batch mode.  It
151 -- should only be True if the upsweep was successful and someone
152 -- exports main, i.e., we have good reason to believe that linking
153 -- will succeed.
154
155 -- There will be (ToDo: are) two lists passed to link.  These
156 -- correspond to
157 --
158 --      1. The list of all linkables in the current home package.  This is
159 --         used by the batch linker to link the program, and by the interactive
160 --         linker to decide which modules from the previous link it can 
161 --         throw away.
162 --      2. The list of modules on which we just called "compile".  This list
163 --         is used by the interactive linker to decide which modules need
164 --         to be actually linked this time around (or unlinked and re-linked 
165 --         if the module was recompiled).
166
167 link mode dflags batch_attempt_linking linkables pls1
168    = do let verb = verbosity dflags
169         when (verb >= 3) $ do
170              hPutStrLn stderr "CmLink.link: linkables are ..."
171              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
172         res <- link' mode dflags batch_attempt_linking linkables pls1
173         when (verb >= 3) $ 
174              hPutStrLn stderr "CmLink.link: done"
175         return res
176
177 link' Batch dflags batch_attempt_linking linkables pls1
178    | batch_attempt_linking
179    = do let o_files = concatMap getOfiles linkables
180         when (verb >= 1) $
181              hPutStrLn stderr "ghc: linking ..."
182         -- don't showPass in Batch mode; doLink will do that for us.
183         doLink o_files
184         -- doLink only returns if it succeeds
185         return (LinkOK pls1)
186    | otherwise
187    = do when (verb >= 3) $ do
188             hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
189             hPutStrLn stderr "   Main.main not exported; not linking."
190         return (LinkOK pls1)
191    where
192       verb = verbosity dflags
193       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
194
195 link' Interactive dflags batch_attempt_linking linkables pls
196     = do showPass dflags "Linking"
197          let (objs, bcos) = partition (isObject.head.linkableUnlinked) linkables
198          linkObjs (objs ++ bcos) pls
199            -- get the objects first
200
201 ppLinkableSCC :: SCC Linkable -> SDoc
202 ppLinkableSCC = ppr . flattenSCC
203
204 filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
205 filterModuleLinkables p [] = []
206 filterModuleLinkables p (li:lis)
207    = case li of
208         LM _ modnm _ -> if p modnm then retain else dump
209      where
210         dump   = filterModuleLinkables p lis
211         retain = li : dump
212
213 -----------------------------------------------------------------------------
214 -- Linker for interactive mode
215
216 #ifndef GHCI
217 linkObjs      = panic "CmLink.linkObjs: no interpreter"
218 lookupClosure = panic "CmLink.lookupClosure: no interpreter"
219 #else
220 linkObjs [] pls = linkFinish pls []
221 linkObjs (l@(LM _ m uls) : ls) pls
222    | all isObject uls = do
223         if isLoaded l pls then linkObjs ls pls else do
224         let objs = [ file | DotO file <- uls ] 
225         mapM_ loadObj objs
226         linkObjs ls pls{objects_loaded = l : objects_loaded pls}
227    | all isInterpretable uls  = linkInterpretedCode (l:ls) [] pls
228    | otherwise                = invalidLinkable
229
230 isLoaded :: Linkable -> PersistentLinkerState -> Bool
231 isLoaded l pls = 
232   case findModuleLinkable_maybe (objects_loaded pls) (linkableModName l) of
233         Nothing -> False
234         Just m  -> linkableTime l == linkableTime m
235  
236 linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees
237 linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls
238    | all isInterpretable uls = 
239         if isLoaded l pls then linkInterpretedCode ls ul_trees pls else
240         linkInterpretedCode ls (uls++ul_trees) 
241                 pls{objects_loaded = l : objects_loaded pls}
242    | any isObject uls
243         = throwDyn (OtherError 
244              "can't link object code that depends on interpreted code")
245    | otherwise = invalidLinkable
246
247 invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code"
248
249
250 -- link all the interpreted code in one go.
251 linkFinish pls ul_bcos = do
252    resolveObjs
253
254    let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
255
256    (ibinds, new_itbl_env, new_closure_env) <-
257         linkIModules (itbl_env pls) (closure_env pls) stuff
258
259    let new_pls = pls { closure_env = new_closure_env,
260                        itbl_env    = new_itbl_env
261                      }
262    return (LinkOK new_pls)
263
264 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
265 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
266   = linkIExpr ie ce bcos
267 #endif
268 \end{code}