CompManager.lhs 38.5 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 43
import CmStaticInfo	( GhciMode(..) )
import DriverPipeline
import DriverFlags	( getDynFlags )
import DriverPhases
import DriverUtil
import Finder
import HscMain		( initPersistentCompilerState )
44
import HscTypes
45 46
import RnEnv		( unQualInScope )
import Id		( idType, idName )
47
import Name		( Name, NamedThing(..), nameRdrName )
48
import NameEnv
49
import RdrName		( lookupRdrEnv, emptyRdrEnv )
50
import Module
51
import GetImports
52 53
import Type		( tidyType )
import VarEnv		( emptyTidyEnv )
54
import UniqFM
55
import Unique		( Uniquable )
56
import Digraph		( SCC(..), stronglyConnComp, flattenSCC )
57
import ErrUtils		( showPass )
58
import SysTools		( cleanTempFilesExcept )
59
import Util
60
import Outputable
61
import Panic
62
import CmdLineOpts	( DynFlags(..) )
63
import IOExts
64

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

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

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

82

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

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

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

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

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

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

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

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

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

137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
-----------------------------------------------------------------------------
-- 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 
152
			then throwDyn (CmdLineError (showSDoc 
153 154 155 156 157 158 159 160 161 162 163 164 165
				(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
166
	Nothing -> throwDyn (CmdLineError ("can't find module `"
167 168 169 170 171 172 173
				    ++ moduleNameUserString mn ++ "'"))
	Just (m,_) -> return m

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

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

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

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

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

195 196 197 198 199 200 201 202 203 204
		    -- 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 	
205 206 207 208 209
			      		[ (getName id, AnId id)	| id <- ids]

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

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

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

217 218 219 220 221
		-- 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)
222

223
	        return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
224
   where
225 226 227 228 229 230 231 232 233
       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
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
   = 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
252 253 254
#endif

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

257
#ifdef GHCI
258 259 260 261 262 263 264
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)
265
	       ty = tidyType emptyTidyEnv (idType id)
266
	       str = case lookupIfaceByModName hit pit modname of
267 268
			Nothing    -> showSDoc (ppr ty)
			Just iface -> showSDocForUser unqual (ppr ty)
269 270 271 272
		  	   where unqual = unQualInScope (mi_globals iface)
	   in return (Just str)

	_ -> panic "cmTypeOfName"
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288
#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 
289
		  ("let __cmCompileExpr = "++expr) False{-stmt-}
290 291 292

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

		-- 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
309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327

-----------------------------------------------------------------------------
-- 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.
328

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

      -- 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 }
340

341 342 343 344
-----------------------------------------------------------------------------
-- 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.
345

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

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

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

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

	showPass dflags "Chasing dependencies"
371
        when (verb >= 1 && ghci_mode == Batch) $
372
           hPutStrLn stderr (progName ++ ": chasing modules from: " ++ rootname)
373

374
        (mg2unsorted, a_root_is_Main) <- downsweep [rootname] mg1
375
        let mg2unsorted_names = map name_of_summary mg2unsorted
376

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

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

397 398 399 400 401 402 403 404
        -- 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
405 406
        -- 2.  A valid linkable exists for each module in ms

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

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

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

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

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

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

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

        -- 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.
441 442 443 444

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

445
        let threaded2 = CmThreaded pcs1 hst1 hit1
446

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

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

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

458 459 460 461 462 463
	-- 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).

464
        let modsDone = reverse modsUpswept ++ stable_summaries
465

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

469
        if upsweep_complete_success
470 471

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

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

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

	      cmLoadFinish True linkresult 
			hst3 hit3 ui3 modsDone ghci_mode pcs3
484 485

         else 
486 487 488
           -- 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.
489 490
           do when (verb >= 2) $
		hPutStrLn stderr "Upsweep partially successful."
491 492 493 494

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

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

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

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

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
	      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)
    }
540

