CompManager.lhs 39.1 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 2000
3
4
5
6
%
\section[CompManager]{The Compilation Manager}

\begin{code}
7
8
module CompManager ( 
    cmInit, 	  -- :: GhciMode -> IO CmState
9

10
    cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String])
11

12
    cmUnload,	  -- :: CmState -> DynFlags -> IO CmState
13

14
    cmSetContext, -- :: CmState -> String -> IO CmState
15

16
    cmGetContext, -- :: CmState -> IO String
17

18
#ifdef GHCI
19
    cmRunStmt,	  --  :: CmState -> DynFlags -> String -> IO (CmState, [Name])
20
21
22
23
24
25
26
27

    cmTypeOfExpr, --  :: CmState -> DynFlags -> String
		  --  -> IO (CmState, Maybe String)

    cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)

    cmCompileExpr,-- :: CmState -> DynFlags -> String 
		  -- -> IO (CmState, Maybe HValue)#endif
28
#endif
29
30
    CmState, emptyCmState  -- abstract
  )
31
32
33
34
where

#include "HsVersions.h"

35
import CmLink
36
import CmTypes
37
38
39
40
41
42
import DriverPipeline
import DriverFlags	( getDynFlags )
import DriverPhases
import DriverUtil
import Finder
import HscMain		( initPersistentCompilerState )
43
import HscTypes
44
45
import RnEnv		( unQualInScope )
import Id		( idType, idName )
46
import Name		( Name, NamedThing(..), nameRdrName )
47
import NameEnv
48
import RdrName		( lookupRdrEnv, emptyRdrEnv )
49
import Module
50
import GetImports
51
52
import Type		( tidyType )
import VarEnv		( emptyTidyEnv )
53
import UniqFM
54
import Unique		( Uniquable )
55
import Digraph		( SCC(..), stronglyConnComp, flattenSCC )
56
import ErrUtils		( showPass )
57
import SysTools		( cleanTempFilesExcept )
58
import Util
59
import Outputable
60
import Panic
61
import CmdLineOpts	( DynFlags(..) )
62
import IOExts
63

64
65
#ifdef GHCI
import Interpreter	( HValue )
66
import HscMain		( hscStmt )
67
68
69
import PrelGHC		( unsafeCoerce# )
#endif

70
-- lang
71
import Exception	( throwDyn )
72
73

-- std
74
import Directory        ( getModificationTime, doesFileExist )
75
import IO
76
import Monad
77
import List		( nub )
78
import Maybe
79
\end{code}
80

81

82
\begin{code}
83
84
-- Persistent state for the entire system
data CmState
85
   = CmState {
86
87
88
89
90
        hst   :: HomeSymbolTable,    -- home symbol table
        hit   :: HomeIfaceTable,     -- home interface table
        ui    :: UnlinkedImage,      -- the unlinked images
        mg    :: ModuleGraph,        -- the module graph
        gmode :: GhciMode,           -- NEVER CHANGES
91
	ic    :: InteractiveContext, -- command-line binding info
92

93
        pcs    :: PersistentCompilerState, -- compile's persistent state
94
        pls    :: PersistentLinkerState    -- link's persistent state
95
     }
96

97
98
emptyCmState :: GhciMode -> Module -> IO CmState
emptyCmState gmode mod
99
    = do pcs     <- initPersistentCompilerState
100
         pls     <- emptyPLS
101
102
103
104
105
106
         return (CmState { hst    = emptySymbolTable,
                           hit    = emptyIfaceTable,
                           ui     = emptyUI,
                           mg     = emptyMG, 
                           gmode  = gmode,
			   ic     = emptyInteractiveContext mod,
107
                           pcs    = pcs,
108
                           pls    = pls })
109

110
111
112
113
114
115
116
117
emptyInteractiveContext mod
  = InteractiveContext { ic_module = mod, 
			 ic_rn_env = emptyRdrEnv,
			 ic_type_env = emptyTypeEnv }

defaultCurrentModuleName = mkModuleName "Prelude"
GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)

118
-- CM internal types
119
120
type UnlinkedImage = [Linkable]	-- the unlinked images (should be a set, really)
emptyUI :: UnlinkedImage
121
122
emptyUI = []

123
type ModuleGraph = [ModSummary]  -- the module graph, topologically sorted
124
emptyMG :: ModuleGraph
125
emptyMG = []
126

127
128
129
130
131
132
133
134
-----------------------------------------------------------------------------
-- Produce an initial CmState.

cmInit :: GhciMode -> IO CmState
cmInit mode = do
   prel <- moduleNameToModule defaultCurrentModuleName
   writeIORef defaultCurrentModule prel
   emptyCmState mode prel
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
-----------------------------------------------------------------------------
-- Setting the context doesn't throw away any bindings; the bindings
-- we've built up in the InteractiveContext simply move to the new
-- module.  They always shadow anything in scope in the current context.

