CmLink.lhs 10 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 2001
3
%
4
\section[CmLink]{The compilation manager's linker}
5
6

\begin{code}
7
8
9
10
11
12
13
14
module CmLink (
	LinkResult(..),	link, unload,

	filterModuleLinkables,
	findModuleLinkable_maybe,

        PersistentLinkerState{-abstractly!-}, emptyPLS,

15
#ifdef GHCI
16
17
18
	delListFromClosureEnv,
	addListToClosureEnv,
	linkExpr
19
#endif
20
  ) where
21

22

23
24
25
26
#ifdef GHCI
import ByteCodeLink	( linkIModules, linkIExpr )
#endif

27
import Interpreter
28
29
import DriverPipeline
import CmTypes
30
import HscTypes		( GhciMode(..) )
31
import Name		( Name )
32
import Module		( ModuleName )
33
34
import FiniteMap
import Outputable
35
36
import ErrUtils		( showPass )
import CmdLineOpts	( DynFlags(..) )
37
import Util
38

39
#ifdef GHCI
40
import Exception	( block )
41
42
#endif

43
import IOExts
44
import List
45
import Monad
46
47
import IO

48
49
#include "HsVersions.h"

50
51
52
53
54
-- ---------------------------------------------------------------------------
-- The Linker's state

-- The PersistentLinkerState maps Names to actual closures (for
-- interpreted code only), for use during linking.
55

56
57
data PersistentLinkerState
   = PersistentLinkerState {
58

59
#ifdef GHCI
60
	-- Current global mapping from RdrNames to closure addresses
61
        closure_env :: ClosureEnv,
62

63
	-- the current global mapping from RdrNames of DataCons to
64
65
66
67
	-- info table addresses.
	-- When a new Unlinked is linked into the running image, or an existing
	-- module in the image is replaced, the itbl_env must be updated
	-- appropriately.
68
69
        itbl_env    :: ItblEnv,

70
71
	-- the currently loaded interpreted modules
	bcos_loaded :: [Linkable]
72

73
74
75
76
#else
	dummy :: ()	--  sigh, can't have an empty record
#endif

77
78
     }

79
80
81
82
83
84
emptyPLS :: IO PersistentLinkerState
#ifdef GHCI
emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
                                           itbl_env    = emptyFM,
					   bcos_loaded = [] })
#else
sof's avatar
sof committed
85
emptyPLS = return (PersistentLinkerState {dummy=()})
86
87
88
89
90
91
92
93
94
95
96
97
98
99
#endif

-- We also keep track of which object modules are currently loaded
-- into the dynamic linker, so that we can unload them again later.
--
-- This state *must* match the actual state of the dyanmic linker at
-- all times, which is why we keep it private here and don't
-- put it in the PersistentLinkerState.
--
GLOBAL_VAR(v_ObjectsLoaded, [], [Linkable])


-- ---------------------------------------------------------------------------
-- Utils
100

101
findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
102
findModuleLinkable_maybe lis mod
103
   = case [LM time nm us | LM time nm us <- lis, nm == mod] of
104
105
106
        []   -> Nothing
        [li] -> Just li
        many -> pprPanic "findModuleLinkable" (ppr mod)
107

108
109
110
111
112
113
114
115
filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
filterModuleLinkables p [] = []
filterModuleLinkables p (li:lis)
   = case li of
        LM _ modnm _ -> if p modnm then retain else dump
     where
        dump   = filterModuleLinkables p lis
        retain = li : dump
116

117
118
119
120
121
linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
  case findModuleLinkable_maybe objs_loaded (linkableModName l) of
	Nothing -> False
	Just m  -> linkableTime l == linkableTime m
122

123
124
-- These two are used to add/remove entries from the closure env for
-- new bindings made at the prompt.
125
#ifdef GHCI
126
127
128
129
130
delListFromClosureEnv :: PersistentLinkerState -> [Name]
  	-> IO PersistentLinkerState
delListFromClosureEnv pls names
  = return pls{ closure_env = delListFromFM (closure_env pls) names }

131
addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
132
	-> IO PersistentLinkerState
133
addListToClosureEnv pls new_bindings
134
  = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
135
#endif
136

137
-- ---------------------------------------------------------------------------
138
139
140
141
142
143
144
145
146
147
148
-- Unloading old objects ready for a new compilation sweep.
--
-- The compilation manager provides us with a list of linkables that it
-- considers "stable", i.e. won't be recompiled this time around.  For
-- each of the modules current linked in memory,
--
--	* if the linkable is stable (and it's the same one - the
--	  user may have recompiled the module on the side), we keep it,
--
--	* otherwise, we unload it.
--
149
--      * we also implicitly unload all temporary bindings at this point.
150
151
152
153
154

unload :: GhciMode
       -> DynFlags
       -> [Linkable]		-- stable linkables
       -> PersistentLinkerState
155
       -> IO PersistentLinkerState
156

157
158
unload Batch dflags linkables pls = return pls