541 542 543
ppFilesFromSummaries summaries
  = [ fn | Just fn <- map (ml_hspp_file . ms_location) summaries ]

544 545 546
-----------------------------------------------------------------------------
-- getValidLinkables

547 548
-- For each module (or SCC of modules), we take:
--
549 550
--	- an on-disk linkable, if this is the first time around and one
--	  is available.
551
--
552 553 554 555 556
--	- 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.
557 558 559 560 561 562 563
--
-- 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.

564
getValidLinkables
565 566 567 568 569 570 571 572 573 574 575 576 577
	:: [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
578 579 580 581
          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.
582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606

	  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 
607 608 609 610
  = do let mod_name = name_of_summary summary

       maybe_disk_linkable
          <- if (not objects_allowed)
611 612 613 614 615
		then return Nothing
		else case ml_obj_file (ms_location summary) of
                 	Just obj_fn -> maybe_getFileLinkable mod_name obj_fn
                 	Nothing -> return Nothing

616 617 618 619 620 621
       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)
622
                    other -> Nothing
623 624 625 626 627 628 629 630

	   -- 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

631 632 633 634
    	   -- 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.
635 636 637 638
           linkable | null old_linkables = maybeToList maybe_disk_linkable
		    | otherwise          = maybeToList maybe_old_linkable

           -- only linkables newer than the source code are valid
639
           src_date = ms_hs_date summary
640 641

	   valid_linkable
642
	      =  filter (\l -> linkableTime l > src_date) linkable
643 644

       return (valid_linkable ++ new_linkables)
645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660


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]))

661

662
-----------------------------------------------------------------------------
663
-- Do a pre-upsweep without use of "compile", to establish a 
664
-- (downward-closed) set of stable modules for which we won't call compile.
665

666 667 668 669 670
-- a stable module:
--	* has a valid linkable (see getValidLinkables above)
--	* depends only on stable modules
--	* has an interface in the HIT (interactive mode only)

671
preUpsweep :: [Linkable]	-- new valid linkables
672
	   -> HomeIfaceTable
673 674 675
           -> [ModuleName]      -- names of all mods encountered in downsweep
           -> [ModuleName]      -- accumulating stable modules
           -> [SCC ModSummary]  -- scc-ified mod graph, including src imps
676
           -> IO [ModuleName]	-- stable modules
677

678 679
preUpsweep valid_lis hit all_home_mods stable []  = return stable
preUpsweep valid_lis hit all_home_mods stable (scc0:sccs)
680 681 682 683 684 685 686 687 688
   = 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
689
               = m `elem` scc_names || m `elem` stable
690

691
	    -- now we check for valid linkables: each module in the SCC must 
692
	    -- have a valid linkable (see getValidLinkables above).
693
	    has_valid_linkable new_summary
694
   	      = isJust (findModuleLinkable_maybe valid_lis modname)
695 696
	       where modname = name_of_summary new_summary

697 698
	    has_interface summary = ms_mod summary `elemUFM` hit

699 700
	    scc_is_stable = all_imports_in_scc_or_stable
			  && all has_valid_linkable scc
701
			  && all has_interface scc
702 703

        if scc_is_stable
704 705
         then preUpsweep valid_lis hit all_home_mods (scc_names++stable) sccs
         else preUpsweep valid_lis hit all_home_mods stable sccs
706 707 708 709 710 711 712 713 714


-- 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]

715 716 717 718 719
findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary
findModInSummaries old_summaries mod
   = case [s | s <- old_summaries, ms_mod s == mod] of
	 [] -> Nothing
	 (s:_) -> Just s
720

721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739
-- 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
740 741


742 743
-- Add the given (LM-form) Linkables to the UI, overwriting previous
-- versions if they exist.
744
add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
745
add_to_ui ui lis
746
   = filter (not_in lis) ui ++ lis
747
     where
748 749
        not_in :: [Linkable] -> Linkable -> Bool
        not_in lis li
750 751
           = all (\l -> linkableModName l /= mod) lis
           where mod = linkableModName li
