GHC.hs 67.8 KB
Newer Older
1
-- -----------------------------------------------------------------------------
2
--
3
-- (c) The University of Glasgow, 2005
4 5 6
--
-- The GHC API
--
7
-- -----------------------------------------------------------------------------
8 9 10

module GHC (
	-- * Initialisation
11
	Session,
12 13 14 15 16
	defaultErrorHandler,
	defaultCleanupHandler,
	newSession,

	-- * Flags and settings
17
	DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
18
        GhcMode(..), GhcLink(..), defaultObjectTarget,
19
	parseDynamicFlags,
20 21
	getSessionDynFlags,
	setSessionDynFlags,
22 23

	-- * Targets
24
	Target(..), TargetId(..), Phase,
25 26 27
	setTargets,
	getTargets,
	addTarget,
28
	removeTarget,
29 30
	guessTarget,
	
31 32 33 34 35 36
        -- * Extending the program scope 
        extendGlobalRdrScope,  -- :: Session -> [GlobalRdrElt] -> IO ()
        setGlobalRdrScope,     -- :: Session -> [GlobalRdrElt] -> IO ()
        extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
        setGlobalTypeScope,    -- :: Session -> [Id] -> IO ()

37
	-- * Loading\/compiling the program
38
	depanal,
39
	load, LoadHowMuch(..), SuccessFlag(..),	-- also does depanal
40
	workingDirectoryChanged,
41
	checkModule, CheckedModule(..),
42
	TypecheckedSource, ParsedSource, RenamedSource,
43

44 45 46
	-- * Parsing Haddock comments
	parseHaddockComment,

47
	-- * Inspecting the module structure of the program
Simon Marlow's avatar
Simon Marlow committed
48
	ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
49
	getModuleGraph,
50
	isLoaded,
51 52
	topSortModuleGraph,

53 54 55 56
	-- * Inspecting modules
	ModuleInfo,
	getModuleInfo,
	modInfoTyThings,
57
	modInfoTopLevelScope,
58 59
	modInfoPrintUnqualified,
	modInfoExports,
60
	modInfoInstances,
61 62
	modInfoIsExportedName,
	modInfoLookupName,
63
	lookupGlobalName,
64

65 66 67
	-- * Printing
	PrintUnqualified, alwaysQualify,

68 69
	-- * Interactive evaluation
	getBindings, getPrintUnqual,
Simon Marlow's avatar
Simon Marlow committed
70
        findModule,
71 72
#ifdef GHCI
	setContext, getContext,	
73
	getNamesInScope,
Simon Marlow's avatar
Simon Marlow committed
74
	getRdrNamesInScope,
75
	moduleIsInterpreted,
76
	getInfo,
77 78
	exprType,
	typeKind,
79
	parseName,
80
	RunResult(..),  
81 82 83 84 85
	runStmt, SingleStep(..),
        resume,
        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
               resumeHistory, resumeHistoryIx),
        History(historyBreakInfo), getHistorySpan,
86 87
        getResumeContext,
        abandon, abandonAll,
88 89
        InteractiveEval.back,
        InteractiveEval.forward,
90
	showModule,
91
        isModuleInterpreted,
ei@vuokko.info's avatar
ei@vuokko.info committed
92
	compileExpr, HValue, dynCompileExpr,
93
	lookupName,
mnislaih's avatar
mnislaih committed
94
        obtainTerm, obtainTerm1,
95
        modInfoModBreaks,
96 97
        ModBreaks(..), BreakIndex,
        BreakInfo(breakInfo_number, breakInfo_module),
98
        BreakArray, setBreakOn, setBreakOff, getBreak,
99 100 101
#endif

	-- * Abstract syntax elements
102

Simon Marlow's avatar
Simon Marlow committed
103 104 105
        -- ** Packages
        PackageId,

106
	-- ** Modules
Simon Marlow's avatar
Simon Marlow committed
107 108
	Module, mkModule, pprModule, moduleName, modulePackageId,
        ModuleName, mkModuleName, moduleNameString,
109

110
	-- ** Names
111
	Name, 
112
	nameModule, pprParenSymName, nameSrcLoc,
113
	NamedThing(..),
Simon Marlow's avatar
Simon Marlow committed
114
	RdrName(Qual,Unqual),
115 116
	
	-- ** Identifiers
117
	Id, idType,
