2 % (c) The University of Glasgow, 2000
4 \section[CmLink]{Linker for GHCI}
7 module CmLink ( Linkable(..), Unlinked(..),
9 findModuleLinkable_maybe,
13 PersistentLinkerState{-abstractly!-}, emptyPLS,
15 delListFromClosureEnv,
23 import ByteCodeLink ( linkIModules, linkIExpr )
29 import HscTypes ( GhciMode(..) )
30 import Outputable ( SDoc )
31 import Digraph ( SCC(..), flattenSCC )
33 import Module ( ModuleName )
36 import ErrUtils ( showPass )
37 import CmdLineOpts ( DynFlags(..) )
38 import Panic ( panic )
44 #include "HsVersions.h"
48 data PersistentLinkerState
49 = PersistentLinkerState {
53 -- Current global mapping from RdrNames to closure addresses
54 closure_env :: ClosureEnv,
56 -- the current global mapping from RdrNames of DataCons to
57 -- info table addresses.
58 -- When a new Unlinked is linked into the running image, or an existing
59 -- module in the image is replaced, the itbl_env must be updated
63 -- list of objects we've loaded (we'll need to unload them again
64 -- before re-loading the same module), together with the ClockTime
65 -- of the linkable they were loaded from.
66 objects_loaded :: [Linkable]
68 -- notionally here, but really lives in the C part of the linker:
69 -- object_symtab :: FiniteMap String Addr
71 dummy :: () -- sigh, can't have an empty record
77 = LinkOK PersistentLinkerState
78 | LinkErrs PersistentLinkerState [SDoc]
80 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
81 findModuleLinkable_maybe lis mod
82 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
85 many -> pprPanic "findModuleLinkable" (ppr mod)
88 emptyPLS :: IO PersistentLinkerState
90 emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
92 objects_loaded = [] })
94 emptyPLS = return (PersistentLinkerState {})
98 delListFromClosureEnv :: PersistentLinkerState -> [Name]
99 -> IO PersistentLinkerState
100 delListFromClosureEnv pls names
101 = return pls{ closure_env = delListFromFM (closure_env pls) names }
103 addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
104 -> IO PersistentLinkerState
105 addListToClosureEnv pls new_bindings
106 = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
109 -----------------------------------------------------------------------------
110 -- Unloading old objects ready for a new compilation sweep.
112 -- The compilation manager provides us with a list of linkables that it
113 -- considers "stable", i.e. won't be recompiled this time around. For
114 -- each of the modules current linked in memory,
116 -- * if the linkable is stable (and it's the same one - the
117 -- user may have recompiled the module on the side), we keep it,
119 -- * otherwise, we unload it.
121 -- * we also implicitly unload all temporary bindings at this point.
125 -> [Linkable] -- stable linkables
126 -> PersistentLinkerState
127 -> IO PersistentLinkerState
129 unload Batch dflags linkables pls = return pls
132 unload Interactive dflags linkables pls
133 = do new_loaded <- filterM maybeUnload (objects_loaded pls)
134 let mods_retained = map linkableModName new_loaded
135 itbl_env' = filterNameMap mods_retained (itbl_env pls)
136 closure_env' = filterNameMap mods_retained (closure_env pls)
138 let verb = verbosity dflags
139 when (verb >= 3) $ do
140 hPutStrLn stderr (showSDoc
141 (text "CmLink.unload: retaining" <+> ppr mods_retained))
143 return pls{ objects_loaded = new_loaded,
144 itbl_env = itbl_env',
145 closure_env = closure_env' }
147 maybeUnload :: Linkable -> IO Bool
148 maybeUnload (LM time mod objs) = do
149 case findModuleLinkable_maybe linkables mod of
150 Nothing -> do unloadObjs; return False
151 Just l | linkableTime l /= time -> do unloadObjs; return False
152 | otherwise -> return True
154 unloadObjs = mapM unloadObj [ f | DotO f <- objs ]
156 unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
158 -----------------------------------------------------------------------------
161 link :: GhciMode -- interactive or batch
162 -> DynFlags -- dynamic flags
163 -> Bool -- attempt linking in batch mode?
165 -> PersistentLinkerState
168 -- For the moment, in the batch linker, we don't bother to tell doLink
169 -- which packages to link -- it just tries all that are available.
170 -- batch_attempt_linking should only be *looked at* in batch mode. It
171 -- should only be True if the upsweep was successful and someone
172 -- exports main, i.e., we have good reason to believe that linking
175 -- There will be (ToDo: are) two lists passed to link. These
178 -- 1. The list of all linkables in the current home package. This is
179 -- used by the batch linker to link the program, and by the interactive
180 -- linker to decide which modules from the previous link it can
182 -- 2. The list of modules on which we just called "compile". This list
183 -- is used by the interactive linker to decide which modules need
184 -- to be actually linked this time around (or unlinked and re-linked
185 -- if the module was recompiled).
187 link mode dflags batch_attempt_linking linkables pls1
188 = do let verb = verbosity dflags
189 when (verb >= 3) $ do
190 hPutStrLn stderr "CmLink.link: linkables are ..."
191 hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
192 res <- link' mode dflags batch_attempt_linking linkables pls1
194 hPutStrLn stderr "CmLink.link: done"
197 link' Batch dflags batch_attempt_linking linkables pls1
198 | batch_attempt_linking
199 = do let o_files = concatMap getOfiles linkables
201 hPutStrLn stderr "ghc: linking ..."
202 -- don't showPass in Batch mode; doLink will do that for us.
204 -- doLink only returns if it succeeds
207 = do when (verb >= 3) $ do
208 hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
209 hPutStrLn stderr " Main.main not exported; not linking."
212 verb = verbosity dflags
213 getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
215 link' Interactive dflags batch_attempt_linking linkables pls
216 = do showPass dflags "Linking"
217 let (objs, bcos) = partition (isObject.head.linkableUnlinked) linkables
218 linkObjs (objs ++ bcos) pls
219 -- get the objects first
221 filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
222 filterModuleLinkables p [] = []
223 filterModuleLinkables p (li:lis)
225 LM _ modnm _ -> if p modnm then retain else dump
227 dump = filterModuleLinkables p lis
230 -----------------------------------------------------------------------------
231 -- Linker for interactive mode
234 linkObjs = panic "CmLink.linkObjs: no interpreter"
236 linkObjs [] pls = linkFinish pls []
237 linkObjs (l@(LM _ m uls) : ls) pls
238 | all isObject uls = do
239 if isLoaded l pls then linkObjs ls pls else do
240 let objs = [ file | DotO file <- uls ]
242 linkObjs ls pls{objects_loaded = l : objects_loaded pls}
243 | all isInterpretable uls = linkInterpretedCode (l:ls) [] pls
244 | otherwise = invalidLinkable
246 isLoaded :: Linkable -> PersistentLinkerState -> Bool
248 case findModuleLinkable_maybe (objects_loaded pls) (linkableModName l) of
250 Just m -> linkableTime l == linkableTime m
252 linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees
253 linkInterpretedCode (l@(LM _ m uls) : ls) ul_trees pls
254 | all isInterpretable uls =
255 if isLoaded l pls then linkInterpretedCode ls ul_trees pls else
256 linkInterpretedCode ls (uls++ul_trees)
257 pls{objects_loaded = l : objects_loaded pls}
259 = panic "linkInterpretedCode: trying to link object code to interpreted code"
260 | otherwise = invalidLinkable
262 invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code"
265 -- link all the interpreted code in one go.
266 linkFinish pls ul_bcos = do
269 let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
271 (ibinds, new_itbl_env, new_closure_env) <-
272 linkIModules (itbl_env pls) (closure_env pls) stuff
274 let new_pls = pls { closure_env = new_closure_env,
275 itbl_env = new_itbl_env
277 return (LinkOK new_pls)
279 linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
280 linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
281 = linkIExpr ie ce bcos