cmSetContext :: CmState -> String -> IO CmState
cmSetContext cmstate str
   = do let mn = mkModuleName str
	    modules_loaded = [ (name_of_summary s, ms_mod s)  | s <- mg cmstate ]

        m <- case lookup mn modules_loaded of
		Just m  -> return m
		Nothing -> do
		   mod <- moduleNameToModule mn
		   if isHomeModule mod 
151
			then throwDyn (CmdLineError (showSDoc 
152
153
154
155
156
157
158
159
160
161
162
163
164
				(quotes (ppr (moduleName mod))
 				  <+> text "is not currently loaded")))
		   	else return mod

	return cmstate{ ic = (ic cmstate){ic_module=m} }
		
cmGetContext :: CmState -> IO String
cmGetContext cmstate = return (moduleUserString (ic_module (ic cmstate)))

moduleNameToModule :: ModuleName -> IO Module
moduleNameToModule mn
 = do maybe_stuff <- findModule mn
      case maybe_stuff of
165
	Nothing -> throwDyn (CmdLineError ("can't find module `"
166
167
168
169
170
171
172
				    ++ moduleNameUserString mn ++ "'"))
	Just (m,_) -> return m

-----------------------------------------------------------------------------
-- cmRunStmt:  Run a statement/expr.

#ifdef GHCI
173
174
175
cmRunStmt :: CmState -> DynFlags -> String
	-> IO (CmState,			-- new state
	       [Name])			-- names bound by this evaluation
176
cmRunStmt cmstate dflags expr
177
   = do 
178
	let InteractiveContext { 
179
180
181
182
	       	ic_rn_env = rn_env, 
	       	ic_type_env = type_env,
	       	ic_module   = this_mod } = icontext

183
        (new_pcs, maybe_stuff) 
184
	    <- hscStmt dflags hst hit pcs icontext expr False{-stmt-}
185

186
187
        case maybe_stuff of
	   Nothing -> return (cmstate{ pcs=new_pcs }, [])
188
	   Just (ids, _, bcos) -> do
189
190

		-- update the interactive context
191
	        let 
192
		    names = map idName ids
193

194
195
196
197
198
199
200
201
202
203
		    -- these names have just been shadowed
		    shadowed = [ n | r <- map nameRdrName names,
				     Just n <- [lookupRdrEnv rn_env r] ]
		    
		    new_rn_env   = extendLocalRdrEnv rn_env names

		    -- remove any shadowed bindings from the type_env
		    filtered_type_env = delListFromNameEnv type_env shadowed

		    new_type_env = extendNameEnvList filtered_type_env 	
204
205
206
207
208
			      		[ (getName id, AnId id)	| id <- ids]

		    new_ic = icontext { ic_rn_env   = new_rn_env, 
			  	  	ic_type_env = new_type_env }

209
		-- link it
210
		hval <- linkExpr pls bcos
211
212
213
214
215

		-- run it!
		let thing_to_run = unsafeCoerce# hval :: IO [HValue]
		hvals <- thing_to_run

216
217
218
219
220
		-- Get the newly bound things, and bind them.  Don't forget
		-- to delete any shadowed bindings from the closure_env, lest
		-- we end up with a space leak.
		pls <- delListFromClosureEnv pls shadowed
		new_pls <- addListToClosureEnv pls (zip names hvals)
221

222
	        return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
223
   where
224
225
226
227
228
229
230
231
232
       CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
#endif

-----------------------------------------------------------------------------
-- cmTypeOfExpr: returns a string representing the type of an expression

#ifdef GHCI
cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String)
cmTypeOfExpr cmstate dflags expr
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
   = do (new_pcs, maybe_stuff) 
	  <- hscStmt dflags hst hit pcs ic expr True{-just an expr-}

	let new_cmstate = cmstate{pcs = new_pcs}

	case maybe_stuff of
	   Nothing -> return (new_cmstate, Nothing)
	   Just (_, ty, _) ->
	     let pit = pcs_PIT pcs
	         modname = moduleName (ic_module ic)
	         tidy_ty = tidyType emptyTidyEnv ty
	         str = case lookupIfaceByModName hit pit modname of
			  Nothing    -> showSDoc (ppr tidy_ty)
			  Just iface -> showSDocForUser unqual (ppr tidy_ty)
		  	     where unqual = unQualInScope (mi_globals iface)
	     in return (new_cmstate, Just str)
   where
       CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate
251
252
253
#endif

-----------------------------------------------------------------------------
254
-- cmTypeOfName: returns a string representing the type of a name.
255

256
#ifdef GHCI
257
258
259
260
261
262
263
cmTypeOfName :: CmState -> Name -> IO (Maybe String)
cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
 = case lookupNameEnv (ic_type_env ic) name of
	Nothing -> return Nothing
	Just (AnId id) -> 
	   let pit = pcs_PIT pcs
	       modname = moduleName (ic_module ic)
264
	       ty = tidyType emptyTidyEnv (idType id)
