CompManager.lhs 50.4 KB
Newer Older
1
%
2
3
4
% (c) The University of Glasgow, 2002
%
% The Compilation Manager
5
6
%
\begin{code}
7
module CompManager ( 
8
9
    ModSummary,		-- Abstract
    ModuleGraph, 	-- All the modules from the home package
10

11
    CmState, 		-- Abstract
12

13
    cmInit, 	   -- :: GhciMode -> IO CmState
14

15
    cmDepAnal,	   -- :: CmState -> [FilePath] -> IO ModuleGraph
16
    cmDownsweep,   
17
18
    cmTopSort,	   -- :: Bool -> ModuleGraph -> [SCC ModSummary]
    cyclicModuleErr,	-- :: [ModSummary] -> String	-- Used by DriverMkDepend
19

20
    cmLoadModules, -- :: CmState -> ModuleGraph
sof's avatar
sof committed
21
		   --	 -> IO (CmState, Bool, [String])
22

23
    cmUnload,	   -- :: CmState -> IO CmState
24

25

26
27
#ifdef GHCI
    cmModuleIsInterpreted, -- :: CmState -> String -> IO Bool
28

29
    cmSetContext,  -- :: CmState -> [String] -> [String] -> IO CmState
30
    cmGetContext,  -- :: CmState -> IO ([String],[String])
31

32
33
    cmGetInfo,    -- :: CmState -> String -> IO (CmState, [(TyThing,Fixity)])
    GetInfoResult,
34
    cmBrowseModule, -- :: CmState -> IO [TyThing]
35
    cmShowModule,
36

37
    CmRunResult(..),
38
    cmRunStmt,		-- :: CmState -> String -> IO (CmState, CmRunResult)
rrt's avatar
rrt committed
39

40
41
42
    cmTypeOfExpr,	-- :: CmState -> String -> IO (CmState, Maybe String)
    cmKindOfType,	-- :: CmState -> String -> IO (CmState, Maybe String)
    cmTypeOfName,	-- :: CmState -> Name -> IO (Maybe String)
43

44
    HValue,
45
    cmCompileExpr,	-- :: CmState -> String -> IO (CmState, Maybe HValue)
46
    cmGetModuleGraph,	-- :: CmState -> ModuleGraph
47
    cmSetDFlags,
48
49
    cmGetDFlags,

50
51
    cmGetBindings, 	-- :: CmState -> [TyThing]
    cmGetPrintUnqual,	-- :: CmState -> PrintUnqualified
52
#endif
53
  )
54
55
56
57
where

#include "HsVersions.h"

58
import Packages		( isHomePackage )
59
import DriverPipeline	( CompResult(..), preprocess, compile, link )
60
import HscMain		( newHscEnv )
61
import DriverState	( v_Output_file, v_NoHsMain, v_MainModIs )
62
import DriverPhases	( HscSource(..), hscSourceString, isHaskellSrcFilename )
63
import Finder		( findModule, findLinkable, addHomeModuleToFinder,
64
			  flushFinderCache, mkHomeModLocation, FindResult(..), cantFindError )
65
import HscTypes		( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath,
66
			  HscEnv(..), GhciMode(..), isBootSummary,
67
68
69
70
71
72
			  InteractiveContext(..), emptyInteractiveContext, 
			  HomePackageTable, emptyHomePackageTable, IsBootInterface,
			  Linkable(..), isObjectLinkable )
import Module		( Module, mkModule, delModuleEnv, delModuleEnvList, mkModuleEnv,
			  lookupModuleEnv, moduleEnvElts, extendModuleEnv, filterModuleEnv,
			  moduleUserString, addBootSuffixLocn, 
73
			  ModLocation(..) )
