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