118
	isImplicitId, isDeadBinder,
119
	isExportedId, isLocalId, isGlobalId,
120
	isRecordSelector,
121
	isPrimOpId, isFCallId, isClassOpId_maybe,
122 123
	isDataConWorkId, idDataCon,
	isBottomingId, isDictonaryId,
124
	recordSelectorFieldLabel,
125 126 127

	-- ** Type constructors
	TyCon, 
128
	tyConTyVars, tyConDataCons, tyConArity,
129
	isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
130 131
	isOpenTyCon,
	synTyConDefn, synTyConType, synTyConResKind,
132

133 134 135 136
	-- ** Type variables
	TyVar,
	alphaTyVars,

137 138
	-- ** Data constructors
	DataCon,
139 140 141 142
	dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
	dataConIsInfix, isVanillaDataCon,
	dataConStrictMarks,  
	StrictnessMark(..), isMarkedStrict,
143 144 145

	-- ** Classes
	Class, 
146 147
	classMethods, classSCTheta, classTvsFds,
	pprFundeps,
148

149
	-- ** Instances
150
	Instance, 
151
	instanceDFunId, pprInstance, pprInstanceHdr,
152

153
	-- ** Types and Kinds
154 155
	Type, dropForAlls, splitForAllTys, funResultTy, 
	pprParendType, pprTypeApp,
156
	Kind,
157 158
	PredType,
	ThetaType, pprThetaArrow,
159 160

	-- ** Entities
161 162
	TyThing(..), 

163 164 165
	-- ** Syntax
	module HsSyn, -- ToDo: remove extraneous bits

166 167 168 169 170 171 172 173
	-- ** Fixities
	FixityDirection(..), 
	defaultFixity, maxPrecedence, 
	negateFixity,
	compareFixity,

	-- ** Source locations
	SrcLoc, pprDefnLoc,
Simon Marlow's avatar
Simon Marlow committed
174 175 176 177 178 179 180 181
        mkSrcLoc, isGoodSrcLoc,
	srcLocFile, srcLocLine, srcLocCol,
        SrcSpan,
        mkSrcSpan, srcLocSpan,
        srcSpanStart, srcSpanEnd,
	srcSpanFile, 
        srcSpanStartLine, srcSpanEndLine, 
        srcSpanStartCol, srcSpanEndCol,
182

183 184 185 186
	-- * Exceptions
	GhcException(..), showGhcException,

	-- * Miscellaneous
187 188
	sessionHscEnv,
	cyclicModuleErr,
189 190
  ) where

191 192 193
{-
 ToDo:

194
  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
195 196 197 198 199 200
  * what StaticFlags should we expose, if any?
-}

#include "HsVersions.h"

#ifdef GHCI
mnislaih's avatar
mnislaih committed
201
import qualified Linker
202
import Linker           ( HValue )
203
import ByteCodeInstr
204
import BreakArray
205 206 207
import NameSet
import TcRnDriver
import InteractiveEval
208 209
#endif

210 211 212
import Packages
import NameSet
import RdrName
213
import HsSyn 
214
import Type             hiding (typeKind)
215
import TcType           hiding (typeKind)
216 217
import Id
import Var              hiding (setIdType)
218
import TysPrim		( alphaTyVars )
219 220 221 222 223
import TyCon
import Class
import FunDeps
import DataCon
import Name             hiding ( varName )
224
import OccName		( parenSymOcc )
225
import InstEnv		( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
226
import SrcLoc
227 228
import DriverPipeline
import DriverPhases	( Phase(..), isHaskellSrcFilename, startPhase )
229
import HeaderInfo	( getImports, getOptions )
230
import Finder
231
import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )
232 233
import HscTypes
import DynFlags
234 235
import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                      cleanTempDirs )
236
import Module
Simon Marlow's avatar
Simon Marlow committed
237
import UniqFM
238 239
import UniqSet
import Unique
240
import PackageConfig
241 242
import FiniteMap
import Panic
243
import Digraph
244
import Bag		( unitBag, listToBag )
245
import ErrUtils		( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
246 247
			  mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
			  WarnMsg )
248
import qualified ErrUtils
249
import Util
250
import StringBuffer	( StringBuffer, hGetStringBuffer )
251
import Outputable
252
import BasicTypes
253
import Maybes		( expectJust, mapCatMaybes )
254
import HaddockParse
255
import HaddockLex       ( tokenise )
256 257 258