265
	       str = case lookupIfaceByModName hit pit modname of
266
267
			Nothing    -> showSDoc (ppr ty)
			Just iface -> showSDocForUser unqual (ppr ty)
268
269
270
271
		  	   where unqual = unQualInScope (mi_globals iface)
	   in return (Just str)

	_ -> panic "cmTypeOfName"
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
#endif

-----------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue

#ifdef GHCI
cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue)
cmCompileExpr cmstate dflags expr
   = do 
	let InteractiveContext { 
	       	ic_rn_env = rn_env, 
	       	ic_type_env = type_env,
	       	ic_module   = this_mod } = icontext

        (new_pcs, maybe_stuff) 
	    <- hscStmt dflags hst hit pcs icontext 
288
		  ("let __cmCompileExpr = "++expr) False{-stmt-}
289
290
291

        case maybe_stuff of
	   Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
292
	   Just (ids, _, bcos) -> do
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307

		-- link it
		hval <- linkExpr pls bcos

		-- run it!
		let thing_to_run = unsafeCoerce# hval :: IO [HValue]
		hvals <- thing_to_run

		case (ids,hvals) of
		  ([id],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv)
		  _ -> panic "cmCompileExpr"

   where
       CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
#endif
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326

-----------------------------------------------------------------------------
-- cmInfo: return "info" about an expression.  The info might be:
--
--	* its type, for an expression,
--	* the class definition, for a class
--	* the datatype definition, for a tycon (or synonym)
--	* the export list, for a module
--
-- Can be used to find the type of the last expression compiled, by looking
-- for "it".

cmInfo :: CmState -> String -> IO (Maybe String)
cmInfo cmstate str 
 = do error "cmInfo not implemented yet"

-----------------------------------------------------------------------------
-- Unload the compilation manager's state: everything it knows about the
-- current collection of modules in the Home package.
327

328
329
cmUnload :: CmState -> DynFlags -> IO CmState
cmUnload state@CmState{ gmode=mode, pls=pls, pcs=pcs } dflags
330
331
 = do -- Throw away the old home dir cache
      emptyHomeDirCache
332
333
334
335
336
337
338

      -- Unload everything the linker knows about
      new_pls <- CmLink.unload mode dflags [] pls 

      -- Start with a fresh CmState, but keep the PersistentCompilerState
      new_state <- cmInit mode
      return new_state{ pcs=pcs, pls=new_pls }
339

340
341
342
343
-----------------------------------------------------------------------------
-- The real business of the compilation manager: given a system state and
-- a module name, try and bring the module up to date, probably changing
-- the system state at the same time.
344

345
cmLoadModule :: CmState 
346
             -> [FilePath]
347
348
             -> IO (CmState,		-- new state
		    Bool, 		-- was successful
349
		    [String])		-- list of modules loaded
350

351
cmLoadModule cmstate1 rootnames
352
   = do -- version 1's are the original, before downsweep
353
354
        let pls1      = pls    cmstate1
        let pcs1      = pcs    cmstate1
355
356
        let hst1      = hst    cmstate1
        let hit1      = hit    cmstate1
357
358
	-- similarly, ui1 is the (complete) set of linkables from
	-- the previous pass, if any.
359
        let ui1       = ui     cmstate1
360
   	let mg1       = mg     cmstate1
361
   	let ic1       = ic     cmstate1
362

363
        let ghci_mode = gmode cmstate1 -- this never changes
364

365
        -- Do the downsweep to reestablish the module graph
366
367
368
369
	dflags <- getDynFlags
        let verb = verbosity dflags

	showPass dflags "Chasing dependencies"
370
        when (verb >= 1 && ghci_mode == Batch) $
371
372
373
           hPutStrLn stderr (showSDoc (hcat [
	     text progName, text ": chasing modules from: ",
	     hcat (punctuate comma (map text rootnames))]))
374

375
        (mg2unsorted, a_root_is_Main) <- downsweep rootnames mg1
376
        let mg2unsorted_names = map name_of_summary mg2unsorted
377

378
379
380
        -- reachable_from follows source as well as normal imports
        let reachable_from :: ModuleName -> [ModuleName]
            reachable_from = downwards_closure_of_module mg2unsorted
381
 
382
383
        -- should be cycle free; ignores 'import source's
        let mg2 = topological_sort False mg2unsorted
384
        -- ... whereas this takes them into account.  Used for
385
        -- backing out partially complete cycles following a failed
386
387
        -- upsweep, and for removing from hst/hit all the modules
        -- not in strict downwards closure, during calls to compile.
388
        let mg2_with_srcimps = topological_sort True mg2unsorted
389

390
	-- Sort out which linkables we wish to keep in the unlinked image.
391
	-- See getValidLinkables below for details.
392
393
	valid_linkables <- getValidLinkables ui1 mg2unsorted_names 
				mg2_with_srcimps
