compiler/main/GHC.hs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2005
   4 --
   5 -- The GHC API
   6 --
   7 -- -----------------------------------------------------------------------------
   8
   9 module GHC (
  10         -- * Initialisation
  11         Session,
  12         defaultErrorHandler,
  13         defaultCleanupHandler,
  14         newSession,
  15
  16         -- * Flags and settings
  17         DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
  18         parseDynamicFlags,
  19         getSessionDynFlags,
  20         setSessionDynFlags,
  21
  22         -- * Targets
  23         Target(..), TargetId(..), Phase,
  24         setTargets,
  25         getTargets,
  26         addTarget,
  27         removeTarget,
  28         guessTarget,
  29
  30         -- * Extending the program scope
  31         extendGlobalRdrScope,  -- :: Session -> [GlobalRdrElt] -> IO ()
  32         setGlobalRdrScope,     -- :: Session -> [GlobalRdrElt] -> IO ()
  33         extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
  34         setGlobalTypeScope,    -- :: Session -> [Id] -> IO ()
  35
  36         -- * Loading\/compiling the program
  37         depanal,
  38         load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
  39         workingDirectoryChanged,
  40         checkModule, CheckedModule(..),
  41         TypecheckedSource, ParsedSource, RenamedSource,
  42
  43         -- * Parsing Haddock comments
  44         parseHaddockComment,
  45
  46         -- * Inspecting the module structure of the program
  47         ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
  48         getModuleGraph,
  49         isLoaded,
  50         topSortModuleGraph,
  51
  52         -- * Inspecting modules
  53         ModuleInfo,
  54         getModuleInfo,
  55         modInfoTyThings,
  56         modInfoTopLevelScope,
  57         modInfoPrintUnqualified,
  58         modInfoExports,
  59         modInfoInstances,
  60         modInfoIsExportedName,
  61         modInfoLookupName,
  62         lookupGlobalName,
  63
  64         -- * Printing
  65         PrintUnqualified, alwaysQualify,
  66
  67         -- * Interactive evaluation
  68         getBindings, getPrintUnqual,
  69         findModule,
  70 #ifdef GHCI
  71         setContext, getContext,
  72         getNamesInScope,
  73         getRdrNamesInScope,
  74         moduleIsInterpreted,
  75         getInfo,
  76         exprType,
  77         typeKind,
  78         parseName,
  79         RunResult(..),
  80         runStmt,
  81         showModule,
  82         compileExpr, HValue, dynCompileExpr,
  83         lookupName,
  84
  85         obtainTerm,
  86 #endif
  87
  88         -- * Abstract syntax elements
  89
  90         -- ** Packages
  91         PackageId,
  92
  93         -- ** Modules
  94         Module, mkModule, pprModule, moduleName, modulePackageId,
  95         ModuleName, mkModuleName, moduleNameString,
  96
  97         -- ** Names
  98         Name,
  99         nameModule, pprParenSymName, nameSrcLoc,
 100         NamedThing(..),
 101         RdrName(Qual,Unqual),
 102
 103         -- ** Identifiers
 104         Id, idType,
 105         isImplicitId, isDeadBinder,
 106         isExportedId, isLocalId, isGlobalId,
 107         isRecordSelector,
 108         isPrimOpId, isFCallId, isClassOpId_maybe,
 109         isDataConWorkId, idDataCon,
 110         isBottomingId, isDictonaryId,
 111         recordSelectorFieldLabel,
 112
 113         -- ** Type constructors
 114         TyCon,
 115         tyConTyVars, tyConDataCons, tyConArity,
 116         isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
 117         isOpenTyCon,
 118         synTyConDefn, synTyConType, synTyConResKind,
 119
 120         -- ** Type variables
 121         TyVar,
 122         alphaTyVars,
 123
 124         -- ** Data constructors
 125         DataCon,
 126         dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
 127         dataConIsInfix, isVanillaDataCon,
 128         dataConStrictMarks,
 129         StrictnessMark(..), isMarkedStrict,
 130
 131         -- ** Classes
 132         Class,
 133         classMethods, classSCTheta, classTvsFds,
 134         pprFundeps,
 135
 136         -- ** Instances
 137         Instance,
 138         instanceDFunId, pprInstance, pprInstanceHdr,
 139
 140         -- ** Types and Kinds
 141         Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
 142         Kind,
 143         PredType,
 144         ThetaType, pprThetaArrow,
 145
 146         -- ** Entities
 147         TyThing(..),
 148
 149         -- ** Syntax
 150         module HsSyn, -- ToDo: remove extraneous bits
 151
 152         -- ** Fixities
 153         FixityDirection(..),
 154         defaultFixity, maxPrecedence,
 155         negateFixity,
 156         compareFixity,
 157
 158         -- ** Source locations
 159         SrcLoc, pprDefnLoc,
 160
 161         -- * Exceptions
 162         GhcException(..), showGhcException,
 163
 164         -- * Miscellaneous
 165         sessionHscEnv,
 166         cyclicModuleErr,
 167   ) where
 168
 169 {-
 170  ToDo:
 171
 172   * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
 173   * what StaticFlags should we expose, if any?
 174 -}
 175
 176 #include "HsVersions.h"
 177
 178 #ifdef GHCI
 179 import TcRnDriver       ( tcRnLookupRdrName, tcRnGetInfo,
 180                           tcRnLookupName, getModuleExports )
 181 import RdrName          ( plusGlobalRdrEnv, Provenance(..),
 182                           ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
 183                           mkGlobalRdrEnv )
 184 import HscMain          ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
 185 import Name             ( nameOccName )
 186 import Type             ( tidyType )
 187 import VarEnv           ( emptyTidyEnv )
 188 import GHC.Exts         ( unsafeCoerce# )
 189
 190 -- For breakpoints
 191 import Breakpoints      ( SiteNumber, Coord, nullBkptHandler,
 192                           BkptHandler(..), BkptLocation, noDbgSites )
 193 import Linker           ( initDynLinker )
 194 import PrelNames        ( breakpointJumpName, breakpointCondJumpName,
 195                           breakpointAutoJumpName )
 196
 197 import GHC.Exts         ( Int(..), Ptr(..), int2Addr#, indexArray# )
 198 import GHC.Base         ( Opaque(..) )
 199 import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
 200 import Foreign          ( unsafePerformIO )
 201 import Data.Maybe       ( fromMaybe)
 202 import qualified Linker
 203
 204 import Data.Dynamic     ( Dynamic )
 205 import RtClosureInspect ( cvObtainTerm, Term )
 206 import Linker           ( HValue, getHValue, extendLinkEnv )
 207 #endif
 208
 209 import Packages         ( initPackages )
 210 import NameSet          ( NameSet, nameSetToList, elemNameSet )
 211 import RdrName          ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
 212                           globalRdrEnvElts, extendGlobalRdrEnv,
 213                           emptyGlobalRdrEnv )
 214 import HsSyn
 215 import Type             ( Kind, Type, dropForAlls, PredType, ThetaType,
 216                           pprThetaArrow, pprParendType, splitForAllTys,
 217                           funResultTy )
 218 import Id               ( Id, idType, isImplicitId, isDeadBinder,
 219                           isExportedId, isLocalId, isGlobalId,
 220                           isRecordSelector, recordSelectorFieldLabel,
 221                           isPrimOpId, isFCallId, isClassOpId_maybe,
 222                           isDataConWorkId, idDataCon,
 223                           isBottomingId )
 224 import Var              ( TyVar, varName )
 225 import TysPrim          ( alphaTyVars )
 226 import TyCon            ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
 227                           isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
 228                           tyConTyVars, tyConDataCons, synTyConDefn,
 229                           synTyConType, synTyConResKind )
 230 import Class            ( Class, classSCTheta, classTvsFds, classMethods )
 231 import FunDeps          ( pprFundeps )
 232 import DataCon          ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
 233                           dataConFieldLabels, dataConStrictMarks,
 234                           dataConIsInfix, isVanillaDataCon )
 235 import Name             ( Name, nameModule, NamedThing(..), nameSrcLoc )
 236 import OccName          ( parenSymOcc )
 237 import NameEnv          ( nameEnvElts )
 238 import InstEnv          ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 239 import SrcLoc
 240 import DriverPipeline
 241 import DriverPhases     ( Phase(..), isHaskellSrcFilename, startPhase )
 242 import HeaderInfo       ( getImports, getOptions )
 243 import Finder
 244 import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )
 245 import HscTypes
 246 import DynFlags
 247 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
 248                       cleanTempDirs )
 249 import Module
 250 import UniqFM
 251 import PackageConfig    ( PackageId, stringToPackageId )
 252 import FiniteMap
 253 import Panic
 254 import Digraph
 255 import Bag              ( unitBag, listToBag )
 256 import ErrUtils         ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
 257                           mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
 258                           WarnMsg )
 259 import qualified ErrUtils
 260 import Util
 261 import StringBuffer     ( StringBuffer, hGetStringBuffer )
 262 import Outputable
 263 import BasicTypes
 264 import TcType           ( tcSplitSigmaTy, isDictTy )
 265 import Maybes           ( expectJust, mapCatMaybes )
 266 import HaddockParse     ( parseHaddockParagraphs, parseHaddockString )
 267 import HaddockLex       ( tokenise )
 268
 269 import Control.Concurrent
 270 import System.Directory ( getModificationTime, doesFileExist )
 271 import Data.Maybe       ( isJust, isNothing )
 272 import Data.List        ( partition, nub )
 273 import qualified Data.List as List
 274 import Control.Monad    ( unless, when )
 275 import System.Exit      ( exitWith, ExitCode(..) )
 276 import System.Time      ( ClockTime )
 277 import Control.Exception as Exception hiding (handle)
 278 import Data.IORef
 279 import Data.Traversable ( traverse )
 280 import System.IO
 281 import System.IO.Error  ( isDoesNotExistError )
 282 import Prelude hiding (init)
 283
 284 #if __GLASGOW_HASKELL__ < 600
 285 import System.IO as System.IO.Error ( try )
 286 #else
 287 import System.IO.Error  ( try )
 288 #endif
 289
 290 -- -----------------------------------------------------------------------------
 291 -- Exception handlers
 292
 293 -- | Install some default exception handlers and run the inner computation.
 294 -- Unless you want to handle exceptions yourself, you should wrap this around
 295 -- the top level of your program.  The default handlers output the error
 296 -- message(s) to stderr and exit cleanly.
 297 defaultErrorHandler :: DynFlags -> IO a -> IO a
 298 defaultErrorHandler dflags inner =
 299   -- top-level exception handler: any unrecognised exception is a compiler bug.
 300   handle (\exception -> do
 301            hFlush stdout
 302            case exception of
 303                 -- an IO exception probably isn't our fault, so don't panic
 304                 IOException _ ->
 305                   fatalErrorMsg dflags (text (show exception))
 306                 AsyncException StackOverflow ->
 307                   fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
 308                 _other ->
 309                   fatalErrorMsg dflags (text (show (Panic (show exception))))
 310            exitWith (ExitFailure 1)
 311          ) $
 312
 313   -- program errors: messages with locations attached.  Sometimes it is
 314   -- convenient to just throw these as exceptions.
 315   handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
 316                         exitWith (ExitFailure 1)) $
 317
 318   -- error messages propagated as exceptions
 319   handleDyn (\dyn -> do
 320                 hFlush stdout
 321                 case dyn of
 322                      PhaseFailed _ code -> exitWith code
 323                      Interrupted -> exitWith (ExitFailure 1)
 324                      _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
 325                              exitWith (ExitFailure 1)
 326             ) $
 327   inner
 328
 329 -- | Install a default cleanup handler to remove temporary files
 330 -- deposited by a GHC run.  This is seperate from
 331 -- 'defaultErrorHandler', because you might want to override the error
 332 -- handling, but still get the ordinary cleanup behaviour.
 333 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 334 defaultCleanupHandler dflags inner =
 335     -- make sure we clean up after ourselves
 336     later (unless (dopt Opt_KeepTmpFiles dflags) $
 337                do cleanTempFiles dflags
 338                   cleanTempDirs dflags
 339           )
 340           -- exceptions will be blocked while we clean the temporary files,
 341           -- so there shouldn't be any difficulty if we receive further
 342           -- signals.
 343     inner
 344
 345
 346 -- | Starts a new session.  A session consists of a set of loaded
 347 -- modules, a set of options (DynFlags), and an interactive context.
 348 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
 349 -- code".
 350 newSession :: GhcMode -> Maybe FilePath -> IO Session
 351 newSession mode mb_top_dir = do
 352   -- catch ^C
 353   main_thread <- myThreadId
 354   modifyMVar_ interruptTargetThread (return . (main_thread :))
 355   installSignalHandlers
 356
 357   dflags0 <- initSysTools mb_top_dir defaultDynFlags
 358   dflags  <- initDynFlags dflags0
 359   env <- newHscEnv dflags{ ghcMode=mode }
 360   ref <- newIORef env
 361   return (Session ref)
 362
 363 -- tmp: this breaks the abstraction, but required because DriverMkDepend
 364 -- needs to call the Finder.  ToDo: untangle this.
 365 sessionHscEnv :: Session -> IO HscEnv
 366 sessionHscEnv (Session ref) = readIORef ref
 367
 368 withSession :: Session -> (HscEnv -> IO a) -> IO a
 369 withSession (Session ref) f = do h <- readIORef ref; f h
 370
 371 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
 372 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
 373
 374 -- -----------------------------------------------------------------------------
 375 -- Flags & settings
 376
 377 -- | Grabs the DynFlags from the Session
 378 getSessionDynFlags :: Session -> IO DynFlags
 379 getSessionDynFlags s = withSession s (return . hsc_dflags)
 380
 381 -- | Updates the DynFlags in a Session.  This also reads
 382 -- the package database (unless it has already been read),
 383 -- and prepares the compilers knowledge about packages.  It
 384 -- can be called again to load new packages: just add new
 385 -- package flags to (packageFlags dflags).
 386 --
 387 -- Returns a list of new packages that may need to be linked in using
 388 -- the dynamic linker (see 'linkPackages') as a result of new package
 389 -- flags.  If you are not doing linking or doing static linking, you
 390 -- can ignore the list of packages returned.
 391 --
 392 setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
 393 setSessionDynFlags (Session ref) dflags = do
 394   hsc_env <- readIORef ref
 395   (dflags', preload) <- initPackages dflags
 396   writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
 397   return preload
 398
 399 -- | If there is no -o option, guess the name of target executable
 400 -- by using top-level source file name as a base.
 401 guessOutputFile :: Session -> IO ()
 402 guessOutputFile s = modifySession s $ \env ->
 403     let dflags = hsc_dflags env
 404         mod_graph = hsc_mod_graph env
 405         mainModuleSrcPath, guessedName :: Maybe String
 406         mainModuleSrcPath = do
 407             let isMain = (== mainModIs dflags) . ms_mod
 408             [ms] <- return (filter isMain mod_graph)
 409             ml_hs_file (ms_location ms)
 410         guessedName = fmap basenameOf mainModuleSrcPath
 411     in
 412     case outputFile dflags of
 413         Just _ -> env
 414         Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
 415
 416 -- -----------------------------------------------------------------------------
 417 -- Targets
 418
 419 -- ToDo: think about relative vs. absolute file paths. And what
 420 -- happens when the current directory changes.
 421
 422 -- | Sets the targets for this session.  Each target may be a module name
 423 -- or a filename.  The targets correspond to the set of root modules for
 424 -- the program\/library.  Unloading the current program is achieved by
 425 -- setting the current set of targets to be empty, followed by load.
 426 setTargets :: Session -> [Target] -> IO ()
 427 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
 428
 429 -- | returns the current set of targets
 430 getTargets :: Session -> IO [Target]
 431 getTargets s = withSession s (return . hsc_targets)
 432
 433 -- | Add another target
 434 addTarget :: Session -> Target -> IO ()
 435 addTarget s target
 436   = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
 437
 438 -- | Remove a target
 439 removeTarget :: Session -> TargetId -> IO ()
 440 removeTarget s target_id
 441   = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
 442   where
 443    filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
 444
 445 -- Attempts to guess what Target a string refers to.  This function implements
 446 -- the --make/GHCi command-line syntax for filenames:
 447 --
 448 --      - if the string looks like a Haskell source filename, then interpret
 449 --        it as such
 450 --      - if adding a .hs or .lhs suffix yields the name of an existing file,
 451 --        then use that
 452 --      - otherwise interpret the string as a module name
 453 --
 454 guessTarget :: String -> Maybe Phase -> IO Target
 455 guessTarget file (Just phase)
 456    = return (Target (TargetFile file (Just phase)) Nothing)
 457 guessTarget file Nothing
 458    | isHaskellSrcFilename file
 459    = return (Target (TargetFile file Nothing) Nothing)
 460    | otherwise
 461    = do exists <- doesFileExist hs_file
 462         if exists
 463            then return (Target (TargetFile hs_file Nothing) Nothing)
 464            else do
 465         exists <- doesFileExist lhs_file
 466         if exists
 467            then return (Target (TargetFile lhs_file Nothing) Nothing)
 468            else do
 469         return (Target (TargetModule (mkModuleName file)) Nothing)
 470      where
 471          hs_file  = file `joinFileExt` "hs"
 472          lhs_file = file `joinFileExt` "lhs"
 473
 474 -- -----------------------------------------------------------------------------
 475 -- Extending the program scope
 476
 477 extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
 478 extendGlobalRdrScope session rdrElts
 479     = modifySession session $ \hscEnv ->
 480       let global_rdr = hsc_global_rdr_env hscEnv
 481       in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
 482
 483 setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
 484 setGlobalRdrScope session rdrElts
 485     = modifySession session $ \hscEnv ->
 486       hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
 487
 488 extendGlobalTypeScope :: Session -> [Id] -> IO ()
 489 extendGlobalTypeScope session ids
 490     = modifySession session $ \hscEnv ->
 491       let global_type = hsc_global_type_env hscEnv
 492       in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
 493
 494 setGlobalTypeScope :: Session -> [Id] -> IO ()
 495 setGlobalTypeScope session ids
 496     = modifySession session $ \hscEnv ->
 497       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 498
 499 -- -----------------------------------------------------------------------------
 500 -- Parsing Haddock comments
 501
 502 parseHaddockComment :: String -> Either String (HsDoc RdrName)
 503 parseHaddockComment string = parseHaddockParagraphs (tokenise string)
 504
 505 -- -----------------------------------------------------------------------------
 506 -- Loading the program
 507
 508 -- Perform a dependency analysis starting from the current targets
 509 -- and update the session with the new module graph.
 510 depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
 511 depanal (Session ref) excluded_mods allow_dup_roots = do
 512   hsc_env <- readIORef ref
 513   let
 514          dflags  = hsc_dflags hsc_env
 515          gmode   = ghcMode (hsc_dflags hsc_env)
 516          targets = hsc_targets hsc_env
 517          old_graph = hsc_mod_graph hsc_env
 518
 519   showPass dflags "Chasing dependencies"
 520   when (gmode == BatchCompile) $
 521         debugTraceMsg dflags 2 (hcat [
 522                      text "Chasing modules from: ",
 523                         hcat (punctuate comma (map pprTarget targets))])
 524
 525   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
 526   case r of
 527     Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
 528     _ -> return ()
 529   return r
 530
 531 {-
 532 -- | The result of load.
 533 data LoadResult
 534   = LoadOk      Errors  -- ^ all specified targets were loaded successfully.
 535   | LoadFailed  Errors  -- ^ not all modules were loaded.
 536
 537 type Errors = [String]
 538
 539 data ErrMsg = ErrMsg {
 540         errMsgSeverity  :: Severity,  -- warning, error, etc.
 541         errMsgSpans     :: [SrcSpan],
 542         errMsgShortDoc  :: Doc,
 543         errMsgExtraInfo :: Doc
 544         }
 545 -}
 546
 547 data LoadHowMuch
 548    = LoadAllTargets
 549    | LoadUpTo ModuleName
 550    | LoadDependenciesOf ModuleName
 551
 552 -- | Try to load the program.  If a Module is supplied, then just
 553 -- attempt to load up to this target.  If no Module is supplied,
 554 -- then try to load all targets.
 555 load :: Session -> LoadHowMuch -> IO SuccessFlag
 556 load s@(Session ref) how_much
 557    = do
 558         -- Dependency analysis first.  Note that this fixes the module graph:
 559         -- even if we don't get a fully successful upsweep, the full module
 560         -- graph is still retained in the Session.  We can tell which modules
 561         -- were successfully loaded by inspecting the Session's HPT.
 562         mb_graph <- depanal s [] False
 563         case mb_graph of
 564            Just mod_graph -> load2 s how_much mod_graph
 565            Nothing        -> return Failed
 566
 567 load2 s@(Session ref) how_much mod_graph = do
 568         guessOutputFile s
 569         hsc_env <- readIORef ref
 570
 571         let hpt1      = hsc_HPT hsc_env
 572         let dflags    = hsc_dflags hsc_env
 573         let ghci_mode = ghcMode dflags -- this never changes
 574
 575         -- The "bad" boot modules are the ones for which we have
 576         -- B.hs-boot in the module graph, but no B.hs
 577         -- The downsweep should have ensured this does not happen
 578         -- (see msDeps)
 579         let all_home_mods = [ms_mod_name s
 580                             | s <- mod_graph, not (isBootSummary s)]
 581 #ifdef DEBUG
 582             bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
 583                                         not (ms_mod_name s `elem` all_home_mods)]
 584 #endif
 585         ASSERT( null bad_boot_mods ) return ()
 586
 587         -- mg2_with_srcimps drops the hi-boot nodes, returning a
 588         -- graph with cycles.  Among other things, it is used for
 589         -- backing out partially complete cycles following a failed
 590         -- upsweep, and for removing from hpt all the modules
 591         -- not in strict downwards closure, during calls to compile.
 592         let mg2_with_srcimps :: [SCC ModSummary]
 593             mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 594
 595         -- If we can determine that any of the {-# SOURCE #-} imports
 596         -- are definitely unnecessary, then emit a warning.
 597         warnUnnecessarySourceImports dflags mg2_with_srcimps
 598
 599         let
 600             -- check the stability property for each module.
 601             stable_mods@(stable_obj,stable_bco)
 602                 | BatchCompile <- ghci_mode = ([],[])
 603                 | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
 604
 605             -- prune bits of the HPT which are definitely redundant now,
 606             -- to save space.
 607             pruned_hpt = pruneHomePackageTable hpt1
 608                                 (flattenSCCs mg2_with_srcimps)
 609                                 stable_mods
 610
 611         evaluate pruned_hpt
 612
 613         debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
 614                                 text "Stable BCO:" <+> ppr stable_bco)
 615
 616         -- Unload any modules which are going to be re-linked this time around.
 617         let stable_linkables = [ linkable
 618                                | m <- stable_obj++stable_bco,
 619                                  Just hmi <- [lookupUFM pruned_hpt m],
 620                                  Just linkable <- [hm_linkable hmi] ]
 621         unload hsc_env stable_linkables
 622
 623         -- We could at this point detect cycles which aren't broken by
 624         -- a source-import, and complain immediately, but it seems better
 625         -- to let upsweep_mods do this, so at least some useful work gets
 626         -- done before the upsweep is abandoned.
 627         --hPutStrLn stderr "after tsort:\n"
 628         --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 629
 630         -- Now do the upsweep, calling compile for each module in
 631         -- turn.  Final result is version 3 of everything.
 632
 633         -- Topologically sort the module graph, this time including hi-boot
 634         -- nodes, and possibly just including the portion of the graph
 635         -- reachable from the module specified in the 2nd argument to load.
 636         -- This graph should be cycle-free.
 637         -- If we're restricting the upsweep to a portion of the graph, we
 638         -- also want to retain everything that is still stable.
 639         let full_mg :: [SCC ModSummary]
 640             full_mg    = topSortModuleGraph False mod_graph Nothing
 641
 642             maybe_top_mod = case how_much of
 643                                 LoadUpTo m           -> Just m
 644                                 LoadDependenciesOf m -> Just m
 645                                 _                    -> Nothing
 646
 647             partial_mg0 :: [SCC ModSummary]
 648             partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
 649
 650             -- LoadDependenciesOf m: we want the upsweep to stop just
 651             -- short of the specified module (unless the specified module
 652             -- is stable).
 653             partial_mg
 654                 | LoadDependenciesOf mod <- how_much
 655                 = ASSERT( case last partial_mg0 of
 656                             AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
 657                   List.init partial_mg0
 658                 | otherwise
 659                 = partial_mg0
 660
 661             stable_mg =
 662                 [ AcyclicSCC ms
 663                 | AcyclicSCC ms <- full_mg,
 664                   ms_mod_name ms `elem` stable_obj++stable_bco,
 665                   ms_mod_name ms `notElem` [ ms_mod_name ms' |
 666                                                 AcyclicSCC ms' <- partial_mg ] ]
 667
 668             mg = stable_mg ++ partial_mg
 669
 670         -- clean up between compilations
 671         let cleanup = cleanTempFilesExcept dflags
 672                           (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
 673
 674         debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
 675                                    2 (ppr mg))
 676         (upsweep_ok, hsc_env1, modsUpswept)
 677            <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
 678                            pruned_hpt stable_mods cleanup mg
 679
 680         -- Make modsDone be the summaries for each home module now
 681         -- available; this should equal the domain of hpt3.
 682         -- Get in in a roughly top .. bottom order (hence reverse).
 683
 684         let modsDone = reverse modsUpswept
 685
 686         -- Try and do linking in some form, depending on whether the
 687         -- upsweep was completely or only partially successful.
 688
 689         if succeeded upsweep_ok
 690
 691          then
 692            -- Easy; just relink it all.
 693            do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
 694
 695               -- Clean up after ourselves
 696               cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
 697
 698               -- Issue a warning for the confusing case where the user
 699               -- said '-o foo' but we're not going to do any linking.
 700               -- We attempt linking if either (a) one of the modules is
 701               -- called Main, or (b) the user said -no-hs-main, indicating
 702               -- that main() is going to come from somewhere else.
 703               --
 704               let ofile = outputFile dflags
 705               let no_hs_main = dopt Opt_NoHsMain dflags
 706               let
 707                 main_mod = mainModIs dflags
 708                 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
 709                 do_linking = a_root_is_Main || no_hs_main
 710
 711               when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
 712                 debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
 713                                               "but no output will be generated\n" ++
 714                                               "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
 715
 716               -- link everything together
 717               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
 718
 719               loadFinish Succeeded linkresult ref hsc_env1
 720
 721          else
 722            -- Tricky.  We need to back out the effects of compiling any
 723            -- half-done cycles, both so as to clean up the top level envs
 724            -- and to avoid telling the interactive linker to link them.
 725            do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
 726
 727               let modsDone_names
 728                      = map ms_mod modsDone
 729               let mods_to_zap_names
 730                      = findPartiallyCompletedCycles modsDone_names
 731                           mg2_with_srcimps
 732               let mods_to_keep
 733                      = filter ((`notElem` mods_to_zap_names).ms_mod)
 734                           modsDone
 735
 736               let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
 737                                               (hsc_HPT hsc_env1)
 738
 739               -- Clean up after ourselves
 740               cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
 741
 742               -- there should be no Nothings where linkables should be, now
 743               ASSERT(all (isJust.hm_linkable)
 744                         (eltsUFM (hsc_HPT hsc_env))) do
 745
 746               -- Link everything together
 747               linkresult <- link ghci_mode dflags False hpt4
 748
 749               let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
 750               loadFinish Failed linkresult ref hsc_env4
 751
 752 -- Finish up after a load.
 753
 754 -- If the link failed, unload everything and return.
 755 loadFinish all_ok Failed ref hsc_env
 756   = do unload hsc_env []
 757        writeIORef ref $! discardProg hsc_env
 758        return Failed
 759
 760 -- Empty the interactive context and set the module context to the topmost
 761 -- newly loaded module, or the Prelude if none were loaded.
 762 loadFinish all_ok Succeeded ref hsc_env
 763   = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
 764        return all_ok
 765
 766
 767 -- Forget the current program, but retain the persistent info in HscEnv
 768 discardProg :: HscEnv -> HscEnv
 769 discardProg hsc_env
 770   = hsc_env { hsc_mod_graph = emptyMG,
 771               hsc_IC = emptyInteractiveContext,
 772               hsc_HPT = emptyHomePackageTable }
 773
 774 -- used to fish out the preprocess output files for the purposes of
 775 -- cleaning up.  The preprocessed file *might* be the same as the
 776 -- source file, but that doesn't do any harm.
 777 ppFilesFromSummaries summaries = map ms_hspp_file summaries
 778
 779 -- -----------------------------------------------------------------------------
 780 -- Check module
 781
 782 data CheckedModule =
 783   CheckedModule { parsedSource      :: ParsedSource,
 784                   renamedSource     :: Maybe RenamedSource,
 785                   typecheckedSource :: Maybe TypecheckedSource,
 786                   checkedModuleInfo :: Maybe ModuleInfo
 787                 }
 788         -- ToDo: improvements that could be made here:
 789         --  if the module succeeded renaming but not typechecking,
 790         --  we can still get back the GlobalRdrEnv and exports, so
 791         --  perhaps the ModuleInfo should be split up into separate
 792         --  fields within CheckedModule.
 793
 794 type ParsedSource      = Located (HsModule RdrName)
 795 type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
 796                           Maybe (HsDoc Name), HaddockModInfo Name)
 797 type TypecheckedSource = LHsBinds Id
 798
 799 -- NOTE:
 800 --   - things that aren't in the output of the typechecker right now:
 801 --     - the export list
 802 --     - the imports
 803 --     - type signatures
 804 --     - type/data/newtype declarations
 805 --     - class declarations
 806 --     - instances
 807 --   - extra things in the typechecker's output:
 808 --     - default methods are turned into top-level decls.
 809 --     - dictionary bindings
 810
 811
 812 -- | This is the way to get access to parsed and typechecked source code
 813 -- for a module.  'checkModule' loads all the dependencies of the specified
 814 -- module in the Session, and then attempts to typecheck the module.  If
 815 -- successful, it returns the abstract syntax for the module.
 816 checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
 817 checkModule session@(Session ref) mod = do
 818         -- load up the dependencies first
 819    r <- load session (LoadDependenciesOf mod)
 820    if (failed r) then return Nothing else do
 821
 822         -- now parse & typecheck the module
 823    hsc_env <- readIORef ref
 824    let mg  = hsc_mod_graph hsc_env
 825    case [ ms | ms <- mg, ms_mod_name ms == mod ] of
 826         [] -> return Nothing
 827         (ms:_) -> do
 828            mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
 829            case mbChecked of
 830              Nothing -> return Nothing
 831              Just (HscChecked parsed renamed Nothing) ->
 832                    return (Just (CheckedModule {
 833                                         parsedSource = parsed,
 834                                         renamedSource = renamed,
 835                                         typecheckedSource = Nothing,
 836                                         checkedModuleInfo = Nothing }))
 837              Just (HscChecked parsed renamed
 838                            (Just (tc_binds, rdr_env, details))) -> do
 839                    let minf = ModuleInfo {
 840                                 minf_type_env  = md_types details,
 841                                 minf_exports   = availsToNameSet $
 842                                                      md_exports details,
 843                                 minf_rdr_env   = Just rdr_env,
 844                                 minf_instances = md_insts details
 845                               }
 846                    return (Just (CheckedModule {
 847                                         parsedSource = parsed,
 848                                         renamedSource = renamed,
 849                                         typecheckedSource = Just tc_binds,
 850                                         checkedModuleInfo = Just minf }))
 851
 852 -- ---------------------------------------------------------------------------
 853 -- Unloading
 854
 855 unload :: HscEnv -> [Linkable] -> IO ()
 856 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
 857   = case ghcMode (hsc_dflags hsc_env) of
 858         BatchCompile  -> return ()
 859         JustTypecheck -> return ()
 860 #ifdef GHCI
 861         Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
 862 #else
 863         Interactive -> panic "unload: no interpreter"
 864 #endif
 865         other -> panic "unload: strange mode"
 866
 867 -- -----------------------------------------------------------------------------
 868 -- checkStability
 869
 870 {-
 871   Stability tells us which modules definitely do not need to be recompiled.
 872   There are two main reasons for having stability:
 873
 874    - avoid doing a complete upsweep of the module graph in GHCi when
 875      modules near the bottom of the tree have not changed.
 876
 877    - to tell GHCi when it can load object code: we can only load object code
 878      for a module when we also load object code fo  all of the imports of the
 879      module.  So we need to know that we will definitely not be recompiling
 880      any of these modules, and we can use the object code.
 881
 882   NB. stability is of no importance to BatchCompile at all, only Interactive.
 883   (ToDo: what about JustTypecheck?)
 884
 885   The stability check is as follows.  Both stableObject and
 886   stableBCO are used during the upsweep phase later.
 887
 888   -------------------
 889   stable m = stableObject m || stableBCO m
 890
 891   stableObject m =
 892         all stableObject (imports m)
 893         && old linkable does not exist, or is == on-disk .o
 894         && date(on-disk .o) > date(.hs)
 895
 896   stableBCO m =
 897         all stable (imports m)
 898         && date(BCO) > date(.hs)
 899   -------------------
 900
 901   These properties embody the following ideas:
 902
 903     - if a module is stable:
 904         - if it has been compiled in a previous pass (present in HPT)
 905           then it does not need to be compiled or re-linked.
 906         - if it has not been compiled in a previous pass,
 907           then we only need to read its .hi file from disk and
 908           link it to produce a ModDetails.
 909
 910     - if a modules is not stable, we will definitely be at least
 911       re-linking, and possibly re-compiling it during the upsweep.
 912       All non-stable modules can (and should) therefore be unlinked
 913       before the upsweep.
 914
 915     - Note that objects are only considered stable if they only depend
 916       on other objects.  We can't link object code against byte code.
 917 -}
 918
 919 checkStability
 920         :: HomePackageTable             -- HPT from last compilation
 921         -> [SCC ModSummary]             -- current module graph (cyclic)
 922         -> [ModuleName]                 -- all home modules
 923         -> ([ModuleName],               -- stableObject
 924             [ModuleName])               -- stableBCO
 925
 926 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
 927   where
 928    checkSCC (stable_obj, stable_bco) scc0
 929      | stableObjects = (scc_mods ++ stable_obj, stable_bco)
 930      | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)
 931      | otherwise     = (stable_obj, stable_bco)
 932      where
 933         scc = flattenSCC scc0
 934         scc_mods = map ms_mod_name scc
 935         home_module m   = m `elem` all_home_mods && m `notElem` scc_mods
 936
 937         scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
 938             -- all imports outside the current SCC, but in the home pkg
 939
 940         stable_obj_imps = map (`elem` stable_obj) scc_allimps
 941         stable_bco_imps = map (`elem` stable_bco) scc_allimps
 942
 943         stableObjects =
 944            and stable_obj_imps
 945            && all object_ok scc
 946
 947         stableBCOs =
 948            and (zipWith (||) stable_obj_imps stable_bco_imps)
 949            && all bco_ok scc
 950
 951         object_ok ms
 952           | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
 953                                          && same_as_prev t
 954           | otherwise = False
 955           where
 956              same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
 957                                 Just hmi  | Just l <- hm_linkable hmi
 958                                  -> isObjectLinkable l && t == linkableTime l
 959                                 _other  -> True
 960                 -- why '>=' rather than '>' above?  If the filesystem stores
 961                 -- times to the nearset second, we may occasionally find that
 962                 -- the object & source have the same modification time,
 963                 -- especially if the source was automatically generated
 964                 -- and compiled.  Using >= is slightly unsafe, but it matches
 965                 -- make's behaviour.
 966
 967         bco_ok ms
 968           = case lookupUFM hpt (ms_mod_name ms) of
 969                 Just hmi  | Just l <- hm_linkable hmi ->
 970                         not (isObjectLinkable l) &&
 971                         linkableTime l >= ms_hs_date ms
 972                 _other  -> False
 973
 974 ms_allimps :: ModSummary -> [ModuleName]
 975 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
 976
 977 -- -----------------------------------------------------------------------------
 978 -- Prune the HomePackageTable
 979
 980 -- Before doing an upsweep, we can throw away:
 981 --
 982 --   - For non-stable modules:
 983 --      - all ModDetails, all linked code
 984 --   - all unlinked code that is out of date with respect to
 985 --     the source file
 986 --
 987 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
 988 -- space at the end of the upsweep, because the topmost ModDetails of the
 989 -- old HPT holds on to the entire type environment from the previous
 990 -- compilation.
 991
 992 pruneHomePackageTable
 993    :: HomePackageTable
 994    -> [ModSummary]
 995    -> ([ModuleName],[ModuleName])
 996    -> HomePackageTable
 997
 998 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
 999   = mapUFM prune hpt
1000   where prune hmi
1001           | is_stable modl = hmi'
1002           | otherwise      = hmi'{ hm_details = emptyModDetails }
1003           where
1004            modl = moduleName (mi_module (hm_iface hmi))
1005            hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1006                 = hmi{ hm_linkable = Nothing }
1007                 | otherwise
1008                 = hmi
1009                 where ms = expectJust "prune" (lookupUFM ms_map modl)
1010
1011         ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1012
1013         is_stable m = m `elem` stable_obj || m `elem` stable_bco
1014
1015 -- -----------------------------------------------------------------------------
1016
1017 -- Return (names of) all those in modsDone who are part of a cycle
1018 -- as defined by theGraph.
1019 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1020 findPartiallyCompletedCycles modsDone theGraph
1021    = chew theGraph
1022      where
1023         chew [] = []
1024         chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
1025         chew ((CyclicSCC vs):rest)
1026            = let names_in_this_cycle = nub (map ms_mod vs)
1027                  mods_in_this_cycle
1028                     = nub ([done | done <- modsDone,
1029                                    done `elem` names_in_this_cycle])
1030                  chewed_rest = chew rest
1031              in
1032              if   notNull mods_in_this_cycle
1033                   && length mods_in_this_cycle < length names_in_this_cycle
1034              then mods_in_this_cycle ++ chewed_rest
1035              else chewed_rest
1036
1037 -- -----------------------------------------------------------------------------
1038 -- The upsweep
1039
1040 -- This is where we compile each module in the module graph, in a pass
1041 -- from the bottom to the top of the graph.
1042
1043 -- There better had not be any cyclic groups here -- we check for them.
1044
1045 upsweep
1046     :: HscEnv                   -- Includes initially-empty HPT
1047     -> HomePackageTable         -- HPT from last time round (pruned)
1048     -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
1049     -> IO ()                    -- How to clean up unwanted tmp files
1050     -> [SCC ModSummary]         -- Mods to do (the worklist)
1051     -> IO (SuccessFlag,
1052            HscEnv,              -- With an updated HPT
1053            [ModSummary])        -- Mods which succeeded
1054
1055 upsweep hsc_env old_hpt stable_mods cleanup mods
1056    = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
1057
1058 upsweep' hsc_env old_hpt stable_mods cleanup
1059      [] _ _
1060    = return (Succeeded, hsc_env, [])
1061
1062 upsweep' hsc_env old_hpt stable_mods cleanup
1063      (CyclicSCC ms:_) _ _
1064    = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1065         return (Failed, hsc_env, [])
1066
1067 upsweep' hsc_env old_hpt stable_mods cleanup
1068      (AcyclicSCC mod:mods) mod_index nmods
1069    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1070         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
1071         --                     (moduleEnvElts (hsc_HPT hsc_env)))
1072
1073         mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
1074                        mod_index nmods
1075
1076         cleanup         -- Remove unwanted tmp files between compilations
1077
1078         case mb_mod_info of
1079             Nothing -> return (Failed, hsc_env, [])
1080             Just mod_info -> do
1081                 { let this_mod = ms_mod_name mod
1082
1083                         -- Add new info to hsc_env
1084                       hpt1     = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1085                       hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1086
1087                         -- Space-saving: delete the old HPT entry
1088                         -- for mod BUT if mod is a hs-boot
1089                         -- node, don't delete it.  For the
1090                         -- interface, the HPT entry is probaby for the
1091                         -- main Haskell source file.  Deleting it
1092                         -- would force .. (what?? --SDM)
1093                       old_hpt1 | isBootSummary mod = old_hpt
1094                                | otherwise = delFromUFM old_hpt this_mod
1095
1096                 ; (restOK, hsc_env2, modOKs)
1097                         <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
1098                                 mods (mod_index+1) nmods
1099                 ; return (restOK, hsc_env2, mod:modOKs)
1100                 }
1101
1102
1103 -- Compile a single module.  Always produce a Linkable for it if
1104 -- successful.  If no compilation happened, return the old Linkable.
1105 upsweep_mod :: HscEnv
1106             -> HomePackageTable
1107             -> ([ModuleName],[ModuleName])
1108             -> ModSummary
1109             -> Int  -- index of module
1110             -> Int  -- total number of modules
1111             -> IO (Maybe HomeModInfo)   -- Nothing => Failed
1112
1113 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1114    = do
1115         let
1116             this_mod_name = ms_mod_name summary
1117             this_mod    = ms_mod summary
1118             mb_obj_date = ms_obj_date summary
1119             obj_fn      = ml_obj_file (ms_location summary)
1120             hs_date     = ms_hs_date summary
1121
1122             compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
1123             compile_it  = upsweep_compile hsc_env old_hpt this_mod_name
1124                                 summary mod_index nmods
1125
1126         case ghcMode (hsc_dflags hsc_env) of
1127             BatchCompile ->
1128                 case () of
1129                    -- Batch-compilating is easy: just check whether we have
1130                    -- an up-to-date object file.  If we do, then the compiler
1131                    -- needs to do a recompilation check.
1132                    _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1133                            linkable <-
1134                                 findObjectLinkable this_mod obj_fn obj_date
1135                            compile_it (Just linkable)
1136
1137                      | otherwise ->
1138                            compile_it Nothing
1139
1140             interactive ->
1141                 case () of
1142                     _ | is_stable_obj, isJust old_hmi ->
1143                            return old_hmi
1144                         -- object is stable, and we have an entry in the
1145                         -- old HPT: nothing to do
1146
1147                       | is_stable_obj, isNothing old_hmi -> do
1148                            linkable <-
1149                                 findObjectLinkable this_mod obj_fn
1150                                         (expectJust "upseep1" mb_obj_date)
1151                            compile_it (Just linkable)
1152                         -- object is stable, but we need to load the interface
1153                         -- off disk to make a HMI.
1154
1155                       | is_stable_bco ->
1156                            ASSERT(isJust old_hmi) -- must be in the old_hpt
1157                            return old_hmi
1158                         -- BCO is stable: nothing to do
1159
1160                       | Just hmi <- old_hmi,
1161                         Just l <- hm_linkable hmi, not (isObjectLinkable l),
1162                         linkableTime l >= ms_hs_date summary ->
1163                            compile_it (Just l)
1164                         -- we have an old BCO that is up to date with respect
1165                         -- to the source: do a recompilation check as normal.
1166
1167                       | otherwise ->
1168                           compile_it Nothing
1169                         -- no existing code at all: we must recompile.
1170                    where
1171                     is_stable_obj = this_mod_name `elem` stable_obj
1172                     is_stable_bco = this_mod_name `elem` stable_bco
1173
1174                     old_hmi = lookupUFM old_hpt this_mod_name
1175
1176 -- Run hsc to compile a module
1177 upsweep_compile hsc_env old_hpt this_mod summary
1178                 mod_index nmods
1179                 mb_old_linkable = do
1180   let
1181         -- The old interface is ok if it's in the old HPT
1182         --      a) we're compiling a source file, and the old HPT
1183         --         entry is for a source file
1184         --      b) we're compiling a hs-boot file
1185         -- Case (b) allows an hs-boot file to get the interface of its
1186         -- real source file on the second iteration of the compilation
1187         -- manager, but that does no harm.  Otherwise the hs-boot file
1188         -- will always be recompiled
1189
1190         mb_old_iface
1191                 = case lookupUFM old_hpt this_mod of
1192                      Nothing                              -> Nothing
1193                      Just hm_info | isBootSummary summary -> Just iface
1194                                   | not (mi_boot iface)   -> Just iface
1195                                   | otherwise             -> Nothing
1196                                    where
1197                                      iface = hm_iface hm_info
1198
1199   compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
1200                         mod_index nmods
1201
1202   case compresult of
1203         -- Compilation failed.  Compile may still have updated the PCS, tho.
1204         CompErrs -> return Nothing
1205
1206         -- Compilation "succeeded", and may or may not have returned a new
1207         -- linkable (depending on whether compilation was actually performed
1208         -- or not).
1209         CompOK new_details new_iface new_linkable
1210               -> do let new_info = HomeModInfo { hm_iface = new_iface,
1211                                                  hm_details = new_details,
1212                                                  hm_linkable = new_linkable }
1213                     return (Just new_info)
1214
1215
1216 -- Filter modules in the HPT
1217 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1218 retainInTopLevelEnvs keep_these hpt
1219    = listToUFM   [ (mod, expectJust "retain" mb_mod_info)
1220                  | mod <- keep_these
1221                  , let mb_mod_info = lookupUFM hpt mod
1222                  , isJust mb_mod_info ]
1223
1224 -- ---------------------------------------------------------------------------
1225 -- Topological sort of the module graph
1226
1227 topSortModuleGraph
1228           :: Bool               -- Drop hi-boot nodes? (see below)
1229           -> [ModSummary]
1230           -> Maybe ModuleName
1231           -> [SCC ModSummary]
1232 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1233 -- The resulting list of strongly-connected-components is in topologically
1234 -- sorted order, starting with the module(s) at the bottom of the
1235 -- dependency graph (ie compile them first) and ending with the ones at
1236 -- the top.
1237 --
1238 -- Drop hi-boot nodes (first boolean arg)?
1239 --
1240 --   False:     treat the hi-boot summaries as nodes of the graph,
1241 --              so the graph must be acyclic
1242 --
1243 --   True:      eliminate the hi-boot nodes, and instead pretend
1244 --              the a source-import of Foo is an import of Foo
1245 --              The resulting graph has no hi-boot nodes, but can by cyclic
1246
1247 topSortModuleGraph drop_hs_boot_nodes summaries Nothing
1248   = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
1249 topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
1250   = stronglyConnComp (map vertex_fn (reachable graph root))
1251   where
1252         -- restrict the graph to just those modules reachable from
1253         -- the specified module.  We do this by building a graph with
1254         -- the full set of nodes, and determining the reachable set from
1255         -- the specified node.
1256         (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
1257         (graph, vertex_fn, key_fn) = graphFromEdges' nodes
1258         root
1259           | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1260           | otherwise  = throwDyn (ProgramError "module does not exist")
1261
1262 moduleGraphNodes :: Bool -> [ModSummary]
1263   -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
1264 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1265    where
1266         -- Drop hs-boot nodes by using HsSrcFile as the key
1267         hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1268                     | otherwise          = HsBootFile
1269
1270         -- We use integers as the keys for the SCC algorithm
1271         nodes :: [(ModSummary, Int, [Int])]
1272         nodes = [(s, expectJust "topSort" $
1273                         lookup_key (ms_hsc_src s) (ms_mod_name s),
1274                      out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1275                      out_edge_keys HsSrcFile   (map unLoc (ms_imps s)) ++
1276                      (-- see [boot-edges] below
1277                       if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1278                         then []
1279                         else case lookup_key HsBootFile (ms_mod_name s) of
1280                                 Nothing -> []
1281                                 Just k  -> [k])
1282                  )
1283                 | s <- summaries
1284                 , not (isBootSummary s && drop_hs_boot_nodes) ]
1285                 -- Drop the hi-boot ones if told to do so
1286
1287         -- [boot-edges] if this is a .hs and there is an equivalent
1288         -- .hs-boot, add a link from the former to the latter.  This
1289         -- has the effect of detecting bogus cases where the .hs-boot
1290         -- depends on the .hs, by introducing a cycle.  Additionally,
1291         -- it ensures that we will always process the .hs-boot before
1292         -- the .hs, and so the HomePackageTable will always have the
1293         -- most up to date information.
1294
1295         key_map :: NodeMap Int
1296         key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
1297                             | s <- summaries]
1298                            `zip` [1..])
1299
1300         lookup_key :: HscSource -> ModuleName -> Maybe Int
1301         lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1302
1303         out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1304         out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1305                 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1306                 -- the IsBootInterface parameter True; else False
1307
1308
1309 type NodeKey   = (ModuleName, HscSource)  -- The nodes of the graph are
1310 type NodeMap a = FiniteMap NodeKey a      -- keyed by (mod, src_file_type) pairs
1311
1312 msKey :: ModSummary -> NodeKey
1313 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1314
1315 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1316 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1317
1318 nodeMapElts :: NodeMap a -> [a]
1319 nodeMapElts = eltsFM
1320
1321 ms_mod_name :: ModSummary -> ModuleName
1322 ms_mod_name = moduleName . ms_mod
1323
1324 -- If there are {-# SOURCE #-} imports between strongly connected
1325 -- components in the topological sort, then those imports can
1326 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1327 -- were necessary, then the edge would be part of a cycle.
1328 warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO ()
1329 warnUnnecessarySourceImports dflags sccs =
1330   printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs)))
1331   where check ms =
1332            let mods_in_this_cycle = map ms_mod_name ms in
1333            [ warn m i | m <- ms, i <- ms_srcimps m,
1334                         unLoc i `notElem`  mods_in_this_cycle ]
1335
1336         warn :: ModSummary -> Located ModuleName -> WarnMsg
1337         warn ms (L loc mod) =
1338            mkPlainErrMsg loc
1339                 (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
1340                  <+> quotes (ppr mod))
1341
1342 -----------------------------------------------------------------------------
1343 -- Downsweep (dependency analysis)
1344
1345 -- Chase downwards from the specified root set, returning summaries
1346 -- for all home modules encountered.  Only follow source-import
1347 -- links.
1348
1349 -- We pass in the previous collection of summaries, which is used as a
1350 -- cache to avoid recalculating a module summary if the source is
1351 -- unchanged.
1352 --
1353 -- The returned list of [ModSummary] nodes has one node for each home-package
1354 -- module, plus one for any hs-boot files.  The imports of these nodes
1355 -- are all there, including the imports of non-home-package modules.
1356
1357 downsweep :: HscEnv
1358           -> [ModSummary]       -- Old summaries
1359           -> [ModuleName]       -- Ignore dependencies on these; treat
1360                                 -- them as if they were package modules
1361           -> Bool               -- True <=> allow multiple targets to have
1362                                 --          the same module name; this is
1363                                 --          very useful for ghc -M
1364           -> IO (Maybe [ModSummary])
1365                 -- The elts of [ModSummary] all have distinct
1366                 -- (Modules, IsBoot) identifiers, unless the Bool is true
1367                 -- in which case there can be repeats
1368 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1369    = -- catch error messages and return them
1370      handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1371        rootSummaries <- mapM getRootSummary roots
1372        let root_map = mkRootMap rootSummaries
1373        checkDuplicates root_map
1374        summs <- loop (concatMap msDeps rootSummaries) root_map
1375        return (Just summs)
1376      where
1377         roots = hsc_targets hsc_env
1378
1379         old_summary_map :: NodeMap ModSummary
1380         old_summary_map = mkNodeMap old_summaries
1381
1382         getRootSummary :: Target -> IO ModSummary
1383         getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1384            = do exists <- doesFileExist file
1385                 if exists
1386                     then summariseFile hsc_env old_summaries file mb_phase maybe_buf
1387                     else throwDyn $ mkPlainErrMsg noSrcSpan $
1388                            text "can't find file:" <+> text file
1389         getRootSummary (Target (TargetModule modl) maybe_buf)
1390            = do maybe_summary <- summariseModule hsc_env old_summary_map False
1391                                            (L rootLoc modl) maybe_buf excl_mods
1392                 case maybe_summary of
1393                    Nothing -> packageModErr modl
1394                    Just s  -> return s
1395
1396         rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
1397
1398         -- In a root module, the filename is allowed to diverge from the module
1399         -- name, so we have to check that there aren't multiple root files
1400         -- defining the same module (otherwise the duplicates will be silently
1401         -- ignored, leading to confusing behaviour).
1402         checkDuplicates :: NodeMap [ModSummary] -> IO ()
1403         checkDuplicates root_map
1404            | allow_dup_roots = return ()
1405            | null dup_roots  = return ()
1406            | otherwise       = multiRootsErr (head dup_roots)
1407            where
1408              dup_roots :: [[ModSummary]]        -- Each at least of length 2
1409              dup_roots = filterOut isSingleton (nodeMapElts root_map)
1410
1411         loop :: [(Located ModuleName,IsBootInterface)]
1412                         -- Work list: process these modules
1413              -> NodeMap [ModSummary]
1414                         -- Visited set; the range is a list because
1415                         -- the roots can have the same module names
1416                         -- if allow_dup_roots is True
1417              -> IO [ModSummary]
1418                         -- The result includes the worklist, except
1419                         -- for those mentioned in the visited set
1420         loop [] done      = return (concat (nodeMapElts done))
1421         loop ((wanted_mod, is_boot) : ss) done
1422           | Just summs <- lookupFM done key
1423           = if isSingleton summs then
1424                 loop ss done
1425             else
1426                 do { multiRootsErr summs; return [] }
1427           | otherwise         = do { mb_s <- summariseModule hsc_env old_summary_map
1428                                                  is_boot wanted_mod Nothing excl_mods
1429                                    ; case mb_s of
1430                                         Nothing -> loop ss done
1431                                         Just s  -> loop (msDeps s ++ ss)
1432                                                         (addToFM done key [s]) }
1433           where
1434             key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1435
1436 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1437 mkRootMap summaries = addListToFM_C (++) emptyFM
1438                         [ (msKey s, [s]) | s <- summaries ]
1439
1440 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1441 -- (msDeps s) returns the dependencies of the ModSummary s.
1442 -- A wrinkle is that for a {-# SOURCE #-} import we return
1443 --      *both* the hs-boot file
1444 --      *and* the source file
1445 -- as "dependencies".  That ensures that the list of all relevant
1446 -- modules always contains B.hs if it contains B.hs-boot.
1447 -- Remember, this pass isn't doing the topological sort.  It's
1448 -- just gathering the list of all relevant ModSummaries
1449 msDeps s =
1450     concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1451          ++ [ (m,False) | m <- ms_imps s ]
1452
1453 -----------------------------------------------------------------------------
1454 -- Summarising modules
1455
1456 -- We have two types of summarisation:
1457 --
1458 --    * Summarise a file.  This is used for the root module(s) passed to
1459 --      cmLoadModules.  The file is read, and used to determine the root
1460 --      module name.  The module name may differ from the filename.
1461 --
1462 --    * Summarise a module.  We are given a module name, and must provide
1463 --      a summary.  The finder is used to locate the file in which the module
1464 --      resides.
1465
1466 summariseFile
1467         :: HscEnv
1468         -> [ModSummary]                 -- old summaries
1469         -> FilePath                     -- source file name
1470         -> Maybe Phase                  -- start phase
1471         -> Maybe (StringBuffer,ClockTime)
1472         -> IO ModSummary
1473
1474 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1475         -- we can use a cached summary if one is available and the
1476         -- source file hasn't changed,  But we have to look up the summary
1477         -- by source file, rather than module name as we do in summarise.
1478    | Just old_summary <- findSummaryBySourceFile old_summaries file
1479    = do
1480         let location = ms_location old_summary
1481
1482                 -- return the cached summary if the source didn't change
1483         src_timestamp <- case maybe_buf of
1484                            Just (_,t) -> return t
1485                            Nothing    -> getModificationTime file
1486                 -- The file exists; we checked in getRootSummary above.
1487                 -- If it gets removed subsequently, then this
1488                 -- getModificationTime may fail, but that's the right
1489                 -- behaviour.
1490
1491         if ms_hs_date old_summary == src_timestamp
1492            then do -- update the object-file timestamp
1493                   obj_timestamp <- getObjTimestamp location False
1494                   return old_summary{ ms_obj_date = obj_timestamp }
1495            else
1496                 new_summary
1497
1498    | otherwise
1499    = new_summary
1500   where
1501     new_summary = do
1502         let dflags = hsc_dflags hsc_env
1503
1504         (dflags', hspp_fn, buf)
1505             <- preprocessFile dflags file mb_phase maybe_buf
1506
1507         (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
1508
1509         -- Make a ModLocation for this file
1510         location <- mkHomeModLocation dflags mod_name file
1511
1512         -- Tell the Finder cache where it is, so that subsequent calls
1513         -- to findModule will find it, even if it's not on any search path
1514         mod <- addHomeModuleToFinder hsc_env mod_name location
1515
1516         src_timestamp <- case maybe_buf of
1517                            Just (_,t) -> return t
1518                            Nothing    -> getModificationTime file
1519                         -- getMofificationTime may fail
1520
1521         obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1522
1523         return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1524                              ms_location = location,
1525                              ms_hspp_file = hspp_fn,
1526                              ms_hspp_opts = dflags',
1527                              ms_hspp_buf  = Just buf,
1528                              ms_srcimps = srcimps, ms_imps = the_imps,
1529                              ms_hs_date = src_timestamp,
1530                              ms_obj_date = obj_timestamp })
1531
1532 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1533 findSummaryBySourceFile summaries file
1534   = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1535                                  expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1536         [] -> Nothing
1537         (x:xs) -> Just x
1538
1539 -- Summarise a module, and pick up source and timestamp.
1540 summariseModule
1541           :: HscEnv
1542           -> NodeMap ModSummary -- Map of old summaries
1543           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
1544           -> Located ModuleName -- Imported module to be summarised
1545           -> Maybe (StringBuffer, ClockTime)
1546           -> [ModuleName]               -- Modules to exclude
1547           -> IO (Maybe ModSummary)      -- Its new summary
1548
1549 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
1550   | wanted_mod `elem` excl_mods
1551   = return Nothing
1552
1553   | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1554   = do          -- Find its new timestamp; all the
1555                 -- ModSummaries in the old map have valid ml_hs_files
1556         let location = ms_location old_summary
1557             src_fn = expectJust "summariseModule" (ml_hs_file location)
1558
1559                 -- check the modification time on the source file, and
1560                 -- return the cached summary if it hasn't changed.  If the
1561                 -- file has disappeared, we need to call the Finder again.
1562         case maybe_buf of
1563            Just (_,t) -> check_timestamp old_summary location src_fn t
1564            Nothing    -> do
1565                 m <- System.IO.Error.try (getModificationTime src_fn)
1566                 case m of
1567                    Right t -> check_timestamp old_summary location src_fn t
1568                    Left e | isDoesNotExistError e -> find_it
1569                           | otherwise             -> ioError e
1570
1571   | otherwise  = find_it
1572   where
1573     dflags = hsc_dflags hsc_env
1574
1575     hsc_src = if is_boot then HsBootFile else HsSrcFile
1576
1577     check_timestamp old_summary location src_fn src_timestamp
1578         | ms_hs_date old_summary == src_timestamp = do
1579                 -- update the object-file timestamp
1580                 obj_timestamp <- getObjTimestamp location is_boot
1581                 return (Just old_summary{ ms_obj_date = obj_timestamp })
1582         | otherwise =
1583                 -- source changed: re-summarise.
1584                 new_summary location (ms_mod old_summary) src_fn src_timestamp
1585
1586     find_it = do
1587         -- Don't use the Finder's cache this time.  If the module was
1588         -- previously a package module, it may have now appeared on the
1589         -- search path, so we want to consider it to be a home module.  If
1590         -- the module was previously a home module, it may have moved.
1591         uncacheModule hsc_env wanted_mod
1592         found <- findImportedModule hsc_env wanted_mod Nothing
1593         case found of
1594              Found location mod
1595                 | isJust (ml_hs_file location) ->
1596                         -- Home package
1597                          just_found location mod
1598                 | otherwise ->
1599                         -- Drop external-pkg
1600                         ASSERT(modulePackageId mod /= thisPackage dflags)
1601                         return Nothing
1602                 where
1603
1604              err -> noModError dflags loc wanted_mod err
1605                         -- Not found
1606
1607     just_found location mod = do
1608                 -- Adjust location to point to the hs-boot source file,
1609                 -- hi file, object file, when is_boot says so
1610         let location' | is_boot   = addBootSuffixLocn location
1611                       | otherwise = location
1612             src_fn = expectJust "summarise2" (ml_hs_file location')
1613
1614                 -- Check that it exists
1615                 -- It might have been deleted since the Finder last found it
1616         maybe_t <- modificationTimeIfExists src_fn
1617         case maybe_t of
1618           Nothing -> noHsFileErr loc src_fn
1619           Just t  -> new_summary location' mod src_fn t
1620
1621
1622     new_summary location mod src_fn src_timestamp
1623       = do
1624         -- Preprocess the source file and get its imports
1625         -- The dflags' contains the OPTIONS pragmas
1626         (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1627         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
1628
1629         when (mod_name /= wanted_mod) $
1630                 throwDyn $ mkPlainErrMsg mod_loc $
1631                               text "file name does not match module name"
1632                               <+> quotes (ppr mod_name)
1633
1634                 -- Find the object timestamp, and return the summary
1635         obj_timestamp <- getObjTimestamp location is_boot
1636
1637         return (Just ( ModSummary { ms_mod       = mod,
1638                                     ms_hsc_src   = hsc_src,
1639                                     ms_location  = location,
1640                                     ms_hspp_file = hspp_fn,
1641                                     ms_hspp_opts = dflags',
1642                                     ms_hspp_buf  = Just buf,
1643                                     ms_srcimps   = srcimps,
1644                                     ms_imps      = the_imps,
1645                                     ms_hs_date   = src_timestamp,
1646                                     ms_obj_date  = obj_timestamp }))
1647
1648
1649 getObjTimestamp location is_boot
1650   = if is_boot then return Nothing
1651                else modificationTimeIfExists (ml_obj_file location)
1652
1653
1654 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1655   -> IO (DynFlags, FilePath, StringBuffer)
1656 preprocessFile dflags src_fn mb_phase Nothing
1657   = do
1658         (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1659         buf <- hGetStringBuffer hspp_fn
1660         return (dflags', hspp_fn, buf)
1661
1662 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1663   = do
1664         -- case we bypass the preprocessing stage?
1665         let
1666             local_opts = getOptions buf src_fn
1667         --
1668         (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
1669
1670         let
1671             needs_preprocessing
1672                 | Just (Unlit _) <- mb_phase    = True
1673                 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
1674                   -- note: local_opts is only required if there's no Unlit phase
1675                 | dopt Opt_Cpp dflags'          = True
1676                 | dopt Opt_Pp  dflags'          = True
1677                 | otherwise                     = False
1678
1679         when needs_preprocessing $
1680            ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1681
1682         return (dflags', src_fn, buf)
1683
1684
1685 -----------------------------------------------------------------------------
1686 --                      Error messages
1687 -----------------------------------------------------------------------------
1688
1689 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1690 -- ToDo: we don't have a proper line number for this error
1691 noModError dflags loc wanted_mod err
1692   = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1693
1694 noHsFileErr loc path
1695   = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1696
1697 packageModErr mod
1698   = throwDyn $ mkPlainErrMsg noSrcSpan $
1699         text "module" <+> quotes (ppr mod) <+> text "is a package module"
1700
1701 multiRootsErr :: [ModSummary] -> IO ()
1702 multiRootsErr summs@(summ1:_)
1703   = throwDyn $ mkPlainErrMsg noSrcSpan $
1704         text "module" <+> quotes (ppr mod) <+>
1705         text "is defined in multiple files:" <+>
1706         sep (map text files)
1707   where
1708     mod = ms_mod summ1
1709     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1710
1711 cyclicModuleErr :: [ModSummary] -> SDoc
1712 cyclicModuleErr ms
1713   = hang (ptext SLIT("Module imports form a cycle for modules:"))
1714        2 (vcat (map show_one ms))
1715   where
1716     show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1717                         nest 2 $ ptext SLIT("imports:") <+>
1718                                    (pp_imps HsBootFile (ms_srcimps ms)
1719                                    $$ pp_imps HsSrcFile  (ms_imps ms))]
1720     show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1721     pp_imps src mods = fsep (map (show_mod src) mods)
1722
1723
1724 -- | Inform GHC that the working directory has changed.  GHC will flush
1725 -- its cache of module locations, since it may no longer be valid.
1726 -- Note: if you change the working directory, you should also unload
1727 -- the current program (set targets to empty, followed by load).
1728 workingDirectoryChanged :: Session -> IO ()
1729 workingDirectoryChanged s = withSession s $ flushFinderCaches
1730
1731 -- -----------------------------------------------------------------------------
1732 -- inspecting the session
1733
1734 -- | Get the module dependency graph.
1735 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1736 getModuleGraph s = withSession s (return . hsc_mod_graph)
1737
1738 isLoaded :: Session -> ModuleName -> IO Bool
1739 isLoaded s m = withSession s $ \hsc_env ->
1740   return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1741
1742 getBindings :: Session -> IO [TyThing]
1743 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1744
1745 getPrintUnqual :: Session -> IO PrintUnqualified
1746 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1747
1748 -- | Container for information about a 'Module'.
1749 data ModuleInfo = ModuleInfo {
1750         minf_type_env  :: TypeEnv,
1751         minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
1752         minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
1753         minf_instances :: [Instance]
1754         -- ToDo: this should really contain the ModIface too
1755   }
1756         -- We don't want HomeModInfo here, because a ModuleInfo applies
1757         -- to package modules too.
1758
1759 -- | Request information about a loaded 'Module'
1760 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1761 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1762   let mg = hsc_mod_graph hsc_env
1763   if mdl `elem` map ms_mod mg
1764         then getHomeModuleInfo hsc_env (moduleName mdl)
1765         else do
1766   {- if isHomeModule (hsc_dflags hsc_env) mdl
1767         then return Nothing
1768         else -} getPackageModuleInfo hsc_env mdl
1769    -- getPackageModuleInfo will attempt to find the interface, so
1770    -- we don't want to call it for a home module, just in case there
1771    -- was a problem loading the module and the interface doesn't
1772    -- exist... hence the isHomeModule test here.  (ToDo: reinstate)
1773
1774 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1775 getPackageModuleInfo hsc_env mdl = do
1776 #ifdef GHCI
1777   (_msgs, mb_avails) <- getModuleExports hsc_env mdl
1778   case mb_avails of
1779     Nothing -> return Nothing
1780     Just avails -> do
1781         eps <- readIORef (hsc_EPS hsc_env)
1782         let
1783             names  = availsToNameSet avails
1784             pte    = eps_PTE eps
1785             tys    = [ ty | name <- concatMap availNames avails,
1786                             Just ty <- [lookupTypeEnv pte name] ]
1787         --
1788         return (Just (ModuleInfo {
1789                         minf_type_env  = mkTypeEnv tys,
1790                         minf_exports   = names,
1791                         minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
1792                         minf_instances = error "getModuleInfo: instances for package module unimplemented"
1793                 }))
1794 #else
1795   -- bogusly different for non-GHCI (ToDo)
1796   return Nothing
1797 #endif
1798
1799 getHomeModuleInfo hsc_env mdl =
1800   case lookupUFM (hsc_HPT hsc_env) mdl of
1801     Nothing  -> return Nothing
1802     Just hmi -> do
1803       let details = hm_details hmi
1804       return (Just (ModuleInfo {
1805                         minf_type_env  = md_types details,
1806                         minf_exports   = availsToNameSet (md_exports details),
1807                         minf_rdr_env   = mi_globals $! hm_iface hmi,
1808                         minf_instances = md_insts details
1809                         }))
1810
1811 -- | The list of top-level entities defined in a module
1812 modInfoTyThings :: ModuleInfo -> [TyThing]
1813 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1814
1815 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1816 modInfoTopLevelScope minf
1817   = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1818
1819 modInfoExports :: ModuleInfo -> [Name]
1820 modInfoExports minf = nameSetToList $! minf_exports minf
1821
1822 -- | Returns the instances defined by the specified module.
1823 -- Warning: currently unimplemented for package modules.
1824 modInfoInstances :: ModuleInfo -> [Instance]
1825 modInfoInstances = minf_instances
1826
1827 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1828 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1829
1830 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1831 modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
1832
1833 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1834 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1835    case lookupTypeEnv (minf_type_env minf) name of
1836      Just tyThing -> return (Just tyThing)
1837      Nothing      -> do
1838        eps <- readIORef (hsc_EPS hsc_env)
1839        return $! lookupType (hsc_dflags hsc_env)
1840                             (hsc_HPT hsc_env) (eps_PTE eps) name
1841
1842 isDictonaryId :: Id -> Bool
1843 isDictonaryId id
1844   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1845
1846 -- | Looks up a global name: that is, any top-level name in any
1847 -- visible module.  Unlike 'lookupName', lookupGlobalName does not use
1848 -- the interactive context, and therefore does not require a preceding
1849 -- 'setContext'.
1850 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1851 lookupGlobalName s name = withSession s $ \hsc_env -> do
1852    eps <- readIORef (hsc_EPS hsc_env)
1853    return $! lookupType (hsc_dflags hsc_env)
1854                         (hsc_HPT hsc_env) (eps_PTE eps) name
1855
1856 -- -----------------------------------------------------------------------------
1857 -- Misc exported utils
1858
1859 dataConType :: DataCon -> Type
1860 dataConType dc = idType (dataConWrapId dc)
1861
1862 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1863 pprParenSymName :: NamedThing a => a -> SDoc
1864 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1865
1866 -- ----------------------------------------------------------------------------
1867
1868 #if 0
1869
1870 -- ToDo:
1871 --   - Data and Typeable instances for HsSyn.
1872
1873 -- ToDo: check for small transformations that happen to the syntax in
1874 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1875
1876 -- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
1877 -- to get from TyCons, Ids etc. to TH syntax (reify).
1878
1879 -- :browse will use either lm_toplev or inspect lm_interface, depending
1880 -- on whether the module is interpreted or not.
1881
1882 -- This is for reconstructing refactored source code
1883 -- Calls the lexer repeatedly.
1884 -- ToDo: add comment tokens to token stream
1885 getTokenStream :: Session -> Module -> IO [Located Token]
1886 #endif
1887
1888 -- -----------------------------------------------------------------------------
1889 -- Interactive evaluation
1890
1891 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
1892 -- filesystem and package database to find the corresponding 'Module',
1893 -- using the algorithm that is used for an @import@ declaration.
1894 findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
1895 findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
1896   findModule' hsc_env mod_name maybe_pkg
1897
1898 findModule' hsc_env mod_name maybe_pkg =
1899   let
1900         dflags = hsc_dflags hsc_env
1901         hpt    = hsc_HPT hsc_env
1902         this_pkg = thisPackage dflags
1903   in
1904   case lookupUFM hpt mod_name of
1905     Just mod_info -> return (mi_module (hm_iface mod_info))
1906     _not_a_home_module -> do
1907           res <- findImportedModule hsc_env mod_name Nothing
1908           case res of
1909             Found _ m | modulePackageId m /= this_pkg -> return m
1910                       | otherwise -> throwDyn (CmdLineError (showSDoc $
1911                                         text "module" <+> pprModule m <+>
1912                                         text "is not loaded"))
1913             err -> let msg = cannotFindModule dflags mod_name err in
1914                    throwDyn (CmdLineError (showSDoc msg))
1915
1916 #ifdef GHCI
1917
1918 -- | Set the interactive evaluation context.
1919 --
1920 -- Setting the context doesn't throw away any bindings; the bindings
1921 -- we've built up in the InteractiveContext simply move to the new
1922 -- module.  They always shadow anything in scope in the current context.
1923 setContext :: Session
1924            -> [Module]  -- entire top level scope of these modules
1925            -> [Module]  -- exports only of these modules
1926            -> IO ()
1927 setContext (Session ref) toplev_mods export_mods = do
1928   hsc_env <- readIORef ref
1929   let old_ic  = hsc_IC     hsc_env
1930       hpt     = hsc_HPT    hsc_env
1931   --
1932   export_env  <- mkExportEnv hsc_env export_mods
1933   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
1934   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1935   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
1936                                             ic_exports      = export_mods,
1937                                             ic_rn_gbl_env   = all_env }}
1938
1939
1940 -- Make a GlobalRdrEnv based on the exports of the modules only.
1941 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1942 mkExportEnv hsc_env mods = do
1943   stuff <- mapM (getModuleExports hsc_env) mods
1944   let
1945         (_msgs, mb_name_sets) = unzip stuff
1946         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
1947                | (Just avails, mod) <- zip mb_name_sets mods ]
1948   --
1949   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1950
1951 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
1952 nameSetToGlobalRdrEnv names mod =
1953   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
1954                  | name <- nameSetToList names ]
1955
1956 vanillaProv :: ModuleName -> Provenance
1957 -- We're building a GlobalRdrEnv as if the user imported
1958 -- all the specified modules into the global interactive module
1959 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
1960   where
1961     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1962                          is_qual = False,
1963                          is_dloc = srcLocSpan interactiveSrcLoc }
1964
1965 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1966 mkTopLevEnv hpt modl
1967   = case lookupUFM hpt (moduleName modl) of
1968       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
1969                                                 showSDoc (ppr modl)))
1970       Just details ->
1971          case mi_globals (hm_iface details) of
1972                 Nothing  ->
1973                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1974                                                 ++ showSDoc (ppr modl)))
1975                 Just env -> return env
1976
1977 -- | Get the interactive evaluation context, consisting of a pair of the
1978 -- set of modules from which we take the full top-level scope, and the set
1979 -- of modules from which we take just the exports respectively.
1980 getContext :: Session -> IO ([Module],[Module])
1981 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1982                                 return (ic_toplev_scope ic, ic_exports ic))
1983
1984 -- | Returns 'True' if the specified module is interpreted, and hence has
1985 -- its full top-level scope available.
1986 moduleIsInterpreted :: Session -> Module -> IO Bool
1987 moduleIsInterpreted s modl = withSession s $ \h ->
1988  if modulePackageId modl /= thisPackage (hsc_dflags h)
1989         then return False
1990         else case lookupUFM (hsc_HPT h) (moduleName modl) of
1991                 Just details       -> return (isJust (mi_globals (hm_iface details)))
1992                 _not_a_home_module -> return False
1993
1994 -- | Looks up an identifier in the current interactive context (for :info)
1995 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
1996 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
1997
1998 -- | Returns all names in scope in the current interactive context
1999 getNamesInScope :: Session -> IO [Name]
2000 getNamesInScope s = withSession s $ \hsc_env -> do
2001   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
2002
2003 getRdrNamesInScope :: Session -> IO [RdrName]
2004 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
2005   let env = ic_rn_gbl_env (hsc_IC hsc_env)
2006   return (concat (map greToRdrNames (globalRdrEnvElts env)))
2007
2008 -- ToDo: move to RdrName
2009 greToRdrNames :: GlobalRdrElt -> [RdrName]
2010 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
2011   = case prov of
2012      LocalDef -> [unqual]
2013      Imported specs -> concat (map do_spec (map is_decl specs))
2014   where
2015     occ = nameOccName name
2016     unqual = Unqual occ
2017     do_spec decl_spec
2018         | is_qual decl_spec = [qual]
2019         | otherwise         = [unqual,qual]
2020         where qual = Qual (is_as decl_spec) occ
2021
2022 -- | Parses a string as an identifier, and returns the list of 'Name's that
2023 -- the identifier can refer to in the current interactive context.
2024 parseName :: Session -> String -> IO [Name]
2025 parseName s str = withSession s $ \hsc_env -> do
2026    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
2027    case maybe_rdr_name of
2028         Nothing -> return []
2029         Just (L _ rdr_name) -> do
2030             mb_names <- tcRnLookupRdrName hsc_env rdr_name
2031             case mb_names of
2032                 Nothing -> return []
2033                 Just ns -> return ns
2034                 -- ToDo: should return error messages
2035
2036 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
2037 -- entity known to GHC, including 'Name's defined using 'runStmt'.
2038 lookupName :: Session -> Name -> IO (Maybe TyThing)
2039 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
2040
2041 -- -----------------------------------------------------------------------------
2042 -- Getting the type of an expression
2043
2044 -- | Get the type of an expression
2045 exprType :: Session -> String -> IO (Maybe Type)
2046 exprType s expr = withSession s $ \hsc_env -> do
2047    maybe_stuff <- hscTcExpr hsc_env expr
2048    case maybe_stuff of
2049         Nothing -> return Nothing
2050         Just ty -> return (Just tidy_ty)
2051              where
2052                 tidy_ty = tidyType emptyTidyEnv ty
2053
2054 -- -----------------------------------------------------------------------------
2055 -- Getting the kind of a type
2056
2057 -- | Get the kind of a  type
2058 typeKind  :: Session -> String -> IO (Maybe Kind)
2059 typeKind s str = withSession s $ \hsc_env -> do
2060    maybe_stuff <- hscKcType hsc_env str
2061    case maybe_stuff of
2062         Nothing -> return Nothing
2063         Just kind -> return (Just kind)
2064
2065 -----------------------------------------------------------------------------
2066 -- cmCompileExpr: compile an expression and deliver an HValue
2067
2068 compileExpr :: Session -> String -> IO (Maybe HValue)
2069 compileExpr s expr = withSession s $ \hsc_env -> do
2070   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
2071   case maybe_stuff of
2072         Nothing -> return Nothing
2073         Just (new_ic, names, hval) -> do
2074                         -- Run it!
2075                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
2076
2077                 case (names,hvals) of
2078                   ([n],[hv]) -> return (Just hv)
2079                   _          -> panic "compileExpr"
2080
2081 -- -----------------------------------------------------------------------------
2082 -- Compile an expression into a dynamic
2083
2084 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
2085 dynCompileExpr ses expr = do
2086     (full,exports) <- getContext ses
2087     setContext ses full $
2088         (mkModule
2089             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
2090         ):exports
2091     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
2092     res <- withSession ses (flip hscStmt stmt)
2093     setContext ses full exports
2094     case res of
2095         Nothing -> return Nothing
2096         Just (_, names, hvals) -> do
2097             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
2098             case (names,vals) of
2099                 (_:[], v:[])    -> return (Just v)
2100                 _               -> panic "dynCompileExpr"
2101
2102 -- -----------------------------------------------------------------------------
2103 -- running a statement interactively
2104
2105 data RunResult
2106   = RunOk [Name]                -- ^ names bound by this evaluation
2107   | RunFailed                   -- ^ statement failed compilation
2108   | RunException Exception      -- ^ statement raised an exception
2109
2110 -- | Run a statement in the current interactive context.  Statemenet
2111 -- may bind multple values.
2112 runStmt :: Session -> String -> IO RunResult
2113 runStmt (Session ref) expr
2114    = do
2115         hsc_env <- readIORef ref
2116
2117         -- Turn off -fwarn-unused-bindings when running a statement, to hide
2118         -- warnings about the implicit bindings we introduce.
2119         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
2120             hsc_env' = hsc_env{ hsc_dflags = dflags' }
2121
2122         maybe_stuff <- hscStmt hsc_env' expr
2123
2124         case maybe_stuff of
2125            Nothing -> return RunFailed
2126            Just (new_hsc_env, names, hval) -> do
2127
2128                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
2129                 either_hvals <- sandboxIO thing_to_run
2130
2131                 case either_hvals of
2132                     Left e -> do
2133                         -- on error, keep the *old* interactive context,
2134                         -- so that 'it' is not bound to something
2135                         -- that doesn't exist.
2136                         return (RunException e)
2137
2138                     Right hvals -> do
2139                         -- Get the newly bound things, and bind them.
2140                         -- Don't need to delete any shadowed bindings;
2141                         -- the new ones override the old ones.
2142                         extendLinkEnv (zip names hvals)
2143
2144                         writeIORef ref new_hsc_env
2145                         return (RunOk names)
2146
2147 -- When running a computation, we redirect ^C exceptions to the running
2148 -- thread.  ToDo: we might want a way to continue even if the target
2149 -- thread doesn't die when it receives the exception... "this thread
2150 -- is not responding".
2151 sandboxIO :: IO a -> IO (Either Exception a)
2152 sandboxIO thing = do
2153   m <- newEmptyMVar
2154   ts <- takeMVar interruptTargetThread
2155   child <- forkIO (do res <- Exception.try thing; putMVar m res)
2156   putMVar interruptTargetThread (child:ts)
2157   takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
2158
2159 {-
2160 -- This version of sandboxIO runs the expression in a completely new
2161 -- RTS main thread.  It is disabled for now because ^C exceptions
2162 -- won't be delivered to the new thread, instead they'll be delivered
2163 -- to the (blocked) GHCi main thread.
2164
2165 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
2166
2167 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
2168 sandboxIO thing = do
2169   st_thing <- newStablePtr (Exception.try thing)
2170   alloca $ \ p_st_result -> do
2171     stat <- rts_evalStableIO st_thing p_st_result
2172     freeStablePtr st_thing
2173     if stat == 1
2174         then do st_result <- peek p_st_result
2175                 result <- deRefStablePtr st_result
2176                 freeStablePtr st_result
2177                 return (Right result)
2178         else do
2179                 return (Left (fromIntegral stat))
2180
2181 foreign import "rts_evalStableIO"  {- safe -}
2182   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
2183   -- more informative than the C type!
2184 -}
2185
2186 -----------------------------------------------------------------------------
2187 -- show a module and it's source/object filenames
2188
2189 showModule :: Session -> ModSummary -> IO String
2190 showModule s mod_summary = withSession s $ \hsc_env -> do
2191   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
2192         Nothing       -> panic "missing linkable"
2193         Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
2194                       where
2195                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
2196
2197 obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
2198 obtainTerm sess force id = withSession sess $ \hsc_env ->
2199               getHValue (varName id) >>= traverse (cvObtainTerm hsc_env force Nothing)
2200
2201 #endif /* GHCI */