import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
259 260
import Data.Maybe
import Data.List
261
import qualified Data.List as List
262
import Control.Monad
263 264 265 266 267
import System.Exit	( exitWith, ExitCode(..) )
import System.Time	( ClockTime )
import Control.Exception as Exception hiding (handle)
import Data.IORef
import System.IO
268
import System.IO.Error	( isDoesNotExistError )
269
import Prelude hiding (init)
270

271 272 273 274 275 276
#if __GLASGOW_HASKELL__ < 600
import System.IO as System.IO.Error ( try )
#else
import System.IO.Error	( try )
#endif

277
-- -----------------------------------------------------------------------------
278
-- Exception handlers
279 280 281 282 283

-- | Install some default exception handlers and run the inner computation.
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program.  The default handlers output the error
-- message(s) to stderr and exit cleanly.
284 285
defaultErrorHandler :: DynFlags -> IO a -> IO a
defaultErrorHandler dflags inner = 
286 287 288 289 290
  -- top-level exception handler: any unrecognised exception is a compiler bug.
  handle (\exception -> do
  	   hFlush stdout
	   case exception of
		-- an IO exception probably isn't our fault, so don't panic
291 292
		IOException _ ->
		  fatalErrorMsg dflags (text (show exception))
293
		AsyncException StackOverflow ->
294 295 296
		  fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
		_other ->
		  fatalErrorMsg dflags (text (show (Panic (show exception))))
297 298 299
	   exitWith (ExitFailure 1)
         ) $

300 301
  -- program errors: messages with locations attached.  Sometimes it is
  -- convenient to just throw these as exceptions.
302
  handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
303 304 305
			exitWith (ExitFailure 1)) $

  -- error messages propagated as exceptions
306 307 308 309 310
  handleDyn (\dyn -> do
  		hFlush stdout
  		case dyn of
		     PhaseFailed _ code -> exitWith code
		     Interrupted -> exitWith (ExitFailure 1)
311
		     _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
312 313 314 315 316 317 318 319
			     exitWith (ExitFailure 1)
	    ) $
  inner

-- | Install a default cleanup handler to remove temporary files
-- deposited by a GHC run.  This is seperate from
-- 'defaultErrorHandler', because you might want to override the error
-- handling, but still get the ordinary cleanup behaviour.
320 321
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner = 
322
    -- make sure we clean up after ourselves
323 324
    later (do cleanTempFiles dflags
              cleanTempDirs dflags
325 326 327 328 329
          )
          -- exceptions will be blocked while we clean the temporary files,
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
    inner
330 331 332 333


-- | Starts a new session.  A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
334 335
newSession :: Maybe FilePath -> IO Session
newSession mb_top_dir = do
336 337
  -- catch ^C
  main_thread <- myThreadId
338
  modifyMVar_ interruptTargetThread (return . (main_thread :))
339 340 341 342
  installSignalHandlers

  dflags0 <- initSysTools mb_top_dir defaultDynFlags
  dflags  <- initDynFlags dflags0
343
  env <- newHscEnv dflags
344
  ref <- newIORef env
345 346 347 348 349 350 351
  return (Session ref)

-- tmp: this breaks the abstraction, but required because DriverMkDepend
-- needs to call the Finder.  ToDo: untangle this.
sessionHscEnv :: Session -> IO HscEnv
sessionHscEnv (Session ref) = readIORef ref

352 353 354 355 356
-- -----------------------------------------------------------------------------
-- Flags & settings

-- | Grabs the DynFlags from the Session
getSessionDynFlags :: Session -> IO DynFlags
357
getSessionDynFlags s = withSession s (return . hsc_dflags)
358

359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
-- | Updates the DynFlags in a Session.  This also reads
-- the package database (unless it has already been read),
-- and prepares the compilers knowledge about packages.  It
-- can be called again to load new packages: just add new
-- package flags to (packageFlags dflags).
--
-- Returns a list of new packages that may need to be linked in using
-- the dynamic linker (see 'linkPackages') as a result of new package
-- flags.  If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
setSessionDynFlags (Session ref) dflags = do
  hsc_env <- readIORef ref
  (dflags', preload) <- initPackages dflags
  writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
  return preload
376

377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: Session -> IO ()
guessOutputFile s = modifySession s $ \env ->
    let dflags = hsc_dflags env
        mod_graph = hsc_mod_graph env
        mainModuleSrcPath, guessedName :: Maybe String
        mainModuleSrcPath = do
            let isMain = (== mainModIs dflags) . ms_mod
            [ms] <- return (filter isMain mod_graph)
            ml_hs_file (ms_location ms)
        guessedName = fmap basenameOf mainModuleSrcPath
    in
    case outputFile dflags of
        Just _ -> env
        Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }

394
-- -----------------------------------------------------------------------------
395
-- Targets
396 397 398 399 400 401

-- ToDo: think about relative vs. absolute file paths. And what
-- happens when the current directory changes.

-- | Sets the targets for this session.  Each target may be a module name
-- or a filename.  The targets correspond to the set of root modules for
402
-- the program\/library.  Unloading the current program is achieved by
403
-- setting the current set of targets to be empty, followed by load.
404
setTargets :: Session -> [Target] -> IO ()
405
setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
406 407

-- | returns the current set of targets
408 409
getTargets :: Session -> IO [Target]
getTargets s = withSession s (return . hsc_targets)
410

411
-- | Add another target
412 413 414
addTarget :: Session -> Target -> IO ()
addTarget s target
  = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
415

416 417 418 419 420 421
-- | Remove a target
removeTarget :: Session -> TargetId -> IO ()
removeTarget s target_id
  = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
  where
   filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
422

423 424 425 426 427 428 429 430 431
-- Attempts to guess what Target a string refers to.  This function implements
-- the --make/GHCi command-line syntax for filenames: 
--
-- 	- if the string looks like a Haskell source filename, then interpret
--	  it as such
--	- if adding a .hs or .lhs suffix yields the name of an existing file,
--	  then use that
-- 	- otherwise interpret the string as a module name
--
432 433 434 435
guessTarget :: String -> Maybe Phase -> IO Target
guessTarget file (Just phase)
   = return (Target (TargetFile file (Just phase)) Nothing)
guessTarget file Nothing
436
   | isHaskellSrcFilename file
437
   = return (Target (TargetFile file Nothing) Nothing)
438 439
   | otherwise
   = do exists <- doesFileExist hs_file
440 441 442
	if exists
	   then return (Target (TargetFile hs_file Nothing) Nothing)
	   else do
443
	exists <- doesFileExist lhs_file
444 445 446
	if exists
	   then return (Target (TargetFile lhs_file Nothing) Nothing)
	   else do
Simon Marlow's avatar
Simon Marlow committed
447
	return (Target (TargetModule (mkModuleName file)) Nothing)
448
     where 
449 450
	 hs_file  = file `joinFileExt` "hs"
	 lhs_file = file `joinFileExt` "lhs"
451

452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476
-- -----------------------------------------------------------------------------
-- Extending the program scope

extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
extendGlobalRdrScope session rdrElts
    = modifySession session $ \hscEnv ->
      let global_rdr = hsc_global_rdr_env hscEnv
      in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }

setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
setGlobalRdrScope session rdrElts
    = modifySession session $ \hscEnv ->
      hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }

extendGlobalTypeScope :: Session -> [Id] -> IO ()
extendGlobalTypeScope session ids
    = modifySession session $ \hscEnv ->
      let global_type = hsc_global_type_env hscEnv
      in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }

setGlobalTypeScope :: Session -> [Id] -> IO ()
setGlobalTypeScope session ids
    = modifySession session $ \hscEnv ->
      hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }

477 478 479 480 481 482
-- -----------------------------------------------------------------------------
-- Parsing Haddock comments

parseHaddockComment :: String -> Either String (HsDoc RdrName)
parseHaddockComment string = parseHaddockParagraphs (tokenise string)

483 484
-- -----------------------------------------------------------------------------
-- Loading the program
485

486 487
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
Simon Marlow's avatar
Simon Marlow committed
488
depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
489
depanal (Session ref) excluded_mods allow_dup_roots = do
490 491 492 493 494 495 496
  hsc_env <- readIORef ref
  let
	 dflags  = hsc_dflags hsc_env
	 targets = hsc_targets hsc_env
	 old_graph = hsc_mod_graph hsc_env
	
  showPass dflags "Chasing dependencies"
497 498 499
  debugTraceMsg dflags 2 (hcat [
	     text "Chasing modules from: ",
	     hcat (punctuate comma (map pprTarget targets))])