74
import GetImports	( getImports )
75
import Digraph		( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
76
import ErrUtils		( showPass )
77
import SysTools		( cleanTempFilesExcept )
78
import BasicTypes	( SuccessFlag(..), succeeded )
79
import StringBuffer	( hGetStringBuffer )
80
import Util
81
import Outputable
82
import Panic
83
import CmdLineOpts	( DynFlags(..) )
84
import Maybes		( expectJust, orElse, mapCatMaybes )
85
import FiniteMap
86

87
import DATA_IOREF	( readIORef )
88

89
#ifdef GHCI
90
import Finder 		( findPackageModule )
91
import HscMain		( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType )
92
import HscTypes		( TyThing(..), icPrintUnqual, showModMsg )
93
import TcRnDriver	( mkExportEnv, getModuleContents )
94
import IfaceSyn		( IfaceDecl )
95
import RdrName		( GlobalRdrEnv, plusGlobalRdrEnv )
96
97
import Name		( Name )
import NameEnv
98
import Id		( idType )
99
import Type		( tidyType, dropForAlls )
100
import VarEnv		( emptyTidyEnv )
101
import Linker		( HValue, unload, extendLinkEnv )
102
import GHC.Exts		( unsafeCoerce# )
103
import Foreign
104
import Control.Exception as Exception ( Exception, try )
105
import CmdLineOpts	( DynFlag(..), dopt_unset, dopt )
sof's avatar
sof committed
106
107
#endif

108
import EXCEPTION	( throwDyn )
109
110

-- std
111
import Directory        ( getModificationTime, doesFileExist )
112
import IO
113
import Monad
114
import List		( nub )
115
import Maybe
116
\end{code}
117

118

119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
%************************************************************************
%*									*
		The module dependency graph
		ModSummary, ModGraph, NodeKey, NodeMap
%*									*
%************************************************************************

The nodes of the module graph are
	EITHER a regular Haskell source module
	OR     a hi-boot source module

A ModuleGraph contains all the nodes from the home package (only).  
There will be a node for each source module, plus a node for each hi-boot
module.

\begin{code}
type ModuleGraph = [ModSummary]  -- The module graph, 
				 -- NOT NECESSARILY IN TOPOLOGICAL ORDER

emptyMG :: ModuleGraph
emptyMG = []

--------------------
142
ms_allimps :: ModSummary -> [Module]
143
144
145
ms_allimps ms = ms_srcimps ms ++ ms_imps ms

--------------------
146
147
type NodeKey   = (Module, HscSource)	  -- The nodes of the graph are 
type NodeMap a = FiniteMap NodeKey a	  -- keyed by (mod, src_file_type) pairs
148
149

msKey :: ModSummary -> NodeKey
150
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
151
152
153
154

emptyNodeMap :: NodeMap a
emptyNodeMap = emptyFM

155
156
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
157
158
159
160
161
162
163
164
165
166
167
168
169
	
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
\end{code}


%************************************************************************
%*									*
		The compilation manager state
%*									*
%************************************************************************


170
\begin{code}
171
172
-- Persistent state for the entire system
data CmState
173
   = CmState {
174
175
176
	cm_hsc :: HscEnv,		-- Includes the home-package table
	cm_mg  :: ModuleGraph,		-- The module graph
  	cm_ic  :: InteractiveContext 	-- Command-line binding info
177
     }
178

179
#ifdef GHCI
180
cmGetModuleGraph cmstate = cm_mg cmstate
181
182
183
184
cmGetBindings    cmstate = nameEnvElts (ic_type_env (cm_ic cmstate))
cmGetPrintUnqual cmstate = icPrintUnqual (cm_ic cmstate)
cmHPT		 cmstate = hsc_HPT (cm_hsc cmstate)
#endif
185

186
187
188
189
190
191
cmInit :: GhciMode -> DynFlags -> IO CmState
cmInit ghci_mode dflags
   = do { hsc_env <- newHscEnv ghci_mode dflags
	; return (CmState { cm_hsc = hsc_env,
			    cm_mg  = emptyMG, 
			    cm_ic  = emptyInteractiveContext })}
192

193
194
195
196
197
198
discardCMInfo :: CmState -> CmState
-- Forget the compilation manager's state, including the home package table
-- but retain the persistent info in HscEnv
discardCMInfo cm_state
  = cm_state { cm_mg = emptyMG, cm_ic = emptyInteractiveContext,
	       cm_hsc = (cm_hsc cm_state) { hsc_HPT = emptyHomePackageTable } }
199

200
201
202
203
204
205
206
-------------------------------------------------------------------
--			The unlinked image
-- 
-- The compilation manager keeps a list of compiled, but as-yet unlinked
-- binaries (byte code or object code).  Even when it links bytecode
-- it keeps the unlinked version so it can re-link it later without
-- recompiling.
207

208
type UnlinkedImage = [Linkable]	-- the unlinked images (should be a set, really)
209

210
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
211
212
213
214
215
findModuleLinkable_maybe lis mod
   = case [LM time nm us | LM time nm us <- lis, nm == mod] of
        []   -> Nothing
        [li] -> Just li
        many -> pprPanic "findModuleLinkable" (ppr mod)
216
217
218

delModuleLinkable :: [Linkable] -> Module -> [Linkable]
delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ]
219
220
221
222
223
224
225
226
227
228
229
\end{code}


%************************************************************************
%*									*
	GHCI stuff
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI
230
231
232
233
234
-----------------------------------------------------------------------------
-- 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.

235
cmSetContext
236
	:: CmState
237
238
239
	-> [String]		-- take the top-level scopes of these modules
	-> [String]		-- and the just the exports from these
	-> IO CmState
240
cmSetContext cmstate toplevs exports = do 
241
242
243
244
  let old_ic  = cm_ic cmstate
      hsc_env = cm_hsc cmstate
      hpt     = hsc_HPT hsc_env

245
246
247
  let export_mods = map mkModule exports
  mapM_ (checkModuleExists (hsc_dflags hsc_env) hpt) export_mods
  export_env  <- mkExportEnv hsc_env export_mods
248
249
250
251
  toplev_envs <- mapM (mkTopLevEnv hpt) toplevs

  let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
  return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs,
252
 		     		   ic_exports      = exports,
253
254
			       	   ic_rn_gbl_env   = all_env } }