159
#ifdef GHCI
160
unload Interactive dflags linkables pls
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
  = block $ do -- block, so we're safe from Ctrl-C in here
	objs_loaded  <- readIORef v_ObjectsLoaded
	objs_loaded' <- filterM (maybeUnload objs_to_keep) objs_loaded
	writeIORef v_ObjectsLoaded objs_loaded'

        bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)

       	let objs_retained = map linkableModName objs_loaded'
	    bcos_retained = map linkableModName bcos_loaded'
	    itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
            closure_env'  = filterNameMap bcos_retained (closure_env pls)

       	let verb = verbosity dflags
       	when (verb >= 3) $ do
	    hPutStrLn stderr (showSDoc
		(text "CmLink.unload: retaining objs" <+> ppr objs_retained))
	    hPutStrLn stderr (showSDoc
		(text "CmLink.unload: retaining bcos" <+> ppr bcos_retained))

       	return pls{ itbl_env = itbl_env',
	            closure_env = closure_env',
		    bcos_loaded = bcos_loaded' }
183
  where
184
185
186
187
188
189
190
191
192
	(objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables

	maybeUnload :: [Linkable] -> Linkable -> IO Bool
	maybeUnload keep_linkables l@(LM time mod objs)
	   | linkableInSet l linkables
		= return True
	   | otherwise
		= do mapM unloadObj [ f | DotO f <- objs ]
		     return False
193
#else
194
unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
195
#endif
196

197
198
199
-----------------------------------------------------------------------------
-- Linking

200
data LinkResult
201
202
   = LinkOK     PersistentLinkerState
   | LinkFailed PersistentLinkerState
203

204
link :: GhciMode		-- interactive or batch
205
     -> DynFlags		-- dynamic flags
206
     -> Bool			-- attempt linking in batch mode?
207
     -> [Linkable]
208
     -> PersistentLinkerState
209
     -> IO LinkResult
210

211
212
213
214
215
216
217
218
219
220
221
222
-- For the moment, in the batch linker, we don't bother to tell doLink
-- which packages to link -- it just tries all that are available.
-- batch_attempt_linking should only be *looked at* in batch mode.  It
-- should only be True if the upsweep was successful and someone
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.

-- There will be (ToDo: are) two lists passed to link.  These
-- correspond to
--
--	1. The list of all linkables in the current home package.  This is
--	   used by the batch linker to link the program, and by the interactive
223
--	   linker to decide which modules from the previous link it can
224
225
226
--	   throw away.
--	2. The list of modules on which we just called "compile".  This list
--	   is used by the interactive linker to decide which modules need
227
--	   to be actually linked this time around (or unlinked and re-linked
228
229
--	   if the module was recompiled).

230
231
232
233
234
235
link mode dflags batch_attempt_linking linkables pls1
   = do let verb = verbosity dflags
        when (verb >= 3) $ do
	     hPutStrLn stderr "CmLink.link: linkables are ..."
             hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
	res <- link' mode dflags batch_attempt_linking linkables pls1
236
        when (verb >= 3) $
237
	     hPutStrLn stderr "CmLink.link: done"
238
239
	return res

240
link' Batch dflags batch_attempt_linking linkables pls1
241
242
   | batch_attempt_linking
   = do let o_files = concatMap getOfiles linkables
243
244
        when (verb >= 1) $
             hPutStrLn stderr "ghc: linking ..."
245
	-- don't showPass in Batch mode; doLink will do that for us.
246
        doLink o_files
247
	-- doLink only returns if it succeeds
248
        return (LinkOK pls1)
249
   | otherwise
250
251
252
   = do when (verb >= 3) $ do
	    hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
            hPutStrLn stderr "   Main.main not exported; not linking."
253
254
        return (LinkOK pls1)
   where
255
      verb = verbosity dflags
256
      getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
257

258
#ifdef GHCI
259
link' Interactive dflags batch_attempt_linking linkables pls
260
    = do showPass dflags "Linking"
261
	 block $ do -- don't want to be interrupted by ^C in here
262

263
264
265
	    -- Always load objects first.  Objects aren't allowed to
	    -- depend on BCOs.
	    let (objs, bcos) = partition isObjectLinkable linkables
266

267
268
269
	    objs_loaded  <- readIORef v_ObjectsLoaded
	    objs_loaded' <- linkObjs objs objs_loaded
	    writeIORef v_ObjectsLoaded objs_loaded'
270

271
	    -- resolve symbols within the object files
272
273
274
275
276
277
278
	    ok <- resolveObjs
	    -- if resolving failed, unload all our object modules and
	    -- carry on.
	    if (not ok)
               then do pls <- unload Interactive dflags [] pls
		       return (LinkFailed pls)
	       else do
279
280
281
282

	    -- finally link the interpreted linkables
	    linkBCOs bcos [] pls
#endif
283

284
285
-----------------------------------------------------------------------------
-- Linker for interactive mode
286

287
288
289
290
291
292
293
294
295
296
297
298
299
#ifdef GHCI
linkObjs [] objs_loaded = return objs_loaded
linkObjs (l@(LM _ m uls) : ls) objs_loaded
   | linkableInSet l objs_loaded  = linkObjs ls objs_loaded -- already loaded
   | otherwise = do mapM_ loadObj [ file | DotO file <- uls ]
	  	    linkObjs ls (l:objs_loaded)

linkBCOs [] ul_trees pls = linkFinish pls ul_trees
linkBCOs (l@(LM _ m uls) : ls) ul_trees pls
   | linkableInSet l (bcos_loaded pls)
	= linkBCOs ls ul_trees pls
   | otherwise
	= linkBCOs ls (uls++ul_trees) pls{bcos_loaded = l : bcos_loaded pls}
300

301
302
303
304
-- link all the interpreted code in one go.
linkFinish pls ul_bcos = do

   let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
305
306

   (ibinds, new_itbl_env, new_closure_env) <-
307
	linkIModules (itbl_env pls) (closure_env pls) stuff
308

309
310
311
   let new_pls = pls { closure_env = new_closure_env,
		       itbl_env    = new_itbl_env
		     }
312
   return (LinkOK new_pls)
313
#endif
314

315
316
317
318
-- ---------------------------------------------------------------------------
-- Link a single expression

#ifdef GHCI
319
320
321
linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
  = linkIExpr ie ce bcos
322
#endif
323
\end{code}