500

501
  r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
502
  case r of
503
    Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
504 505
    _ -> return ()
  return r
506

507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524
{-
-- | The result of load.
data LoadResult
  = LoadOk	Errors	-- ^ all specified targets were loaded successfully.
  | LoadFailed  Errors	-- ^ not all modules were loaded.

type Errors = [String]

data ErrMsg = ErrMsg { 
	errMsgSeverity  :: Severity,  -- warning, error, etc.
	errMsgSpans     :: [SrcSpan],
	errMsgShortDoc  :: Doc,
	errMsgExtraInfo :: Doc
	}
-}

data LoadHowMuch
   = LoadAllTargets
Simon Marlow's avatar
Simon Marlow committed
525 526
   | LoadUpTo ModuleName
   | LoadDependenciesOf ModuleName
527 528 529 530

-- | Try to load the program.  If a Module is supplied, then just
-- attempt to load up to this target.  If no Module is supplied,
-- then try to load all targets.
531
load :: Session -> LoadHowMuch -> IO SuccessFlag
532
load s@(Session ref) how_much
533
   = do 
534 535 536 537
	-- Dependency analysis first.  Note that this fixes the module graph:
	-- even if we don't get a fully successful upsweep, the full module
	-- graph is still retained in the Session.  We can tell which modules
	-- were successfully loaded by inspecting the Session's HPT.
538
	mb_graph <- depanal s [] False
539 540 541
	case mb_graph of	   
	   Just mod_graph -> load2 s how_much mod_graph 
	   Nothing        -> return Failed
542

543
load2 s@(Session ref) how_much mod_graph = do
544
        guessOutputFile s
545 546 547 548 549 550 551 552 553
	hsc_env <- readIORef ref

        let hpt1      = hsc_HPT hsc_env
        let dflags    = hsc_dflags hsc_env

	-- The "bad" boot modules are the ones for which we have
	-- B.hs-boot in the module graph, but no B.hs
	-- The downsweep should have ensured this does not happen
	-- (see msDeps)
Simon Marlow's avatar
Simon Marlow committed
554 555
        let all_home_mods = [ms_mod_name s 
			    | s <- mod_graph, not (isBootSummary s)]
556
#ifdef DEBUG
557
	    bad_boot_mods = [s 	      | s <- mod_graph, isBootSummary s,
Simon Marlow's avatar
Simon Marlow committed
558
					not (ms_mod_name s `elem` all_home_mods)]
559
#endif
560 561 562 563 564 565 566 567
	ASSERT( null bad_boot_mods ) return ()

        -- mg2_with_srcimps drops the hi-boot nodes, returning a 
	-- graph with cycles.  Among other things, it is used for
        -- backing out partially complete cycles following a failed
        -- upsweep, and for removing from hpt all the modules
        -- not in strict downwards closure, during calls to compile.
        let mg2_with_srcimps :: [SCC ModSummary]
568
	    mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
569

570 571 572 573 574
	-- If we can determine that any of the {-# SOURCE #-} imports
	-- are definitely unnecessary, then emit a warning.
	warnUnnecessarySourceImports dflags mg2_with_srcimps

 	let
575 576
	    -- check the stability property for each module.
	    stable_mods@(stable_obj,stable_bco)
577
	        = checkStability hpt1 mg2_with_srcimps all_home_mods
578 579 580 581 582 583 584 585 586

	    -- prune bits of the HPT which are definitely redundant now,
	    -- to save space.
	    pruned_hpt = pruneHomePackageTable hpt1 
				(flattenSCCs mg2_with_srcimps)
				stable_mods

	evaluate pruned_hpt

587 588
	debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
				text "Stable BCO:" <+> ppr stable_bco)
589 590

	-- Unload any modules which are going to be re-linked this time around.
591 592
	let stable_linkables = [ linkable
			       | m <- stable_obj++stable_bco,
Simon Marlow's avatar
Simon Marlow committed
593
				 Just hmi <- [lookupUFM pruned_hpt m],
594
				 Just linkable <- [hm_linkable hmi] ]
595 596 597 598 599 600 601 602 603 604 605 606
	unload hsc_env stable_linkables

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

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