394
395
	-- when (verb >= 2) $
        --    putStrLn (showSDoc (text "Valid linkables:" 
396
        -- 			 <+> ppr valid_linkables))
397

398
399
400
401
402
403
404
405
        -- Figure out a stable set of modules which can be retained
        -- the top level envs, to avoid upsweeping them.  Goes to a
        -- bit of trouble to avoid upsweeping module cycles.
        --
        -- Construct a set S of stable modules like this:
        -- Travel upwards, over the sccified graph.  For each scc
        -- of modules ms, add ms to S only if:
        -- 1.  All home imports of ms are either in ms or S
406
407
        -- 2.  A valid linkable exists for each module in ms

408
409
        stable_mods <- preUpsweep valid_linkables hit1 
		 		  mg2unsorted_names [] mg2_with_srcimps
410

411
412
        let stable_summaries
               = concatMap (findInSummaries mg2unsorted) stable_mods
413

414
415
416
417
	    stable_linkables
	       = filter (\m -> linkableModName m `elem` stable_mods) 
		    valid_linkables

418
        when (verb >= 2) $
419
           putStrLn (showSDoc (text "Stable modules:" 
420
                               <+> sep (map (text.moduleNameUserString) stable_mods)))
421

422
423
424
425
	-- unload any modules which aren't going to be re-linked this
	-- time around.
	pls2 <- unload ghci_mode dflags stable_linkables pls1

426
        -- We could at this point detect cycles which aren't broken by
427
428
        -- a source-import, and complain immediately, but it seems better
        -- to let upsweep_mods do this, so at least some useful work gets
429
        -- done before the upsweep is abandoned.
430
        let upsweep_these
431
432
433
               = filter (\scc -> any (`notElem` stable_mods) 
                                     (map name_of_summary (flattenSCC scc)))
                        mg2
434

435
436
        --hPutStrLn stderr "after tsort:\n"
        --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
437
438
439
440
441

        -- Because we don't take into account source imports when doing
        -- the topological sort, there shouldn't be any cycles in mg2.
        -- If there is, we complain and give up -- the user needs to
        -- break the cycle using a boot file.
442
443
444
445

        -- Now do the upsweep, calling compile for each module in
        -- turn.  Final result is version 3 of everything.

446
        let threaded2 = CmThreaded pcs1 hst1 hit1
447

448
        (upsweep_complete_success, threaded3, modsUpswept, newLis)
449
           <- upsweep_mods ghci_mode dflags valid_linkables reachable_from 
450
                           threaded2 upsweep_these
451

452
        let ui3 = add_to_ui valid_linkables newLis
453
454
        let (CmThreaded pcs3 hst3 hit3) = threaded3

455
        -- At this point, modsUpswept and newLis should have the same
456
457
        -- length, so there is one new (or old) linkable for each 
        -- mod which was processed (passed to compile).
458

459
460
461
462
463
464
	-- Make modsDone be the summaries for each home module now
	-- available; this should equal the domains of hst3 and hit3.
	-- (NOT STRICTLY TRUE if an interactive session was started
	--  with some object on disk ???)
        -- Get in in a roughly top .. bottom order (hence reverse).

465
        let modsDone = reverse modsUpswept ++ stable_summaries
466

467
468
469
        -- Try and do linking in some form, depending on whether the
        -- upsweep was completely or only partially successful.

470
        if upsweep_complete_success
471
472

         then 
473
           -- Easy; just relink it all.
474
           do when (verb >= 2) $ 
475
		 hPutStrLn stderr "Upsweep completely successful."
476
477
478
479

	      -- clean up after ourselves
	      cleanTempFilesExcept verb (ppFilesFromSummaries modsDone)

480
481
482
483
484
	      -- link everything together
              linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2

	      cmLoadFinish True linkresult 
			hst3 hit3 ui3 modsDone ghci_mode pcs3
485
486

         else 
487
488
489
           -- Tricky.  We need to back out the effects of compiling any
           -- half-done cycles, both so as to clean up the top level envs
           -- and to avoid telling the interactive linker to link them.
490
491
           do when (verb >= 2) $
		hPutStrLn stderr "Upsweep partially successful."
492
493
494
495

              let modsDone_names
                     = map name_of_summary modsDone
              let mods_to_zap_names 
496
497
                     = findPartiallyCompletedCycles modsDone_names 
			  mg2_with_srcimps
498
              let mods_to_keep
499
500
                     = filter ((`notElem` mods_to_zap_names).name_of_summary) 
			  modsDone
501

502
503
504
505
              let (hst4, hit4, ui4)
                     = retainInTopLevelEnvs (map name_of_summary mods_to_keep) 
                                            (hst3,hit3,ui3)

506
507
508
	      -- clean up after ourselves
	      cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)

509
510
	      -- link everything together
              linkresult <- link ghci_mode dflags False ui4 pls2
511

512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
	      cmLoadFinish False linkresult 
		    hst4 hit4 ui4 mods_to_keep ghci_mode pcs3