752 753
                                  

754 755
data CmThreaded  -- stuff threaded through individual module compilations
   = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
756

757

758 759
-- Compile multiple modules, stopping as soon as an error appears.
-- There better had not be any cyclic groups here -- we check for them.
760
upsweep_mods :: GhciMode
761
	     -> DynFlags
762
             -> UnlinkedImage         -- valid linkables
763
             -> (ModuleName -> [ModuleName])  -- to construct downward closures
764 765
             -> CmThreaded            -- PCS & HST & HIT
             -> [SCC ModSummary]      -- mods to do (the worklist)
766
                                      -- ...... RETURNING ......
767 768 769
             -> IO (Bool{-complete success?-},
                    CmThreaded,
                    [ModSummary],     -- mods which succeeded
770
                    [Linkable])       -- new linkables
771

772
upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
773
     []
774 775
   = return (True, threaded, [], [])

776
upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
777
     ((CyclicSCC ms):_)
778
   = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
779 780 781
                          unwords (map (moduleNameUserString.name_of_summary) ms))
        return (False, threaded, [], [])

782
upsweep_mods ghci_mode dflags oldUI reachable_from threaded 
783
     ((AcyclicSCC mod):mods)
784 785 786 787 788
   = do --case threaded of
        --   CmThreaded pcsz hstz hitz
        --      -> putStrLn ("UPSWEEP_MOD: hit = " ++ show (map (moduleNameUserString.moduleName.mi_module) (eltsUFM hitz)))

        (threaded1, maybe_linkable) 
789
           <- upsweep_mod ghci_mode dflags oldUI threaded mod 
790
                          (reachable_from (name_of_summary mod))
791 792 793 794
        case maybe_linkable of
           Just linkable 
              -> -- No errors; do the rest
                 do (restOK, threaded2, modOKs, linkables) 
795
                       <- upsweep_mods ghci_mode dflags oldUI reachable_from 
796
                                       threaded1 mods
797 798 799 800 801 802 803
                    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.
804
upsweep_mod :: GhciMode 
805
	    -> DynFlags
806
            -> UnlinkedImage
807
            -> CmThreaded
808
            -> ModSummary
809
            -> [ModuleName]
810
            -> IO (CmThreaded, Maybe Linkable)
811

812
upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me
813
   = do 
814
        let mod_name = name_of_summary summary1
815 816
	let verb = verbosity dflags

817
        let (CmThreaded pcs1 hst1 hit1) = threaded1
818
        let old_iface = lookupUFM hit1 mod_name
819

820
        let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name
821

822 823
            source_unchanged = isJust maybe_old_linkable

824 825 826
	    reachable_only = filter (/= (name_of_summary summary1)) 
				reachable_inc_me

827 828 829
	   -- in interactive mode, all home modules below us *must* have an
	   -- interface in the HIT.  We never demand-load home interfaces in
	   -- interactive mode.
830
            (hst1_strictDC, hit1_strictDC, [])
831
               = ASSERT(ghci_mode == Batch || 
832
			all (`elemUFM` hit1) reachable_only)
833
		 retainInTopLevelEnvs reachable_only (hst1,hit1,[])
834

835 836 837
            old_linkable 
               = unJust "upsweep_mod:old_linkable" maybe_old_linkable

838 839 840 841
	    have_object 
	       | Just l <- maybe_old_linkable, isObjectLinkable l = True
	       | otherwise = False

842
        compresult <- compile ghci_mode summary1 source_unchanged
843
			 have_object old_iface hst1_strictDC hit1_strictDC pcs1
844 845 846

        case compresult of

847 848 849 850
           -- 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
851 852 853 854
              -> do let hst2      = addToUFM hst1 mod_name new_details
                        hit2      = addToUFM hit1 mod_name new_iface
                        threaded2 = CmThreaded pcs2 hst2 hit2

855 856 857
                    return (threaded2, if isJust maybe_new_linkable
					  then maybe_new_linkable
					  else Just old_linkable)