255
256
257
258
259
260
261
262
263
264
265
checkModuleExists :: DynFlags -> HomePackageTable -> Module -> IO ()
checkModuleExists dflags hpt mod = 
  case lookupModuleEnv hpt mod of
    Just mod_info -> return ()
    _not_a_home_module -> do
	  res <- findPackageModule dflags mod True
	  case res of
	    Found _ _ -> return  ()
	    err -> let msg = cantFindError dflags mod err in
		   throwDyn (CmdLineError (showSDoc msg))

266
267
mkTopLevEnv :: HomePackageTable -> String -> IO GlobalRdrEnv
mkTopLevEnv hpt mod
268
 = case lookupModuleEnv hpt (mkModule mod) of
269
      Nothing      -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ mod))
270
      Just details -> case mi_globals (hm_iface details) of
271
272
			Nothing  -> throwDyn (ProgramError ("mkTopLevEnv: not interpreted " ++ mod))
			Just env -> return env
273
274

cmGetContext :: CmState -> IO ([String],[String])
275
276
cmGetContext CmState{cm_ic=ic} = 
  return (ic_toplev_scope ic, ic_exports ic)
277
278
279

cmModuleIsInterpreted :: CmState -> String -> IO Bool
cmModuleIsInterpreted cmstate str 
280
 = case lookupModuleEnv (cmHPT cmstate) (mkModule str) of
281
      Just details       -> return (isJust (mi_globals (hm_iface details)))
282
      _not_a_home_module -> return False
283

284
-----------------------------------------------------------------------------
285

286
287
288
289
cmSetDFlags :: CmState -> DynFlags -> CmState
cmSetDFlags cm_state dflags 
  = cm_state { cm_hsc = (cm_hsc cm_state) { hsc_dflags = dflags } }

290
291
292
cmGetDFlags :: CmState -> DynFlags
cmGetDFlags cm_state = hsc_dflags (cm_hsc cm_state)

293
294
295
296
297
298
-----------------------------------------------------------------------------
-- cmInfoThing: convert a String to a TyThing

-- A string may refer to more than one TyThing (eg. a constructor,
-- and type constructor), so we return a list of all the possible TyThings.

299
300
cmGetInfo :: CmState -> String -> IO [GetInfoResult]
cmGetInfo cmstate id = hscGetInfo (cm_hsc cmstate) (cm_ic cmstate) id
301

302
303
304
-- ---------------------------------------------------------------------------
-- cmBrowseModule: get all the TyThings defined in a module

305
306
cmBrowseModule :: CmState -> String -> Bool -> IO [IfaceDecl]
cmBrowseModule cmstate str exports_only
307
  = do { mb_decls <- getModuleContents (cm_hsc cmstate) (cm_ic cmstate) 
308
		     		       (mkModule str) exports_only
309
310
311
312
       ; case mb_decls of
	   Nothing -> return []		-- An error of some kind
	   Just ds -> return ds
   }
313

314

315
316
317
-----------------------------------------------------------------------------
cmShowModule :: CmState -> ModSummary -> String
cmShowModule cmstate mod_summary
318
  = case lookupModuleEnv hpt (ms_mod mod_summary) of
319
	Nothing	      -> panic "missing linkable"
320
	Just mod_info -> showModMsg obj_linkable mod_summary
321
322
323
324
325
		      where
			 obj_linkable = isObjectLinkable (hm_linkable mod_info)
  where
    hpt  = hsc_HPT (cm_hsc cmstate)

326
327
328
-----------------------------------------------------------------------------
-- cmRunStmt:  Run a statement/expr.

329
330
331
332
333
data CmRunResult
  = CmRunOk [Name] 		-- names bound by this evaluation
  | CmRunFailed 
  | CmRunException Exception	-- statement raised an exception

334
335
cmRunStmt :: CmState -> String -> IO (CmState, CmRunResult)		
cmRunStmt cmstate@CmState{ cm_hsc=hsc_env, cm_ic=icontext } expr
336
   = do 
337
338
339
340
341
342
	-- Turn off -fwarn-unused-bindings when running a statement, to hide
	-- warnings about the implicit bindings we introduce.
	let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
	    hsc_env' = hsc_env{ hsc_dflags = dflags' }

        maybe_stuff <- hscStmt hsc_env' icontext expr
343

344
        case maybe_stuff of
345
	   Nothing -> return (cmstate, CmRunFailed)
346
	   Just (new_ic, names, hval) -> do
347

348
		let thing_to_run = unsafeCoerce# hval :: IO [HValue]
349
		either_hvals <- sandboxIO thing_to_run
350

351
		case either_hvals of
352
		    Left e -> do
353
354
355
			-- on error, keep the *old* interactive context,
			-- so that 'it' is not bound to something
			-- that doesn't exist.