-- Finish up after a cmLoad.
--
-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
cmLoadFinish ok linkresult hst hit ui mods ghci_mode pcs
  = do case linkresult of {
          LinkErrs _ _ -> panic "cmLoadModule: link failed (2)";
          LinkOK pls   -> do

       def_mod <- readIORef defaultCurrentModule
       let current_mod = case mods of 
				[]    -> def_mod
				(x:_) -> ms_mod x

       	   new_ic = emptyInteractiveContext current_mod

           new_cmstate = CmState{ hst=hst, hit=hit, 
                                  ui=ui, mg=mods,
                                  gmode=ghci_mode, pcs=pcs, 
				  pls=pls,
				  ic = new_ic }
           mods_loaded = map (moduleNameUserString.name_of_summary) mods

       return (new_cmstate, ok, mods_loaded)
    }
541

sof's avatar
sof committed
542
543
-- used to fish out the preprocess output files for the purposes
-- of cleaning up.
544
ppFilesFromSummaries summaries
sof's avatar
sof committed
545
546
547
548
549
550
551
552
553
  = [ fn | Just fn <- map toPpFile summaries ]
  where
   toPpFile sum
     | hspp /= ml_hs_file loc = hspp
     | otherwise              = Nothing
    where
      loc  = ms_location sum
      hspp = ml_hspp_file loc

554

555
556
557
-----------------------------------------------------------------------------
-- getValidLinkables

558
559
-- For each module (or SCC of modules), we take:
--
560
561
--	- an on-disk linkable, if this is the first time around and one
--	  is available.
562
--
563
564
565
566
567
--	- the old linkable, otherwise (and if one is available).
--
-- and we throw away the linkable if it is older than the source
-- file.  We ignore the on-disk linkables unless all of the dependents
-- of this SCC also have on-disk linkables.
568
569
570
571
572
573
574
--
-- If a module has a valid linkable, then it may be STABLE (see below),
-- and it is classified as SOURCE UNCHANGED for the purposes of calling
-- compile.
--
-- ToDo: this pass could be merged with the preUpsweep.

575
getValidLinkables
576
577
578
579
580
581
582
583
584
585
586
587
588
	:: [Linkable]		-- old linkables
	-> [ModuleName]		-- all home modules
	-> [SCC ModSummary]	-- all modules in the program, dependency order
	-> IO [Linkable]	-- still-valid linkables 

getValidLinkables old_linkables all_home_mods module_graph
  = foldM (getValidLinkablesSCC old_linkables all_home_mods) [] module_graph

getValidLinkablesSCC old_linkables all_home_mods new_linkables scc0
   = let 
	  scc             = flattenSCC scc0
          scc_names       = map name_of_summary scc
	  home_module m   = m `elem` all_home_mods && m `notElem` scc_names
589
590
591
592
          scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc))
		-- NOTE: ms_imps, not ms_allimps above.  We don't want to
		-- force a module's SOURCE imports to be already compiled for
		-- its object linkable to be valid.
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617

	  has_object m = case findModuleLinkable_maybe new_linkables m of
			    Nothing -> False
			    Just l  -> isObjectLinkable l

          objects_allowed = all has_object scc_allhomeimps
     in do

     these_linkables 
	<- foldM (getValidLinkable old_linkables objects_allowed) [] scc

	-- since an scc can contain only all objects or no objects at all,
	-- we have to check whether we got all objects or not, and re-do
	-- the linkable check if not.
     adjusted_linkables 
	<- if objects_allowed && not (all isObjectLinkable these_linkables)
	      then foldM (getValidLinkable old_linkables False) [] scc
	      else return these_linkables

     return (adjusted_linkables ++ new_linkables)


getValidLinkable :: [Linkable] -> Bool -> [Linkable] -> ModSummary 
	-> IO [Linkable]
getValidLinkable old_linkables objects_allowed new_linkables summary 
618
619
620
621
  = do let mod_name = name_of_summary summary

       maybe_disk_linkable
          <- if (not objects_allowed)
622
623
624
625
626
		then return Nothing
		else case ml_obj_file (ms_location summary) of
                 	Just obj_fn -> maybe_getFileLinkable mod_name obj_fn
                 	Nothing -> return Nothing

627
628
629
630
631
632
       let old_linkable = findModuleLinkable_maybe old_linkables mod_name
	   maybe_old_linkable =
	  	case old_linkable of
		    Just l | not (isObjectLinkable l) || stillThere l 
				-> old_linkable
				-- ToDo: emit a warning if not (stillThere l)
633
                    other -> Nothing
634
635
636
637
638
639
640
641

	   -- make sure that if we had an old disk linkable around, that it's
	   -- still there on the disk (in case we need to re-link it).
	   stillThere l = 
		case maybe_disk_linkable of
		   Nothing    -> False
		   Just l_disk -> linkableTime l == linkableTime l_disk