607 608 609 610 611 612
        -- Topologically sort the module graph, this time including hi-boot
	-- nodes, and possibly just including the portion of the graph
	-- reachable from the module specified in the 2nd argument to load.
	-- This graph should be cycle-free.
	-- If we're restricting the upsweep to a portion of the graph, we
	-- also want to retain everything that is still stable.
613
        let full_mg :: [SCC ModSummary]
614
	    full_mg    = topSortModuleGraph False mod_graph Nothing
615 616 617

	    maybe_top_mod = case how_much of
				LoadUpTo m           -> Just m
618
			  	LoadDependenciesOf m -> Just m
619 620
			  	_		     -> Nothing

621 622 623 624 625 626 627 628 629
	    partial_mg0 :: [SCC ModSummary]
	    partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod

	    -- LoadDependenciesOf m: we want the upsweep to stop just
	    -- short of the specified module (unless the specified module
	    -- is stable).
	    partial_mg
		| LoadDependenciesOf mod <- how_much
		= ASSERT( case last partial_mg0 of 
Simon Marlow's avatar
Simon Marlow committed
630
			    AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
631 632 633 634
		  List.init partial_mg0
		| otherwise
		= partial_mg0
  
635 636 637
	    stable_mg = 
		[ AcyclicSCC ms
	        | AcyclicSCC ms <- full_mg,
Simon Marlow's avatar
Simon Marlow committed
638 639 640
		  ms_mod_name ms `elem` stable_obj++stable_bco,
		  ms_mod_name ms `notElem` [ ms_mod_name ms' | 
						AcyclicSCC ms' <- partial_mg ] ]
641 642 643

	    mg = stable_mg ++ partial_mg

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

648 649
	debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 
				   2 (ppr mg))
650 651
        (upsweep_ok, hsc_env1, modsUpswept)
           <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
652
			   pruned_hpt stable_mods cleanup mg
653 654 655 656 657

	-- Make modsDone be the summaries for each home module now
	-- available; this should equal the domain of hpt3.
        -- Get in in a roughly top .. bottom order (hence reverse).

658
        let modsDone = reverse modsUpswept
659 660 661 662 663 664 665 666

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

        if succeeded upsweep_ok

         then 
           -- Easy; just relink it all.
667
           do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
668 669 670 671 672 673 674 675 676 677 678 679 680

	      -- Clean up after ourselves
	      cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)

	      -- 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.
	      --
	      let ofile = outputFile dflags
	      let no_hs_main = dopt Opt_NoHsMain dflags
	      let 
681 682
	 	main_mod = mainModIs dflags
		a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
683 684
		do_linking = a_root_is_Main || no_hs_main

685 686 687 688 689 690 691
	      when (ghcLink dflags == LinkBinary 
                    && isJust ofile && not do_linking) $
	        debugTraceMsg dflags 1 $
                    text ("Warning: output was redirected with -o, " ++
                          "but no output will be generated\n" ++
			  "because there is no " ++ 
                          moduleNameString (moduleName main_mod) ++ " module.")
692 693

	      -- link everything together
694
              linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
695

696
	      loadFinish Succeeded linkresult ref hsc_env1
697 698 699 700 701

         else 
           -- 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.
702
           do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
703 704 705 706 707 708 709 710 711 712

              let modsDone_names
                     = map ms_mod modsDone
              let mods_to_zap_names 
                     = findPartiallyCompletedCycles modsDone_names 
			  mg2_with_srcimps
              let mods_to_keep
                     = filter ((`notElem` mods_to_zap_names).ms_mod) 
			  modsDone

Simon Marlow's avatar
Simon Marlow committed
713
              let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) 
714
					      (hsc_HPT hsc_env1)
715 716 717 718

	      -- Clean up after ourselves
	      cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)

719 720
	      -- there should be no Nothings where linkables should be, now
	      ASSERT(all (isJust.hm_linkable) 
Simon Marlow's avatar
Simon Marlow committed
721
			(eltsUFM (hsc_HPT hsc_env))) do
722
	
723
	      -- Link everything together
724
              linkresult <- link (ghcLink dflags) dflags False hpt4
725

726
	      let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742
	      loadFinish Failed linkresult ref hsc_env4

-- Finish up after a load.

-- If the link failed, unload everything and return.
loadFinish all_ok Failed ref hsc_env
  = do unload hsc_env []
       writeIORef ref $! discardProg hsc_env
       return Failed

-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
loadFinish all_ok Succeeded ref hsc_env
  = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
       return all_ok

