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