356
		        return ( cmstate, CmRunException e )
357

358
359
360
361
362
363
		    Right hvals -> do
			-- Get the newly bound things, and bind them.  
			-- Don't need to delete any shadowed bindings;
			-- the new ones override the old ones. 
			extendLinkEnv (zip names hvals)
	     		
364
			return (cmstate{ cm_ic=new_ic }, 
365
				CmRunOk names)
366

367
368
369
370
371
372

-- We run the statement in a "sandbox" to protect the rest of the
-- system from anything the expression might do.  For now, this
-- consists of just wrapping it in an exception handler, but see below
-- for another version.

373
374
sandboxIO :: IO a -> IO (Either Exception a)
sandboxIO thing = Exception.try thing
375
376
377
378
379
380

{-
-- This version of sandboxIO runs the expression in a completely new
-- RTS main thread.  It is disabled for now because ^C exceptions
-- won't be delivered to the new thread, instead they'll be delivered
-- to the (blocked) GHCi main thread.
381

382
383
-- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception

384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
sandboxIO :: IO a -> IO (Either Int (Either Exception a))
sandboxIO thing = do
  st_thing <- newStablePtr (Exception.try thing)
  alloca $ \ p_st_result -> do
    stat <- rts_evalStableIO st_thing p_st_result
    freeStablePtr st_thing
    if stat == 1
	then do st_result <- peek p_st_result
		result <- deRefStablePtr st_result
		freeStablePtr st_result
		return (Right result)
	else do
		return (Left (fromIntegral stat))

foreign import "rts_evalStableIO"  {- safe -}
  rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
  -- more informative than the C type!
401
-}
402
403
404
405

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

406
407
408
cmTypeOfExpr :: CmState -> String -> IO (Maybe String)
cmTypeOfExpr cmstate expr
   = do maybe_stuff <- hscTcExpr (cm_hsc cmstate) (cm_ic cmstate) expr
409
410

	case maybe_stuff of
411
	   Nothing -> return Nothing
412
	   Just ty -> return (Just (showSDocForUser unqual doc))
413
 	     where 
414
		doc     = text expr <+> dcolon <+> ppr final_ty
415
		unqual  = icPrintUnqual (cm_ic cmstate)
416
		tidy_ty = tidyType emptyTidyEnv ty
417
418
419
420
421
422
		dflags  = hsc_dflags (cm_hsc cmstate)
		-- if -fglasgow-exts is on we show the foralls, otherwise
		-- we don't.
		final_ty
		  | dopt Opt_GlasgowExts dflags = tidy_ty
		  | otherwise			= dropForAlls tidy_ty
423

424
425
426
427
428
429
430
431
-----------------------------------------------------------------------------
-- cmKindOfType: returns a string representing the kind of a type

cmKindOfType :: CmState -> String -> IO (Maybe String)
cmKindOfType cmstate str
   = do maybe_stuff <- hscKcType (cm_hsc cmstate) (cm_ic cmstate) str
	case maybe_stuff of
	   Nothing -> return Nothing
432
	   Just kind -> return (Just res_str)
433
 	     where 
434
		res_str = showSDocForUser unqual (text str <+> dcolon <+> ppr kind)
435
436
		unqual  = icPrintUnqual (cm_ic cmstate)

437
-----------------------------------------------------------------------------
438
-- cmTypeOfName: returns a string representing the type of a name.
439
440

cmTypeOfName :: CmState -> Name -> IO (Maybe String)
441
cmTypeOfName CmState{ cm_ic=ic } name
442
443
444
 = do 
    hPutStrLn stderr ("cmTypeOfName: " ++ showSDoc (ppr name))
    case lookupNameEnv (ic_type_env ic) name of
445
	Nothing        -> return Nothing
446
447
	Just (AnId id) -> return (Just str)
	   where
448
	     unqual = icPrintUnqual ic
449
450
	     ty = tidyType emptyTidyEnv (idType id)
	     str = showSDocForUser unqual (ppr ty)
451
452

	_ -> panic "cmTypeOfName"
453
454
455
456

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

457
458
cmCompileExpr :: CmState -> String -> IO (Maybe HValue)
cmCompileExpr cmstate expr
459
   = do 
460
461
        maybe_stuff 
	    <- hscStmt (cm_hsc cmstate) (cm_ic cmstate)
462
		       ("let __cmCompileExpr = "++expr)
463
464

        case maybe_stuff of
465
	   Nothing -> return Nothing
466
	   Just (new_ic, names, hval) -> do
467