642
643
644
645
    	   -- we only look for objects on disk the first time around;
    	   -- if the user compiles a module on the side during a GHCi session,
    	   -- it won't be picked up until the next ":load".  This is what the
    	   -- "null old_linkables" test below is.
646
647
648
649
           linkable | null old_linkables = maybeToList maybe_disk_linkable
		    | otherwise          = maybeToList maybe_old_linkable

           -- only linkables newer than the source code are valid
650
           src_date = ms_hs_date summary
651
652

	   valid_linkable
653
654
655
656
657
658
659
	      =  filter (\l -> linkableTime l >= src_date) linkable
		-- why '>=' rather than '>' above?  If the filesystem stores
		-- times to the nearset second, we may occasionally find that
		-- the object & source have the same modification time, 
		-- especially if the source was automatically generated
		-- and compiled.  Using >= is slightly unsafe, but it matches
		-- make's behaviour.
660
661

       return (valid_linkable ++ new_linkables)
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677


maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable)
maybe_getFileLinkable mod_name obj_fn
   = do obj_exist <- doesFileExist obj_fn
        if not obj_exist 
         then return Nothing 
         else 
         do let stub_fn = case splitFilename3 obj_fn of
                             (dir, base, ext) -> dir ++ "/" ++ base ++ ".stub_o"
            stub_exist <- doesFileExist stub_fn
            obj_time <- getModificationTime obj_fn
            if stub_exist
             then return (Just (LM obj_time mod_name [DotO obj_fn, DotO stub_fn]))
             else return (Just (LM obj_time mod_name [DotO obj_fn]))

678

679
-----------------------------------------------------------------------------
680
-- Do a pre-upsweep without use of "compile", to establish a 
681
-- (downward-closed) set of stable modules for which we won't call compile.
682

683
684
685
686
687
-- a stable module:
--	* has a valid linkable (see getValidLinkables above)
--	* depends only on stable modules
--	* has an interface in the HIT (interactive mode only)

688
preUpsweep :: [Linkable]	-- new valid linkables
689
	   -> HomeIfaceTable
690
691
692
           -> [ModuleName]      -- names of all mods encountered in downsweep
           -> [ModuleName]      -- accumulating stable modules
           -> [SCC ModSummary]  -- scc-ified mod graph, including src imps
693
           -> IO [ModuleName]	-- stable modules
694

695
696
preUpsweep valid_lis hit all_home_mods stable []  = return stable
preUpsweep valid_lis hit all_home_mods stable (scc0:sccs)
697
698
699
700
701
702
703
704
705
   = do let scc = flattenSCC scc0
            scc_allhomeimps :: [ModuleName]
            scc_allhomeimps 
               = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc))
            all_imports_in_scc_or_stable
               = all in_stable_or_scc scc_allhomeimps
            scc_names
               = map name_of_summary scc
            in_stable_or_scc m
706
               = m `elem` scc_names || m `elem` stable
707

708
	    -- now we check for valid linkables: each module in the SCC must 
709
	    -- have a valid linkable (see getValidLinkables above).
710
	    has_valid_linkable new_summary
711
   	      = isJust (findModuleLinkable_maybe valid_lis modname)
712
713
	       where modname = name_of_summary new_summary

714
715
	    has_interface summary = ms_mod summary `elemUFM` hit

716
717
	    scc_is_stable = all_imports_in_scc_or_stable
			  && all has_valid_linkable scc
718
			  && all has_interface scc
719
720

        if scc_is_stable
721
722
         then preUpsweep valid_lis hit all_home_mods (scc_names++stable) sccs
         else preUpsweep valid_lis hit all_home_mods stable sccs
723
724
725
726
727
728
729
730
731


-- Helper for preUpsweep.  Assuming that new_summary's imports are all
-- stable (in the sense of preUpsweep), determine if new_summary is itself
-- stable, and, if so, in batch mode, return its linkable.
findInSummaries :: [ModSummary] -> ModuleName -> [ModSummary]
findInSummaries old_summaries mod_name
   = [s | s <- old_summaries, name_of_summary s == mod_name]

732
733
734
735
736
findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary
findModInSummaries old_summaries mod
   = case [s | s <- old_summaries, ms_mod s == mod] of
	 [] -> Nothing
	 (s:_) -> Just s
737

738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
-- Return (names of) all those in modsDone who are part of a cycle
-- as defined by theGraph.
findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName]
findPartiallyCompletedCycles modsDone theGraph
   = chew theGraph
     where
        chew [] = []
        chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
        chew ((CyclicSCC vs):rest)
           = let names_in_this_cycle = nub (map name_of_summary vs)
                 mods_in_this_cycle  
                    = nub ([done | done <- modsDone, 
                                   done `elem` names_in_this_cycle])
                 chewed_rest = chew rest
             in 
             if   not (null mods_in_this_cycle) 
                  && length mods_in_this_cycle < length names_in_this_cycle
             then mods_in_this_cycle ++ chewed_rest
             else chewed_rest