743

744 745 746 747 748 749 750 751 752 753
-- Forget the current program, but retain the persistent info in HscEnv
discardProg :: HscEnv -> HscEnv
discardProg hsc_env
  = hsc_env { hsc_mod_graph = emptyMG, 
	      hsc_IC = emptyInteractiveContext,
	      hsc_HPT = emptyHomePackageTable }

-- 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.
754
ppFilesFromSummaries summaries = map ms_hspp_file summaries
755

756 757 758 759 760
-- -----------------------------------------------------------------------------
-- Check module

data CheckedModule = 
  CheckedModule { parsedSource      :: ParsedSource,
761
		  renamedSource     :: Maybe RenamedSource,
762 763 764
		  typecheckedSource :: Maybe TypecheckedSource,
		  checkedModuleInfo :: Maybe ModuleInfo
	        }
765 766 767 768 769
	-- ToDo: improvements that could be made here:
	--  if the module succeeded renaming but not typechecking,
	--  we can still get back the GlobalRdrEnv and exports, so
	--  perhaps the ModuleInfo should be split up into separate
	--  fields within CheckedModule.
770

771
type ParsedSource      = Located (HsModule RdrName)
772 773
type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
                          Maybe (HsDoc Name), HaddockModInfo Name)
774 775
type TypecheckedSource = LHsBinds Id

776 777 778 779 780 781 782 783 784 785 786 787 788
-- NOTE:
--   - things that aren't in the output of the typechecker right now:
--     - the export list
--     - the imports
--     - type signatures
--     - type/data/newtype declarations
--     - class declarations
--     - instances
--   - extra things in the typechecker's output:
--     - default methods are turned into top-level decls.
--     - dictionary bindings


789 790 791 792
-- | This is the way to get access to parsed and typechecked source code
-- for a module.  'checkModule' loads all the dependencies of the specified
-- module in the Session, and then attempts to typecheck the module.  If
-- successful, it returns the abstract syntax for the module.
Simon Marlow's avatar
Simon Marlow committed
793
checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
794
checkModule session@(Session ref) mod = do
795
	-- load up the dependencies first
796
   r <- load session (LoadDependenciesOf mod)
797 798 799 800 801
   if (failed r) then return Nothing else do

	-- now parse & typecheck the module
   hsc_env <- readIORef ref   
   let mg  = hsc_mod_graph hsc_env
Simon Marlow's avatar
Simon Marlow committed
802
   case [ ms | ms <- mg, ms_mod_name ms == mod ] of
803 804
	[] -> return Nothing
	(ms:_) -> do 
805
	   mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
806 807 808
	   case mbChecked of
             Nothing -> return Nothing
             Just (HscChecked parsed renamed Nothing) ->
809 810 811 812 813
		   return (Just (CheckedModule {
					parsedSource = parsed,
					renamedSource = renamed,
					typecheckedSource = Nothing,
					checkedModuleInfo = Nothing }))
814 815
             Just (HscChecked parsed renamed
			   (Just (tc_binds, rdr_env, details))) -> do
816
		   let minf = ModuleInfo {
817
				minf_type_env  = md_types details,
818 819
				minf_exports   = availsToNameSet $
                                                     md_exports details,
820 821
				minf_rdr_env   = Just rdr_env,
				minf_instances = md_insts details
mnislaih's avatar
mnislaih committed
822
#ifdef GHCI
823
                               ,minf_modBreaks = emptyModBreaks 
mnislaih's avatar
mnislaih committed
824
#endif
825 826 827
			      }
		   return (Just (CheckedModule {
					parsedSource = parsed,
828
					renamedSource = renamed,
829 830 831 832
					typecheckedSource = Just tc_binds,
					checkedModuleInfo = Just minf }))

-- ---------------------------------------------------------------------------
833 834 835 836
-- Unloading

unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables	-- Unload everthing *except* 'stable_linkables'
837
  = case ghcLink (hsc_dflags hsc_env) of
838
#ifdef GHCI
839
	LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
840
#else
841
	LinkInMemory -> panic "unload: no interpreter"
842
#endif
843
	other -> return ()
844

845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877
-- -----------------------------------------------------------------------------
-- checkStability