468
469
			-- Run it!
		hvals <- (unsafeCoerce# hval) :: IO [HValue]
470

471
		case (names,hvals) of
472
		  ([n],[hv]) -> return (Just hv)
473
		  _ 	     -> panic "cmCompileExpr"
474

475
476
477
478
479
480
481
482
483
#endif /* GHCI */
\end{code}


%************************************************************************
%*									*
	Loading and unloading
%*									*
%************************************************************************
484

485
\begin{code}
486
487
488
-----------------------------------------------------------------------------
-- Unload the compilation manager's state: everything it knows about the
-- current collection of modules in the Home package.
489

490
491
cmUnload :: CmState -> IO CmState
cmUnload state@CmState{ cm_hsc = hsc_env }
492
 = do -- Throw away the old home dir cache
493
      flushFinderCache
494
495

      -- Unload everything the linker knows about
496
      cm_unload hsc_env []
497
498

      -- Start with a fresh CmState, but keep the PersistentCompilerState
499
      return (discardCMInfo state)
500

501
cm_unload hsc_env stable_linkables	-- Unload everthing *except* 'stable_linkables'
502
503
  = case hsc_mode hsc_env of
	Batch -> return ()
504
#ifdef GHCI
505
	Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
506
#else
507
	Interactive -> panic "cm_unload: no interpreter"
508
#endif
509
	other -> panic "cm_unload: strange mode"
510
    
511
512
513
514
515

-----------------------------------------------------------------------------
-- Trace dependency graph

-- This is a seperate pass so that the caller can back off and keep
516
517
518
519
520
521
-- the current state if the downsweep fails.  Typically the caller
-- might go	cmDepAnal
--		cmUnload
--		cmLoadModules
-- He wants to do the dependency analysis before the unload, so that
-- if the former fails he can use the later
522

523
524
cmDepAnal :: CmState -> [FilePath] -> IO ModuleGraph
cmDepAnal cmstate rootnames
525
  = do showPass dflags "Chasing dependencies"
526
       when (verbosity dflags >= 1 && gmode == Batch) $
527
           hPutStrLn stderr (showSDoc (hcat [
528
	     text "Chasing modules from: ",
529
	     hcat (punctuate comma (map text rootnames))]))
530
       cmDownsweep dflags rootnames (cm_mg cmstate) []
531
532
533
534
  where
    hsc_env = cm_hsc cmstate
    dflags  = hsc_dflags hsc_env
    gmode   = hsc_mode hsc_env
535

536
537
538
539
-----------------------------------------------------------------------------
-- 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.
540

541
cmLoadModules :: CmState 		-- The HPT may not be as up to date
542
              -> ModuleGraph		-- Bang up to date; but may contain hi-boot no
543
544
545
              -> IO (CmState,		-- new state
		     SuccessFlag,	-- was successful
		     [String])		-- list of modules loaded
546

547
cmLoadModules cmstate1 mg2unsorted
548
   = do -- version 1's are the original, before downsweep
549
550
551
552
	let hsc_env   = cm_hsc cmstate1
        let hpt1      = hsc_HPT hsc_env
        let ghci_mode = hsc_mode   hsc_env -- this never changes
        let dflags    = hsc_dflags hsc_env -- this never changes
553
        let verb      = verbosity dflags
554

555
556
	-- The "bad" boot modules are the ones for which we have
	-- B.hs-boot in the module graph, but no B.hs
557
558
	-- The downsweep should have ensured this does not happen
	-- (see msDeps)
559
560
561
        let all_home_mods = [ms_mod s | s <- mg2unsorted, not (isBootSummary s)]
	    bad_boot_mods = [s 	      | s <- mg2unsorted, isBootSummary s,
					not (ms_mod s `elem` all_home_mods)]
562
563
	ASSERT( null bad_boot_mods ) return ()

564
        -- Do the downsweep to reestablish the module graph
565
566
        -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes
        let mg2 :: [SCC ModSummary]
567
	    mg2 = cmTopSort False mg2unsorted
568
569
570

        -- mg2_with_srcimps drops the hi-boot nodes, returning a 
	-- graph with cycles.  Among other things, it is used for
571
        -- backing out partially complete cycles following a failed
572
        -- upsweep, and for removing from hpt all the modules
573
        -- not in strict downwards closure, during calls to compile.
574
        let mg2_with_srcimps :: [SCC ModSummary]
575
	    mg2_with_srcimps = cmTopSort True mg2unsorted
576

577
	-- Sort out which linkables we wish to keep in the unlinked image.
578
	-- See getValidLinkables below for details.
579
	(valid_old_linkables, new_linkables)
580
	    <- getValidLinkables ghci_mode (hptLinkables hpt1)
581
		  all_home_mods mg2_with_srcimps
582
583
584

	-- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables]))

585
586
587
588
	-- The new_linkables are .o files we found on the disk, presumably
	-- as a result of a GHC run "on the side".  So we'd better forget
	-- everything we know abouut those modules!
	let old_hpt = delModuleEnvList hpt1 (map linkableModule new_linkables)
589
590

	-- When (verb >= 2) $
591
        --    putStrLn (showSDoc (text "Valid linkables:" 
592
        -- 			 <+> ppr valid_linkables))
593

594
595
596
597
598
599
600
601
        -- 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
602
        -- 2.  A valid old linkable exists for each module in ms
603