757
758


759
760
-- Add the given (LM-form) Linkables to the UI, overwriting previous
-- versions if they exist.
761
add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
762
add_to_ui ui lis
763
   = filter (not_in lis) ui ++ lis
764
     where
765
766
        not_in :: [Linkable] -> Linkable -> Bool
        not_in lis li
767
768
           = all (\l -> linkableModName l /= mod) lis
           where mod = linkableModName li
769
770
                                  

771
772
data CmThreaded  -- stuff threaded through individual module compilations
   = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
773

774

775
776
-- Compile multiple modules, stopping as soon as an error appears.
-- There better had not be any cyclic groups here -- we check for them.
777
upsweep_mods :: GhciMode
778
	     -> DynFlags
779
             -> UnlinkedImage         -- valid linkables
780
             -> (ModuleName -> [ModuleName])  -- to construct downward closures
781
782
             -> CmThreaded            -- PCS & HST & HIT
             -> [SCC ModSummary]      -- mods to do (the worklist)
783
                                      -- ...... RETURNING ......
784
785
786
             -> IO (Bool{-complete success?-},
                    CmThreaded,
                    [ModSummary],     -- mods which succeeded
787
                    [Linkable])       -- new linkables
788

789
upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
790
     []
791
792
   = return (True, threaded, [], [])

793
upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
794
     ((CyclicSCC ms):_)
795
   = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
796
797
798
                          unwords (map (moduleNameUserString.name_of_summary) ms))
        return (False, threaded, [], [])

799
upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
800
     ((AcyclicSCC mod):mods)
801
802
803
804
805
   = do --case threaded of
        --   CmThreaded pcsz hstz hitz
        --      -> putStrLn ("UPSWEEP_MOD: hit = " ++ show (map (moduleNameUserString.moduleName.mi_module) (eltsUFM hitz)))

        (threaded1, maybe_linkable) 
806
           <- upsweep_mod ghci_mode dflags oldUI threaded mod 
807
                          (reachable_from (name_of_summary mod))
808
809
810
811
        case maybe_linkable of
           Just linkable 
              -> -- No errors; do the rest
                 do (restOK, threaded2, modOKs, linkables) 
812
                       <- upsweep_mods ghci_mode dflags oldUI reachable_from 
813
                                       threaded1 mods
814
815
816
817
818
819
820
                    return (restOK, threaded2, mod:modOKs, linkable:linkables)
           Nothing -- we got a compilation error; give up now
              -> return (False, threaded1, [], [])


-- Compile a single module.  Always produce a Linkable for it if 
-- successful.  If no compilation happened, return the old Linkable.
821
upsweep_mod :: GhciMode 
822
	    -> DynFlags
823
            -> UnlinkedImage
824
            -> CmThreaded
825
            -> ModSummary
826
            -> [ModuleName]
827
            -> IO (CmThreaded, Maybe Linkable)
828

829
upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me
830
   = do 
831
        let mod_name = name_of_summary summary1
832
833
	let verb = verbosity dflags

834
        let (CmThreaded pcs1 hst1 hit1) = threaded1
835
        let old_iface = lookupUFM hit1 mod_name
836

837
        let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name
838

839
840
            source_unchanged = isJust maybe_old_linkable

841
842
843
	    reachable_only = filter (/= (name_of_summary summary1)) 
				reachable_inc_me

844
845
846
	   -- in interactive mode, all home modules below us *must* have an
	   -- interface in the HIT.  We never demand-load home interfaces in
	   -- interactive mode.
847
            (hst1_strictDC, hit1_strictDC, [])
848
               = ASSERT(ghci_mode == Batch || 
849
			all (`elemUFM` hit1) reachable_only)
850
		 retainInTopLevelEnvs reachable_only (hst1,hit1,[])
851

852
853
854
            old_linkable 
               = unJust "upsweep_mod:old_linkable" maybe_old_linkable

855
856
857
858
	    have_object 
	       | Just l <- maybe_old_linkable, isObjectLinkable l = True
	       | otherwise = False

859
        compresult <- compile ghci_mode summary1 source_unchanged
860
			 have_object old_iface hst1_strictDC hit1_strictDC pcs1
861
862
863

        case compresult of

864
865
866
867
           -- Compilation "succeeded", and may or may not have returned a new
           -- linkable (depending on whether compilation was actually performed
	   -- or not).
           CompOK pcs2 new_details new_iface maybe_new_linkable
868
869
870
871
              -> do let hst2      = addToUFM hst1 mod_name new_details
                        hit2      = addToUFM hit1 mod_name new_iface
                        threaded2 = CmThreaded pcs2 hst2 hit2

872
873
874
                    return (threaded2, if isJust maybe_new_linkable
					  then maybe_new_linkable
					  else Just old_linkable)
875
876
877

           -- Compilation failed.  compile may still have updated
           -- the PCS, tho.
878
           CompErrs pcs2