858 859 860

           -- Compilation failed.  compile may still have updated
           -- the PCS, tho.
861
           CompErrs pcs2
862 863
	      -> do let threaded2 = CmThreaded pcs2 hst1 hit1
                    return (threaded2, Nothing)
864

865
-- Filter modules in the top level envs (HST, HIT, UI).
866
retainInTopLevelEnvs :: [ModuleName]
867 868 869
                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
retainInTopLevelEnvs keep_these (hst, hit, ui)
870
   = (retainInUFM hst keep_these,
871 872
      retainInUFM hit keep_these,
      filterModuleLinkables (`elem` keep_these) ui
873 874 875 876 877 878 879 880 881 882 883 884
     )
     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])
885 886 887 888 889 890
         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]
891
     in
892 893
         --trace (showSDoc (text "DC of mod" <+> ppr root
         --                 <+> text "=" <+> ppr res)) (
894
         res
895
         --)
896 897 898 899 900 901 902 903 904 905 906 907 908 909

-- 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.
910 911
topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
topological_sort include_source_imports summaries
912
   = let 
913
         toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
914
         toEdge summ
915 916 917 918
             = (summ, name_of_summary summ, 
                      (if include_source_imports 
                       then ms_srcimps summ else []) ++ ms_imps summ)
        
919
         mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
920 921 922 923 924 925 926 927
         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
928
         key_map   = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
929 930 931 932
         scc_input = map mash_edge edges
         sccs      = stronglyConnComp scc_input
     in
         sccs
933

934 935 936

-- Chase downwards from the specified root set, returning summaries
-- for all home modules encountered.  Only follow source-import
937 938
-- links.  Also returns a Bool to indicate whether any of the roots
-- are module Main.
939 940
downsweep :: [FilePath] -> [ModSummary] -> IO ([ModSummary], Bool)
downsweep rootNm old_summaries
941
   = do rootSummaries <- mapM getRootSummary rootNm
942 943 944 945
        let a_root_is_Main 
               = any ((=="Main").moduleNameUserString.name_of_summary) 
                     rootSummaries
        all_summaries
946
           <- loop (concat (map ms_imps rootSummaries))
947 948 949
		(mkModuleEnv [ (mod, s) | s <- rootSummaries, 
					  let mod = ms_mod s, isHomeModule mod 
			     ])
950
        return (all_summaries, a_root_is_Main)
951
     where
952 953
	getRootSummary :: FilePath -> IO ModSummary
	getRootSummary file
954
	   | haskellish_src_file file
955 956
	   = do exists <- doesFileExist file
		if exists then summariseFile file else do
957
		throwDyn (CmdLineError ("can't find file `" ++ file ++ "'"))	
958 959 960 961 962
	   | 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
963 964 965 966 967
		let mod_name = mkModuleName file
		maybe_summary <- getSummary mod_name
		case maybe_summary of
		   Nothing -> packageModErr mod_name
		   Just s  -> return s
968 969 970
           where 
		 hs_file = file ++ ".hs"
		 lhs_file = file ++ ".lhs"
971

972
        getSummary :: ModuleName -> IO (Maybe ModSummary)
973
        getSummary nm
974
           = do found <- findModule nm
975
		case found of
976 977
		   Just (mod, location) -> do
			let old_summary = findModInSummaries old_summaries mod
978
			summarise mod location old_summary
979

980
		   Nothing -> throwDyn (CmdLineError 
981
                                   ("can't find module `" 
982
                                     ++ showSDoc (ppr nm) ++ "'"))
983

984 985 986 987 988 989
        -- loop invariant: env doesn't contain package modules
        loop :: [ModuleName] -> ModuleEnv ModSummary -> IO [ModSummary]
	loop [] env = return (moduleEnvElts env)
        loop imps env
           = do -- imports for modules we don't already have
                let needed_imps = nub (filter (not . (`elemUFM` env)) imps)
990

991 992 993 994
		-- summarise them