604
605
606
	-- mg2_with_srcimps has no hi-boot nodes, 
	-- and hence neither does stable_mods 
        stable_summaries <- preUpsweep valid_old_linkables
607
		 		       all_home_mods [] mg2_with_srcimps
608
609
610
        let stable_mods      = map ms_mod stable_summaries
	    stable_linkables = filter (\m -> linkableModule m `elem` stable_mods) 
				      valid_old_linkables
611

612
613
614
615
616
617
618
619
	    stable_hpt = filterModuleEnv is_stable_hm hpt1
	    is_stable_hm hm_info = mi_module (hm_iface hm_info) `elem` stable_mods

            upsweep_these
               = filter (\scc -> any (`notElem` stable_mods) 
                                     (map ms_mod (flattenSCC scc)))
                        mg2

620
        when (verb >= 2) $
621
           hPutStrLn stderr (showSDoc (text "Stable modules:" 
622
                               <+> sep (map (text.moduleUserString) stable_mods)))
623

624
625
	-- Unload any modules which are going to be re-linked this time around.
	cm_unload hsc_env stable_linkables
626

627
	-- We can now glom together our linkable sets
628
629
	let valid_linkables = valid_old_linkables ++ new_linkables

630
        -- We could at this point detect cycles which aren't broken by
631
632
        -- a source-import, and complain immediately, but it seems better
        -- to let upsweep_mods do this, so at least some useful work gets
633
        -- done before the upsweep is abandoned.
634
635
        --hPutStrLn stderr "after tsort:\n"
        --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
636
637
638
639
640

        -- 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.
641
642
643
644

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

645
	-- clean up between compilations
646
	let cleanup = cleanTempFilesExcept dflags
647
			  (ppFilesFromSummaries (flattenSCCs mg2))
648

649
        (upsweep_ok, hsc_env3, modsUpswept)
650
651
           <- upsweep_mods (hsc_env { hsc_HPT = stable_hpt })
			   (old_hpt, valid_linkables)
652
                           cleanup upsweep_these
653

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

658
	-- Make modsDone be the summaries for each home module now
659
	-- available; this should equal the domain of hpt3.
660
661
662
663
	-- (NOT STRICTLY TRUE if an interactive session was started
	--  with some object on disk ???)
        -- Get in in a roughly top .. bottom order (hence reverse).

664
        let modsDone = reverse modsUpswept ++ stable_summaries
665

666
667
668
        -- Try and do linking in some form, depending on whether the
        -- upsweep was completely or only partially successful.

669
        if succeeded upsweep_ok
670
671

         then 
672
           -- Easy; just relink it all.
673
           do when (verb >= 2) $ 
674
		 hPutStrLn stderr "Upsweep completely successful."
675

676
	      -- Clean up after ourselves
677
	      cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
678

679
680
681
682
683
684
685

	      -- Issue a warning for the confusing case where the user
	      -- said '-o foo' but we're not going to do any linking.
	      -- We attempt linking if either (a) one of the modules is
	      -- called Main, or (b) the user said -no-hs-main, indicating
	      -- that main() is going to come from somewhere else.
	      --
686
687
688
689
690
691
692
693
694
695
	      ofile       <- readIORef v_Output_file
	      no_hs_main  <- readIORef v_NoHsMain
	      mb_main_mod <- readIORef v_MainModIs
	      let 
	 	main_mod = mb_main_mod `orElse` "Main"
		a_root_is_Main 
               	    = any ((==main_mod).moduleUserString.ms_mod) 
                    	  mg2unsorted
		do_linking = a_root_is_Main || no_hs_main

696
	      when (ghci_mode == Batch && isJust ofile && not do_linking
697
		     && verb > 0) $
698
699
700
	         hPutStrLn stderr ("Warning: output was redirected with -o, " ++
				   "but no output will be generated\n" ++
				   "because there is no " ++ main_mod ++ " module.")
701

702
	      -- link everything together
703
              linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3)
704

705
706
	      let cmstate3 = cmstate1 { cm_mg = modsDone, cm_hsc = hsc_env3 }
	      cmLoadFinish Succeeded linkresult cmstate3
707
708

         else 
709
710
711
           -- 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.
712
713
           do when (verb >= 2) $
		hPutStrLn stderr "Upsweep partially successful."
714
715

              let modsDone_names
716
                     = map ms_mod modsDone
717
              let mods_to_zap_names 
718
719
                     = findPartiallyCompletedCycles modsDone_names 
			  mg2_with_srcimps
720
              let mods_to_keep
721
                     = filter ((`notElem` mods_to_zap_names).ms_mod) 
722
			  modsDone
723

724
              let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep) 
725
					      (hsc_HPT hsc_env3)
726

727
	      -- Clean up after ourselves
728
	      cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
729

730
	      -- Link everything together
731
              linkresult <- link ghci_mode dflags False hpt4
732