879
880
	      -> do let threaded2 = CmThreaded pcs2 hst1 hit1
                    return (threaded2, Nothing)
881

882
-- Filter modules in the top level envs (HST, HIT, UI).
883
retainInTopLevelEnvs :: [ModuleName]
884
885
886
                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
retainInTopLevelEnvs keep_these (hst, hit, ui)
887
   = (retainInUFM hst keep_these,
888
889
      retainInUFM hit keep_these,
      filterModuleLinkables (`elem` keep_these) ui
890
891
892
893
894
895
896
897
898
899
900
901
     )
     where
        retainInUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
        retainInUFM ufm keys_to_keep
           = listToUFM (concatMap (maybeLookupUFM ufm) keys_to_keep)
        maybeLookupUFM ufm u 
           = case lookupUFM ufm u of Nothing -> []; Just val -> [(u, val)] 

-- Needed to clean up HIT and HST so that we don't get duplicates in inst env
downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName]
downwards_closure_of_module summaries root
   = let toEdge :: ModSummary -> (ModuleName,[ModuleName])
902
903
904
905
906
907
         toEdge summ = (name_of_summary summ, 
			filter (`elem` all_mods) (ms_allimps summ))

	 all_mods = map name_of_summary summaries

         res = simple_transitive_closure (map toEdge summaries) [root]
908
     in
909
910
--         trace (showSDoc (text "DC of mod" <+> ppr root
--                          <+> text "=" <+> ppr res)) $
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
         res

-- Calculate transitive closures from a set of roots given an adjacency list
simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
simple_transitive_closure graph set 
   = let set2      = nub (concatMap dsts set ++ set)
         dsts node = fromMaybe [] (lookup node graph)
     in
         if   length set == length set2
         then set
         else simple_transitive_closure graph set2


-- Calculate SCCs of the module graph, with or without taking into
-- account source imports.
926
927
topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
topological_sort include_source_imports summaries
928
   = let 
929
         toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
930
         toEdge summ
931
932
933
934
             = (summ, name_of_summary summ, 
                      (if include_source_imports 
                       then ms_srcimps summ else []) ++ ms_imps summ)
        
935
         mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
936
937
938
939
940
941
942
943
         mash_edge (summ, m, m_imports)
            = case lookup m key_map of
                 Nothing -> panic "reverse_topological_sort"
                 Just mk -> (summ, mk, 
                                -- ignore imports not from the home package
                                catMaybes (map (flip lookup key_map) m_imports))

         edges     = map toEdge summaries
944
         key_map   = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
945
946
947
948
         scc_input = map mash_edge edges
         sccs      = stronglyConnComp scc_input
     in
         sccs
949

950
951
952

-- Chase downwards from the specified root set, returning summaries
-- for all home modules encountered.  Only follow source-import
953
954
-- links.  Also returns a Bool to indicate whether any of the roots
-- are module Main.
955
956
downsweep :: [FilePath] -> [ModSummary] -> IO ([ModSummary], Bool)
downsweep rootNm old_summaries
957
   = do rootSummaries <- mapM getRootSummary rootNm
958
959
960
961
        let a_root_is_Main 
               = any ((=="Main").moduleNameUserString.name_of_summary) 
                     rootSummaries
        all_summaries
962
           <- loop (concat (map ms_imps rootSummaries))
963
964
965
		(mkModuleEnv [ (mod, s) | s <- rootSummaries, 
					  let mod = ms_mod s, isHomeModule mod 
			     ])
966
        return (all_summaries, a_root_is_Main)
967
     where
968
969
	getRootSummary :: FilePath -> IO ModSummary
	getRootSummary file
970
	   | haskellish_src_file file
971
972
	   = do exists <- doesFileExist file
		if exists then summariseFile file else do
973
		throwDyn (CmdLineError ("can't find file `" ++ file ++ "'"))	
974
975
976
977
978
	   | otherwise
 	   = do exists <- doesFileExist hs_file
		if exists then summariseFile hs_file else do
		exists <- doesFileExist lhs_file
		if exists then summariseFile lhs_file else do
979
980
981
982
983
		let mod_name = mkModuleName file
		maybe_summary <- getSummary mod_name
		case maybe_summary of
		   Nothing -> packageModErr mod_name
		   Just s  -> return s
984
985
986
           where 
		 hs_file = file ++ ".hs"
		 lhs_file = file ++ ".lhs"
987

988
        getSummary :: ModuleName -> IO (Maybe ModSummary)
989
        getSummary nm
990
           = do found <- findModule nm
991
		case found of
992
993
		   Just (mod, location) -> do
			let old_summary = findModInSummaries old_summaries mod
994
			summarise mod location old_summary
995

996
		   Nothing -> throwDyn (CmdLineError 
997
                                   ("can't find module `" 
998
                                     ++ showSDoc (ppr nm) ++ "'"))
999

1000
        -- loop invariant: env doesn't contain package modules
For faster browsing, not all history is shown. View entire blame