{-
  Stability tells us which modules definitely do not need to be recompiled.
  There are two main reasons for having stability:
  
   - avoid doing a complete upsweep of the module graph in GHCi when
     modules near the bottom of the tree have not changed.

   - to tell GHCi when it can load object code: we can only load object code
     for a module when we also load object code fo  all of the imports of the
     module.  So we need to know that we will definitely not be recompiling
     any of these modules, and we can use the object code.

  The stability check is as follows.  Both stableObject and
  stableBCO are used during the upsweep phase later.

  -------------------
  stable m = stableObject m || stableBCO m

  stableObject m = 
	all stableObject (imports m)
	&& old linkable does not exist, or is == on-disk .o
	&& date(on-disk .o) > date(.hs)

  stableBCO m =
	all stable (imports m)
	&& date(BCO) > date(.hs)
  -------------------    

  These properties embody the following ideas:

878
    - if a module is stable, then:
879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896
	- if it has been compiled in a previous pass (present in HPT)
	  then it does not need to be compiled or re-linked.
        - if it has not been compiled in a previous pass,
	  then we only need to read its .hi file from disk and
	  link it to produce a ModDetails.

    - if a modules is not stable, we will definitely be at least
      re-linking, and possibly re-compiling it during the upsweep.
      All non-stable modules can (and should) therefore be unlinked
      before the upsweep.

    - Note that objects are only considered stable if they only depend
      on other objects.  We can't link object code against byte code.
-}

checkStability
	:: HomePackageTable		-- HPT from last compilation
	-> [SCC ModSummary]		-- current module graph (cyclic)
Simon Marlow's avatar
Simon Marlow committed
897 898 899
	-> [ModuleName]			-- all home modules
	-> ([ModuleName],		-- stableObject
	    [ModuleName])		-- stableBCO
900 901 902 903 904 905 906 907 908

checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
  where
   checkSCC (stable_obj, stable_bco) scc0
     | stableObjects = (scc_mods ++ stable_obj, stable_bco)
     | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)
     | otherwise     = (stable_obj, stable_bco)
     where
	scc = flattenSCC scc0
Simon Marlow's avatar
Simon Marlow committed
909
	scc_mods = map ms_mod_name scc
910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930
	home_module m   = m `elem` all_home_mods && m `notElem` scc_mods

        scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
	    -- all imports outside the current SCC, but in the home pkg
	
	stable_obj_imps = map (`elem` stable_obj) scc_allimps
	stable_bco_imps = map (`elem` stable_bco) scc_allimps

	stableObjects = 
	   and stable_obj_imps
	   && all object_ok scc

	stableBCOs = 
	   and (zipWith (||) stable_obj_imps stable_bco_imps)
	   && all bco_ok scc

	object_ok ms
	  | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms 
					 && same_as_prev t
	  | otherwise = False
	  where
Simon Marlow's avatar
Simon Marlow committed
931
	     same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
932 933
				Just hmi  | Just l <- hm_linkable hmi
				 -> isObjectLinkable l && t == linkableTime l
934
				_other  -> True
935
		-- why '>=' rather than '>' above?  If the filesystem stores
936 937 938 939 940 941
		-- 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.

942
	bco_ok ms
Simon Marlow's avatar
Simon Marlow committed
943
	  = case lookupUFM hpt (ms_mod_name ms) of
944 945 946
		Just hmi  | Just l <- hm_linkable hmi ->
			not (isObjectLinkable l) && 
			linkableTime l >= ms_hs_date ms
947
		_other  -> False
948

Simon Marlow's avatar
Simon Marlow committed
949
ms_allimps :: ModSummary -> [ModuleName]
950
ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
951

952 953
-- -----------------------------------------------------------------------------
-- Prune the HomePackageTable
954

955 956 957 958 959 960 961 962 963 964 965 966 967 968 969
-- Before doing an upsweep, we can throw away:
--
--   - For non-stable modules:
--	- all ModDetails, all linked code
--   - all unlinked code that is out of date with respect to
--     the source file
--
-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
-- space at the end of the upsweep, because the topmost ModDetails of the
-- old HPT holds on to the entire type environment from the previous
-- compilation.

pruneHomePackageTable
   :: HomePackageTable
   -> [ModSummary]
Simon Marlow's avatar
Simon Marlow committed
970
   -> ([ModuleName],[ModuleName])
971 972 973
   -> HomePackageTable

pruneHomePackageTable hpt summ (stable_obj, stable_bco)
Simon Marlow's avatar