733
734
735
	      let cmstate3 = cmstate1 { cm_mg = mods_to_keep,
					cm_hsc = hsc_env3 { hsc_HPT = hpt4 } }
	      cmLoadFinish Failed linkresult cmstate3
736
737

-- Finish up after a cmLoad.
738
739

-- If the link failed, unload everything and return.
740
741
742
cmLoadFinish ok Failed cmstate
  = do cm_unload (cm_hsc cmstate) []
       return (discardCMInfo cmstate, Failed, [])
743

744
745
-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
746
747
cmLoadFinish ok Succeeded cmstate
  = do let new_cmstate = cmstate { cm_ic = emptyInteractiveContext }
748
           mods_loaded = map (moduleUserString.ms_mod) 
749
			     (cm_mg cmstate)
750
751

       return (new_cmstate, ok, mods_loaded)
752

753
754
755
-- used to fish out the preprocess output files for the purposes of
-- cleaning up.  The preprocessed file *might* be the same as the
-- source file, but that doesn't do any harm.
756
ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
757

758
-----------------------------------------------------------------------------
759
-- getValidLinkables
760

761
762
-- For each module (or SCC of modules), we take:
--
763
764
--	- an on-disk linkable, if this is the first time around and one
--	  is available.
765
--
766
767
--	- the old linkable, otherwise (and if one is available).
--
768
769
770
771
772
-- and we throw away the linkable if it is older than the source file.
-- In interactive mode, we also ignore the on-disk linkables unless
-- all of the dependents of this SCC also have on-disk linkables (we
-- can't have dynamically loaded objects that depend on interpreted
-- modules in GHCi).
773
774
775
776
777
778
779
--
-- 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.

780
getValidLinkables
781
782
	:: GhciMode
	-> [Linkable]		-- old linkables
783
	-> [Module]		-- all home modules
784
	-> [SCC ModSummary]	-- all modules in the program, dependency order
785
	-> IO ( [Linkable],	-- still-valid linkables 
786
787
		[Linkable] 	-- new linkables we just found on the disk
				-- presumably generated by separate run of ghc
788
789
	      )

790
791
792
793
794
795
getValidLinkables mode old_linkables all_home_mods module_graph
  = do	{ 	-- Process the SCCs in bottom-to-top order
		-- (foldM works left-to-right)
	  ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods) 
	  	      [] module_graph
	; return (partition_it ls [] []) }
796
797
798
799
800
 where
  partition_it []         valid new = (valid,new)
  partition_it ((l,b):ls) valid new 
	| b         = partition_it ls valid (l:new)
	| otherwise = partition_it ls (l:valid) new
801
802


803
804
805
806
807
808
809
810
getValidLinkablesSCC
	:: GhciMode
	-> [Linkable]		-- old linkables
	-> [Module]		-- all home modules
	-> [(Linkable,Bool)]
	-> SCC ModSummary
	-> IO [(Linkable,Bool)]

811
getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0
812
813
   = let 
	  scc             = flattenSCC scc0
814
          scc_names       = map ms_mod scc
815
	  home_module m   = m `elem` all_home_mods && m `notElem` scc_names
816
          scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc))
817
		-- NB. ms_imps, not ms_allimps above.  We don't want to
818
819
		-- force a module's SOURCE imports to be already compiled for
		-- its object linkable to be valid.
820

821
822
823
824
		-- The new_linkables is only the *valid* linkables below here
	  has_object m = case findModuleLinkable_maybe (map fst new_linkables) m of
			    Nothing -> False
			    Just l  -> isObjectLinkable l
825

826
          objects_allowed = mode == Batch || all has_object scc_allhomeimps
827
828
     in do

829
     new_linkables'
830
831
832
833
834
	<- 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.
