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