2 % (c) The University of Glasgow, 2001
4 \section[CmLink]{The compilation manager's linker}
8 LinkResult(..), link, unload,
10 filterModuleLinkables,
11 findModuleLinkable_maybe,
13 PersistentLinkerState{-abstractly!-}, emptyPLS,
16 delListFromClosureEnv,
23 #include "HsVersions.h"
26 import ByteCodeLink ( linkIModules, linkIExpr )
30 import ErrUtils ( showPass )
31 import DATA_IOREF ( readIORef, writeIORef )
36 import HscTypes ( GhciMode(..) )
37 import Module ( ModuleName )
39 import CmdLineOpts ( DynFlags(..) )
43 import Control.Exception ( block )
46 import DATA_IOREF ( IORef )
52 -- ---------------------------------------------------------------------------
55 -- The PersistentLinkerState maps Names to actual closures (for
56 -- interpreted code only), for use during linking.
58 data PersistentLinkerState
59 = PersistentLinkerState {
62 -- Current global mapping from RdrNames to closure addresses
63 closure_env :: ClosureEnv,
65 -- the current global mapping from RdrNames of DataCons to
66 -- info table addresses.
67 -- When a new Unlinked is linked into the running image, or an existing
68 -- module in the image is replaced, the itbl_env must be updated
72 -- the currently loaded interpreted modules
73 bcos_loaded :: [Linkable]
76 dummy :: () -- sigh, can't have an empty record
81 emptyPLS :: IO PersistentLinkerState
83 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
87 emptyPLS = return (PersistentLinkerState {dummy=()})
90 -- We also keep track of which object modules are currently loaded
91 -- into the dynamic linker, so that we can unload them again later.
93 -- This state *must* match the actual state of the dyanmic linker at
94 -- all times, which is why we keep it private here and don't
95 -- put it in the PersistentLinkerState.
97 GLOBAL_VAR(v_ObjectsLoaded, [], [Linkable])
100 -- ---------------------------------------------------------------------------
103 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
104 findModuleLinkable_maybe lis mod
105 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
108 many -> pprPanic "findModuleLinkable" (ppr mod)
110 filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
111 filterModuleLinkables p [] = []
112 filterModuleLinkables p (li:lis)
114 LM _ modnm _ -> if p modnm then retain else dump
116 dump = filterModuleLinkables p lis
120 linkableInSet :: Linkable -> [Linkable] -> Bool
121 linkableInSet l objs_loaded =
122 case findModuleLinkable_maybe objs_loaded (linkableModName l) of
124 Just m -> linkableTime l == linkableTime m
126 -- These two are used to add/remove entries from the closure env for
127 -- new bindings made at the prompt.
128 delListFromClosureEnv :: PersistentLinkerState -> [Name]
129 -> IO PersistentLinkerState
130 delListFromClosureEnv pls names
131 = return pls{ closure_env = delListFromFM (closure_env pls) names }
133 addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
134 -> IO PersistentLinkerState
135 addListToClosureEnv pls new_bindings
136 = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
139 -- ---------------------------------------------------------------------------
140 -- Unloading old objects ready for a new compilation sweep.
142 -- The compilation manager provides us with a list of linkables that it
143 -- considers "stable", i.e. won't be recompiled this time around. For
144 -- each of the modules current linked in memory,
146 -- * if the linkable is stable (and it's the same one - the
147 -- user may have recompiled the module on the side), we keep it,
149 -- * otherwise, we unload it.
151 -- * we also implicitly unload all temporary bindings at this point.
155 -> [Linkable] -- stable linkables
156 -> PersistentLinkerState
157 -> IO PersistentLinkerState
159 unload Batch dflags linkables pls = return pls
162 unload Interactive dflags linkables pls
163 = block $ do -- block, so we're safe from Ctrl-C in here
164 objs_loaded <- readIORef v_ObjectsLoaded
165 objs_loaded' <- filterM (maybeUnload objs_to_keep) objs_loaded
166 writeIORef v_ObjectsLoaded objs_loaded'
168 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
170 let objs_retained = map linkableModName objs_loaded'
171 bcos_retained = map linkableModName bcos_loaded'
172 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
173 closure_env' = filterNameMap bcos_retained (closure_env pls)
175 let verb = verbosity dflags
176 when (verb >= 3) $ do
177 hPutStrLn stderr (showSDoc
178 (text "CmLink.unload: retaining objs" <+> ppr objs_retained))
179 hPutStrLn stderr (showSDoc
180 (text "CmLink.unload: retaining bcos" <+> ppr bcos_retained))
182 return pls{ itbl_env = itbl_env',
183 closure_env = closure_env',
184 bcos_loaded = bcos_loaded' }
186 (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
188 maybeUnload :: [Linkable] -> Linkable -> IO Bool
189 maybeUnload keep_linkables l@(LM time mod objs)
190 | linkableInSet l linkables
193 = do mapM_ unloadObj [ f | DotO f <- objs ]
196 unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
199 -----------------------------------------------------------------------------
203 = LinkOK PersistentLinkerState
204 | LinkFailed PersistentLinkerState
206 link :: GhciMode -- interactive or batch
207 -> DynFlags -- dynamic flags
208 -> Bool -- attempt linking in batch mode?
210 -> PersistentLinkerState
213 -- For the moment, in the batch linker, we don't bother to tell doLink
214 -- which packages to link -- it just tries all that are available.
215 -- batch_attempt_linking should only be *looked at* in batch mode. It
216 -- should only be True if the upsweep was successful and someone
217 -- exports main, i.e., we have good reason to believe that linking
220 -- There will be (ToDo: are) two lists passed to link. These
223 -- 1. The list of all linkables in the current home package. This is
224 -- used by the batch linker to link the program, and by the interactive
225 -- linker to decide which modules from the previous link it can
227 -- 2. The list of modules on which we just called "compile". This list
228 -- is used by the interactive linker to decide which modules need
229 -- to be actually linked this time around (or unlinked and re-linked
230 -- if the module was recompiled).
232 link mode dflags batch_attempt_linking linkables pls1
233 = do let verb = verbosity dflags
234 when (verb >= 3) $ do
235 hPutStrLn stderr "CmLink.link: linkables are ..."
236 hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
237 res <- link' mode dflags batch_attempt_linking linkables pls1
239 hPutStrLn stderr "CmLink.link: done"
242 link' Batch dflags batch_attempt_linking linkables pls1
243 | batch_attempt_linking
244 = do let o_files = concatMap getOfiles linkables
246 hPutStrLn stderr "ghc: linking ..."
247 -- don't showPass in Batch mode; doLink will do that for us.
249 -- doLink only returns if it succeeds
252 = do when (verb >= 3) $ do
253 hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
254 hPutStrLn stderr " Main.main not exported; not linking."
257 verb = verbosity dflags
258 getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
261 link' Interactive dflags batch_attempt_linking linkables pls
262 = do showPass dflags "Linking"
263 block $ do -- don't want to be interrupted by ^C in here
265 -- Always load objects first. Objects aren't allowed to
267 let (objs, bcos) = partition isObjectLinkable
268 (concatMap partitionLinkable linkables)
270 objs_loaded <- readIORef v_ObjectsLoaded
271 objs_loaded' <- linkObjs objs objs_loaded
272 writeIORef v_ObjectsLoaded objs_loaded'
274 -- resolve symbols within the object files
276 -- if resolving failed, unload all our object modules and
279 then do pls <- unload Interactive dflags [] pls
280 return (LinkFailed pls)
283 -- finally link the interpreted linkables
287 -----------------------------------------------------------------------------
288 -- Linker for interactive mode
291 linkObjs [] objs_loaded = return objs_loaded
292 linkObjs (l@(LM _ m uls) : ls) objs_loaded
293 | linkableInSet l objs_loaded = linkObjs ls objs_loaded -- already loaded
294 | otherwise = do mapM_ loadObj [ file | DotO file <- uls ]
295 linkObjs ls (l:objs_loaded)
297 linkBCOs [] ul_trees pls = linkFinish pls ul_trees
298 linkBCOs (l@(LM _ m uls) : ls) ul_trees pls
299 | linkableInSet l (bcos_loaded pls)
300 = linkBCOs ls ul_trees pls
302 = linkBCOs ls (uls++ul_trees) pls{bcos_loaded = l : bcos_loaded pls}
304 -- link all the interpreted code in one go.
305 linkFinish pls ul_bcos = do
307 let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
309 (ibinds, new_itbl_env, new_closure_env) <-
310 linkIModules (itbl_env pls) (closure_env pls) stuff
312 let new_pls = pls { closure_env = new_closure_env,
313 itbl_env = new_itbl_env
315 return (LinkOK new_pls)
318 -- ---------------------------------------------------------------------------
319 -- Link a single expression
322 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
323 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
324 = linkIExpr ie ce bcos