835
836
837
838
839
     new_linkables' <- 
        if objects_allowed
	     && not (all isObjectLinkable (map fst new_linkables'))
	  then foldM (getValidLinkable old_linkables False) [] scc
	  else return new_linkables'
840

841
     return (new_linkables ++ new_linkables')
842
843


844
845
getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary 
	-> IO [(Linkable,Bool)]
846
847
848
	-- True <=> linkable is new; i.e. freshly discovered on the disk
	--				  presumably generated 'on the side'
	--				  by a separate GHC run
849
getValidLinkable old_linkables objects_allowed new_linkables summary 
850
851
852
853
	-- 'objects_allowed' says whether we permit this module to
	-- have a .o-file linkable.  We only permit it if all the
	-- modules it depends on also have .o files; a .o file can't
	-- link to a bytecode module
854
   = do let mod_name = ms_mod summary
855

856
	maybe_disk_linkable
857
          <- if (not objects_allowed)
858
		then return Nothing
859

860
		else findLinkable mod_name (ms_location summary)
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894

	let old_linkable = findModuleLinkable_maybe old_linkables mod_name

	    new_linkables' = 
	     case (old_linkable, maybe_disk_linkable) of
		(Nothing, Nothing)			-> []

		-- new object linkable just appeared
		(Nothing, Just l)			-> up_to_date l True

		(Just l,  Nothing)
		  | isObjectLinkable l			-> []
		    -- object linkable disappeared!  In case we need to
		    -- relink the module, disregard the old linkable and
		    -- just interpret the module from now on.
		  | otherwise				-> up_to_date l False
		    -- old byte code linkable

		(Just l, Just l') 
		  | not (isObjectLinkable l)		-> up_to_date l  False
		    -- if the previous linkable was interpreted, then we
		    -- ignore a newly compiled version, because the version
		    -- numbers in the interface file will be out-of-sync with
		    -- our internal ones.
		  | linkableTime l' >  linkableTime l   -> up_to_date l' True
		  | linkableTime l' == linkableTime l   -> up_to_date l  False
		  | otherwise			        -> []
		    -- on-disk linkable has been replaced by an older one!
		    -- again, disregard the previous one.

	    up_to_date l b
		| linkableTime l < ms_hs_date summary = []
		| otherwise = [(l,b)]
		-- why '<' rather than '<=' above?  If the filesystem stores
895
896
897
898
899
		-- 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.
900

901
	return (new_linkables' ++ new_linkables)
902
903


904
905
906
907
908
hptLinkables :: HomePackageTable -> [Linkable]
-- Get all the linkables from the home package table, one for each module
-- Once the HPT is up to date, these are the ones we should link
hptLinkables hpt = map hm_linkable (moduleEnvElts hpt)

909

910
-----------------------------------------------------------------------------
911
-- Do a pre-upsweep without use of "compile", to establish a 
912
-- (downward-closed) set of stable modules for which we won't call compile.
913

914
915
916
-- a stable module:
--	* has a valid linkable (see getValidLinkables above)
--	* depends only on stable modules
917
--	* has an interface in the HPT (interactive mode only)
918

919
preUpsweep :: [Linkable]	-- new valid linkables
920
           -> [Module]		-- names of all mods encountered in downsweep
921
           -> [ModSummary]	-- accumulating stable modules
922
           -> [SCC ModSummary]  -- scc-ified mod graph, including src imps
923
           -> IO [ModSummary]	-- stable modules
924

925
926
preUpsweep valid_lis all_home_mods stable []  = return stable
preUpsweep valid_lis all_home_mods stable (scc0:sccs)
927
   = do let scc = flattenSCC scc0
928
            scc_allhomeimps :: [Module]
929
930
931
932
            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
933
934
935
	    scc_mods     = map ms_mod scc
            stable_names = scc_mods ++ map ms_mod stable
            in_stable_or_scc m = m `elem` stable_names
936

937
	    -- now we check for valid linkables: each module in the SCC must 
938
	    -- have a valid linkable (see getValidLinkables above).
939
940
	    has_valid_linkable scc_mod
   	      = isJust (findModuleLinkable_maybe valid_lis scc_mod)
941

942
	    scc_is_stable = all_imports_in_scc_or_stable
943
			  && all has_valid_linkable scc_mods
944
945

        if scc_is_stable
946
947
         then preUpsweep valid_lis all_home_mods (scc ++ stable) sccs
         else preUpsweep valid_lis all_home_mods stable 	 sccs
948
949


950
951
-- Return (names of) all those in modsDone who are part of a cycle
-- as defined by theGraph.
952
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
953
954
955
956
957
958
findPartiallyCompletedCycles modsDone theGraph
   = chew theGraph
     where
        chew [] = []
        chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
        chew ((CyclicSCC vs):rest)
959
           = let names_in_this_cycle = nub (map ms_mod vs)
960
961
962
963
964
                 mods_in_this_cycle  
                    = nub ([done | done <- modsDone, 
                                   done `elem` names_in_this_cycle])
                 chewed_rest = chew rest
             in 
sof's avatar
sof committed
965
             if   notNull mods_in_this_cycle
966
                  && length mods_in_this_cycle < length names_in_this_cycle
967
968
             then mods_in_this_cycle ++ chewed_rest
             else chewed_rest
969
970


971
972
-- Compile multiple modules, stopping as soon as an error appears.
-- There better had not be any cyclic groups here -- we check for them.
973
974
975
976
upsweep_mods :: HscEnv				-- Includes initially-empty HPT
             -> (HomePackageTable, [Linkable])	-- HPT and valid linkables from last time round
	     -> IO ()				-- How to clean up unwanted tmp files
             -> [SCC ModSummary]		-- Mods to do (the worklist)
977
             -> IO (SuccessFlag,
978
                    HscEnv,		-- With an updated HPT
979
                    [ModSummary])	-- Mods which succeeded
980

981
upsweep_mods hsc_env oldUI cleanup
982
     []
983
   = return (Succeeded, hsc_env, [])
984

985
986
upsweep_mods hsc_env oldUI cleanup
     (CyclicSCC ms:_)
987
   = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
988
        return (Failed, hsc_env, [])
989

990
upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup
991
     (AcyclicSCC mod:mods)
992