ghc/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         init,
  15         newSession,
  16
  17         -- * Flags and settings
  18         DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
  19         parseDynamicFlags,
  20         getSessionDynFlags,
  21         setSessionDynFlags,
  22         setMsgHandler,
  23
  24         -- * Targets
  25         Target(..),
  26         setTargets,
  27         getTargets,
  28         addTarget,
  29         guessTarget,
  30
  31         -- * Loading/compiling the program
  32         depanal,
  33         load, SuccessFlag(..),          -- also does depanal
  34         workingDirectoryChanged,
  35
  36         -- * Inspecting the module structure of the program
  37         ModuleGraph, ModSummary(..),
  38         getModuleGraph,
  39         topSortModuleGraph,
  40
  41         -- * Interactive evaluation
  42         getBindings, getPrintUnqual,
  43 #ifdef GHCI
  44         setContext, getContext,
  45         moduleIsInterpreted,
  46         getInfo, GetInfoResult,
  47         exprType,
  48         typeKind,
  49         lookupName,
  50         RunResult(..),
  51         runStmt,
  52         browseModule,
  53         showModule,
  54         compileExpr, HValue,
  55 #endif
  56
  57         -- * Abstract syntax elements
  58         Module, mkModule, pprModule,
  59         Type, dropForAlls,
  60         Kind,
  61         Name, Id, TyCon, Class, DataCon,
  62         TyThing(..),
  63         idType,
  64
  65         -- used by DriverMkDepend:
  66         sessionHscEnv,
  67         cyclicModuleErr,
  68   ) where
  69
  70 {-
  71  ToDo:
  72
  73   * return error messages rather than printing them.
  74   * inline bits of HscMain here to simplify layering: hscGetInfo,
  75     hscTcExpr, hscStmt.
  76   * implement second argument to load.
  77   * we need to expose DynFlags, so should parseDynamicFlags really be
  78     part of this interface?
  79   * what StaticFlags should we expose, if any?
  80 -}
  81
  82 #include "HsVersions.h"
  83
  84 #ifdef GHCI
  85 import qualified Linker
  86 import Linker           ( HValue, extendLinkEnv )
  87 import NameEnv          ( lookupNameEnv )
  88 import TcRnDriver       ( mkExportEnv, getModuleContents )
  89 import RdrName          ( GlobalRdrEnv, plusGlobalRdrEnv )
  90 import HscMain          ( hscGetInfo, GetInfoResult,
  91                           hscStmt, hscTcExpr, hscKcType )
  92 import Type             ( tidyType )
  93 import VarEnv           ( emptyTidyEnv )
  94 import GHC.Exts         ( unsafeCoerce# )
  95 import IfaceSyn         ( IfaceDecl )
  96 #endif
  97
  98 import Type             ( Kind, Type, dropForAlls )
  99 import Id               ( Id, idType )
 100 import TyCon            ( TyCon )
 101 import Class            ( Class )
 102 import DataCon          ( DataCon )
 103 import Name             ( Name )
 104 import NameEnv          ( nameEnvElts )
 105 import DriverPipeline   ( preprocess, compile, CompResult(..), link )
 106 import DriverPhases     ( isHaskellSrcFilename )
 107 import GetImports       ( getImports )
 108 import Packages         ( isHomePackage )
 109 import Finder
 110 import HscMain          ( newHscEnv )
 111 import HscTypes
 112 import DynFlags
 113 import StaticFlags
 114 import SysTools         ( initSysTools, cleanTempFiles )
 115 import Module
 116 import FiniteMap
 117 import Panic
 118 import Digraph          ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
 119 import ErrUtils         ( showPass )
 120 import qualified ErrUtils
 121 import Util
 122 import StringBuffer     ( hGetStringBuffer )
 123 import Outputable
 124 import SysTools         ( cleanTempFilesExcept )
 125 import BasicTypes       ( SuccessFlag(..), succeeded )
 126 import Maybes           ( orElse, expectJust, mapCatMaybes )
 127
 128 import Directory        ( getModificationTime, doesFileExist )
 129 import Maybe            ( isJust, fromJust )
 130 import List             ( partition, nub )
 131 import Monad            ( unless, when, foldM )
 132 import System           ( exitWith, ExitCode(..) )
 133 import EXCEPTION as Exception hiding (handle)
 134 import DATA_IOREF
 135 import IO
 136 import Prelude hiding (init)
 137
 138 -- -----------------------------------------------------------------------------
 139 -- Exception handlers
 140
 141 -- | Install some default exception handlers and run the inner computation.
 142 -- Unless you want to handle exceptions yourself, you should wrap this around
 143 -- the top level of your program.  The default handlers output the error
 144 -- message(s) to stderr and exit cleanly.
 145 defaultErrorHandler :: IO a -> IO a
 146 defaultErrorHandler inner =
 147   -- top-level exception handler: any unrecognised exception is a compiler bug.
 148   handle (\exception -> do
 149            hFlush stdout
 150            case exception of
 151                 -- an IO exception probably isn't our fault, so don't panic
 152                 IOException _ ->  hPutStrLn stderr (show exception)
 153                 AsyncException StackOverflow ->
 154                         hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
 155                 _other ->  hPutStr stderr (show (Panic (show exception)))
 156            exitWith (ExitFailure 1)
 157          ) $
 158
 159   -- all error messages are propagated as exceptions
 160   handleDyn (\dyn -> do
 161                 hFlush stdout
 162                 case dyn of
 163                      PhaseFailed _ code -> exitWith code
 164                      Interrupted -> exitWith (ExitFailure 1)
 165                      _ -> do hPutStrLn stderr (show (dyn :: GhcException))
 166                              exitWith (ExitFailure 1)
 167             ) $
 168   inner
 169
 170 -- | Install a default cleanup handler to remove temporary files
 171 -- deposited by a GHC run.  This is seperate from
 172 -- 'defaultErrorHandler', because you might want to override the error
 173 -- handling, but still get the ordinary cleanup behaviour.
 174 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 175 defaultCleanupHandler dflags inner =
 176    -- make sure we clean up after ourselves
 177    later (unless (dopt Opt_KeepTmpFiles dflags) $
 178             cleanTempFiles dflags)
 179         -- exceptions will be blocked while we clean the temporary files,
 180         -- so there shouldn't be any difficulty if we receive further
 181         -- signals.
 182    inner
 183
 184
 185 -- | Initialises GHC.  This must be done /once/ only.  Takes the
 186 -- command-line arguments.  All command-line arguments which aren't
 187 -- understood by GHC will be returned.
 188
 189 init :: [String] -> IO [String]
 190 init args = do
 191    -- catch ^C
 192    installSignalHandlers
 193
 194    -- Grab the -B option if there is one
 195    let (minusB_args, argv1) = partition (prefixMatch "-B") args
 196    dflags0 <- initSysTools minusB_args defaultDynFlags
 197    writeIORef v_initDynFlags dflags0
 198
 199    -- Parse the static flags
 200    argv2 <- parseStaticFlags argv1
 201    return argv2
 202
 203 GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
 204         -- stores the DynFlags between the call to init and subsequent
 205         -- calls to newSession.
 206
 207 -- | Starts a new session.  A session consists of a set of loaded
 208 -- modules, a set of options (DynFlags), and an interactive context.
 209 -- ToDo: GhcMode should say "keep typechecked code" and/or "keep renamed
 210 -- code".
 211 newSession :: GhcMode -> IO Session
 212 newSession mode = do
 213   dflags0 <- readIORef v_initDynFlags
 214   dflags <- initDynFlags dflags0
 215   env <- newHscEnv dflags{ ghcMode=mode }
 216   ref <- newIORef env
 217   return (Session ref)
 218
 219 -- tmp: this breaks the abstraction, but required because DriverMkDepend
 220 -- needs to call the Finder.  ToDo: untangle this.
 221 sessionHscEnv :: Session -> IO HscEnv
 222 sessionHscEnv (Session ref) = readIORef ref
 223
 224 withSession :: Session -> (HscEnv -> IO a) -> IO a
 225 withSession (Session ref) f = do h <- readIORef ref; f h
 226
 227 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
 228 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
 229
 230 -- -----------------------------------------------------------------------------
 231 -- Flags & settings
 232
 233 -- | Grabs the DynFlags from the Session
 234 getSessionDynFlags :: Session -> IO DynFlags
 235 getSessionDynFlags s = withSession s (return . hsc_dflags)
 236
 237 -- | Updates the DynFlags in a Session
 238 setSessionDynFlags :: Session -> DynFlags -> IO ()
 239 setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
 240
 241 -- | Messages during compilation (eg. warnings and progress messages)
 242 -- are reported using this callback.  By default, these messages are
 243 -- printed to stderr.
 244 setMsgHandler :: (String -> IO ()) -> IO ()
 245 setMsgHandler = ErrUtils.setMsgHandler
 246
 247 -- -----------------------------------------------------------------------------
 248 -- Targets
 249
 250 -- ToDo: think about relative vs. absolute file paths. And what
 251 -- happens when the current directory changes.
 252
 253 -- | Sets the targets for this session.  Each target may be a module name
 254 -- or a filename.  The targets correspond to the set of root modules for
 255 -- the program/library.  Unloading the current program is achieved by
 256 -- setting the current set of targets to be empty, followed by load.
 257 setTargets :: Session -> [Target] -> IO ()
 258 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
 259
 260 -- | returns the current set of targets
 261 getTargets :: Session -> IO [Target]
 262 getTargets s = withSession s (return . hsc_targets)
 263
 264 -- Add another target, or update an existing target with new content.
 265 addTarget :: Session -> Target -> IO ()
 266 addTarget s target
 267   = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
 268
 269 -- Remove a target
 270 -- removeTarget :: Session -> Module -> IO ()
 271
 272 -- Attempts to guess what Target a string refers to.  This function implements
 273 -- the --make/GHCi command-line syntax for filenames:
 274 --
 275 --      - if the string looks like a Haskell source filename, then interpret
 276 --        it as such
 277 --      - if adding a .hs or .lhs suffix yields the name of an existing file,
 278 --        then use that
 279 --      - otherwise interpret the string as a module name
 280 --
 281 guessTarget :: String -> IO Target
 282 guessTarget file
 283    | isHaskellSrcFilename file
 284    = return (Target (TargetFile file) Nothing)
 285    | otherwise
 286    = do exists <- doesFileExist hs_file
 287         if exists then return (Target (TargetFile hs_file) Nothing) else do
 288         exists <- doesFileExist lhs_file
 289         if exists then return (Target (TargetFile lhs_file) Nothing) else do
 290         return (Target (TargetModule (mkModule file)) Nothing)
 291      where
 292          hs_file = file ++ ".hs"
 293          lhs_file = file ++ ".lhs"
 294
 295 -- -----------------------------------------------------------------------------
 296 -- Loading the program
 297
 298 -- | The result of load.
 299 data LoadResult
 300   = LoadOk      Errors  -- ^ all specified targets were loaded successfully.
 301   | LoadFailed  Errors  -- ^ not all modules were loaded.
 302
 303 type Errors = [String]
 304
 305 {-
 306 data ErrMsg = ErrMsg {
 307         errMsgSeverity  :: Severity,  -- warning, error, etc.
 308         errMsgSpans     :: [SrcSpan],
 309         errMsgShortDoc  :: Doc,
 310         errMsgExtraInfo :: Doc
 311         }
 312 -}
 313
 314 -- Perform a dependency analysis starting from the current targets
 315 -- and update the session with the new module graph.
 316 depanal :: Session -> [Module] -> IO ()
 317 depanal (Session ref) excluded_mods = do
 318   hsc_env <- readIORef ref
 319   let
 320          dflags  = hsc_dflags hsc_env
 321          gmode   = ghcMode (hsc_dflags hsc_env)
 322          targets = hsc_targets hsc_env
 323          old_graph = hsc_mod_graph hsc_env
 324
 325   showPass dflags "Chasing dependencies"
 326   when (verbosity dflags >= 1 && gmode == BatchCompile) $
 327                hPutStrLn stderr (showSDoc (hcat [
 328                      text "Chasing modules from: ",
 329                         hcat (punctuate comma (map pprTarget targets))]))
 330
 331   graph <- downsweep hsc_env old_graph excluded_mods
 332   writeIORef ref hsc_env{ hsc_mod_graph=graph }
 333
 334
 335 -- | Try to load the program.  If a Module is supplied, then just
 336 -- attempt to load up to this target.  If no Module is supplied,
 337 -- then try to load all targets.
 338 load :: Session -> Maybe Module -> IO SuccessFlag
 339 load s@(Session ref) maybe_mod{-ToDo-}
 340    = do
 341         -- dependency analysis first
 342         depanal s []
 343
 344         hsc_env <- readIORef ref
 345
 346         let hpt1      = hsc_HPT hsc_env
 347         let dflags    = hsc_dflags hsc_env
 348         let mod_graph = hsc_mod_graph hsc_env
 349
 350         let ghci_mode = ghcMode (hsc_dflags hsc_env) -- this never changes
 351         let verb      = verbosity dflags
 352
 353         -- The "bad" boot modules are the ones for which we have
 354         -- B.hs-boot in the module graph, but no B.hs
 355         -- The downsweep should have ensured this does not happen
 356         -- (see msDeps)
 357         let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)]
 358             bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
 359                                         not (ms_mod s `elem` all_home_mods)]
 360         ASSERT( null bad_boot_mods ) return ()
 361
 362         -- Topologically sort the module graph
 363         -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes
 364         let mg2 :: [SCC ModSummary]
 365             mg2 = topSortModuleGraph False mod_graph
 366
 367         -- mg2_with_srcimps drops the hi-boot nodes, returning a
 368         -- graph with cycles.  Among other things, it is used for
 369         -- backing out partially complete cycles following a failed
 370         -- upsweep, and for removing from hpt all the modules
 371         -- not in strict downwards closure, during calls to compile.
 372         let mg2_with_srcimps :: [SCC ModSummary]
 373             mg2_with_srcimps = topSortModuleGraph True mod_graph
 374
 375         -- Sort out which linkables we wish to keep in the unlinked image.
 376         -- See getValidLinkables below for details.
 377         (valid_old_linkables, new_linkables)
 378             <- getValidLinkables ghci_mode (hptLinkables hpt1)
 379                   all_home_mods mg2_with_srcimps
 380
 381         -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables]))
 382
 383         -- The new_linkables are .o files we found on the disk, presumably
 384         -- as a result of a GHC run "on the side".  So we'd better forget
 385         -- everything we know abouut those modules!
 386         let old_hpt = delModuleEnvList hpt1 (map linkableModule new_linkables)
 387
 388         -- When (verb >= 2) $
 389         --    putStrLn (showSDoc (text "Valid linkables:"
 390         --                       <+> ppr valid_linkables))
 391
 392         -- Figure out a stable set of modules which can be retained
 393         -- the top level envs, to avoid upsweeping them.  Goes to a
 394         -- bit of trouble to avoid upsweeping module cycles.
 395         --
 396         -- Construct a set S of stable modules like this:
 397         -- Travel upwards, over the sccified graph.  For each scc
 398         -- of modules ms, add ms to S only if:
 399         -- 1.  All home imports of ms are either in ms or S
 400         -- 2.  A valid old linkable exists for each module in ms
 401
 402         -- mg2_with_srcimps has no hi-boot nodes,
 403         -- and hence neither does stable_mods
 404         stable_summaries <- preUpsweep valid_old_linkables
 405                                        all_home_mods [] mg2_with_srcimps
 406         let stable_mods      = map ms_mod stable_summaries
 407             stable_linkables = filter (\m -> linkableModule m `elem` stable_mods)
 408                                       valid_old_linkables
 409
 410             stable_hpt = filterModuleEnv is_stable_hm hpt1
 411             is_stable_hm hm_info = mi_module (hm_iface hm_info) `elem` stable_mods
 412
 413             upsweep_these
 414                = filter (\scc -> any (`notElem` stable_mods)
 415                                      (map ms_mod (flattenSCC scc)))
 416                         mg2
 417
 418         when (verb >= 2) $
 419            hPutStrLn stderr (showSDoc (text "Stable modules:"
 420                                <+> sep (map (text.moduleUserString) stable_mods)))
 421
 422         -- Unload any modules which are going to be re-linked this time around.
 423         unload hsc_env stable_linkables
 424
 425         -- We can now glom together our linkable sets
 426         let valid_linkables = valid_old_linkables ++ new_linkables
 427
 428         -- We could at this point detect cycles which aren't broken by
 429         -- a source-import, and complain immediately, but it seems better
 430         -- to let upsweep_mods do this, so at least some useful work gets
 431         -- done before the upsweep is abandoned.
 432         --hPutStrLn stderr "after tsort:\n"
 433         --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 434
 435         -- Now do the upsweep, calling compile for each module in
 436         -- turn.  Final result is version 3 of everything.
 437
 438         -- clean up between compilations
 439         let cleanup = cleanTempFilesExcept dflags
 440                           (ppFilesFromSummaries (flattenSCCs mg2))
 441
 442         (upsweep_ok, hsc_env3, modsUpswept)
 443            <- upsweep_mods (hsc_env { hsc_HPT = stable_hpt })
 444                            (old_hpt, valid_linkables)
 445                            cleanup upsweep_these
 446
 447         -- At this point, modsUpswept and newLis should have the same
 448         -- length, so there is one new (or old) linkable for each
 449         -- mod which was processed (passed to compile).
 450
 451         -- Make modsDone be the summaries for each home module now
 452         -- available; this should equal the domain of hpt3.
 453         -- (NOT STRICTLY TRUE if an interactive session was started
 454         --  with some object on disk ???)
 455         -- Get in in a roughly top .. bottom order (hence reverse).
 456
 457         let modsDone = reverse modsUpswept ++ stable_summaries
 458
 459         -- Try and do linking in some form, depending on whether the
 460         -- upsweep was completely or only partially successful.
 461
 462         if succeeded upsweep_ok
 463
 464          then
 465            -- Easy; just relink it all.
 466            do when (verb >= 2) $
 467                  hPutStrLn stderr "Upsweep completely successful."
 468
 469               -- Clean up after ourselves
 470               cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
 471
 472               -- Issue a warning for the confusing case where the user
 473               -- said '-o foo' but we're not going to do any linking.
 474               -- We attempt linking if either (a) one of the modules is
 475               -- called Main, or (b) the user said -no-hs-main, indicating
 476               -- that main() is going to come from somewhere else.
 477               --
 478               let ofile = outputFile dflags
 479               let no_hs_main = dopt Opt_NoHsMain dflags
 480               let mb_main_mod = mainModIs dflags
 481               let
 482                 main_mod = mb_main_mod `orElse` "Main"
 483                 a_root_is_Main
 484                     = any ((==main_mod).moduleUserString.ms_mod)
 485                           mod_graph
 486                 do_linking = a_root_is_Main || no_hs_main
 487
 488               when (ghci_mode == BatchCompile && isJust ofile && not do_linking
 489                      && verb > 0) $
 490                  hPutStrLn stderr ("Warning: output was redirected with -o, " ++
 491                                    "but no output will be generated\n" ++
 492                                    "because there is no " ++ main_mod ++ " module.")
 493
 494               -- link everything together
 495               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3)
 496
 497               let hsc_env4 = hsc_env3{ hsc_mod_graph = modsDone }
 498               loadFinish Succeeded linkresult ref hsc_env4
 499
 500          else
 501            -- Tricky.  We need to back out the effects of compiling any
 502            -- half-done cycles, both so as to clean up the top level envs
 503            -- and to avoid telling the interactive linker to link them.
 504            do when (verb >= 2) $
 505                 hPutStrLn stderr "Upsweep partially successful."
 506
 507               let modsDone_names
 508                      = map ms_mod modsDone
 509               let mods_to_zap_names
 510                      = findPartiallyCompletedCycles modsDone_names
 511                           mg2_with_srcimps
 512               let mods_to_keep
 513                      = filter ((`notElem` mods_to_zap_names).ms_mod)
 514                           modsDone
 515
 516               let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep)
 517                                               (hsc_HPT hsc_env3)
 518
 519               -- Clean up after ourselves
 520               cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
 521
 522               -- Link everything together
 523               linkresult <- link ghci_mode dflags False hpt4
 524
 525               let hsc_env4 = hsc_env3{ hsc_mod_graph = mods_to_keep,
 526                                        hsc_HPT = hpt4 }
 527               loadFinish Failed linkresult ref hsc_env4
 528
 529 -- Finish up after a load.
 530
 531 -- If the link failed, unload everything and return.
 532 loadFinish all_ok Failed ref hsc_env
 533   = do unload hsc_env []
 534        writeIORef ref $! discardProg hsc_env
 535        return Failed
 536
 537 -- Empty the interactive context and set the module context to the topmost
 538 -- newly loaded module, or the Prelude if none were loaded.
 539 loadFinish all_ok Succeeded ref hsc_env
 540   = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
 541        return all_ok
 542
 543 -- Forget the current program, but retain the persistent info in HscEnv
 544 discardProg :: HscEnv -> HscEnv
 545 discardProg hsc_env
 546   = hsc_env { hsc_mod_graph = emptyMG,
 547               hsc_IC = emptyInteractiveContext,
 548               hsc_HPT = emptyHomePackageTable }
 549
 550 -- used to fish out the preprocess output files for the purposes of
 551 -- cleaning up.  The preprocessed file *might* be the same as the
 552 -- source file, but that doesn't do any harm.
 553 ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
 554
 555 -----------------------------------------------------------------------------
 556 -- Unloading
 557
 558 unload :: HscEnv -> [Linkable] -> IO ()
 559 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
 560   = case ghcMode (hsc_dflags hsc_env) of
 561         BatchCompile -> return ()
 562 #ifdef GHCI
 563         Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
 564 #else
 565         Interactive -> panic "unload: no interpreter"
 566 #endif
 567         other -> panic "unload: strange mode"
 568
 569 -----------------------------------------------------------------------------
 570 -- getValidLinkables
 571
 572 -- For each module (or SCC of modules), we take:
 573 --
 574 --      - an on-disk linkable, if this is the first time around and one
 575 --        is available.
 576 --
 577 --      - the old linkable, otherwise (and if one is available).
 578 --
 579 -- and we throw away the linkable if it is older than the source file.
 580 -- In interactive mode, we also ignore the on-disk linkables unless
 581 -- all of the dependents of this SCC also have on-disk linkables (we
 582 -- can't have dynamically loaded objects that depend on interpreted
 583 -- modules in GHCi).
 584 --
 585 -- If a module has a valid linkable, then it may be STABLE (see below),
 586 -- and it is classified as SOURCE UNCHANGED for the purposes of calling
 587 -- compile.
 588 --
 589 -- ToDo: this pass could be merged with the preUpsweep.
 590 --
 591 -- ****************
 592 -- CAREFUL!  This pass operates on the cyclic version of
 593 -- the module graph (topSortModuleGraph True), whereas the upsweep operates on
 594 -- the non-cyclic (topSortModuleGraph False) version of the graph.
 595 -- ****************
 596
 597 getValidLinkables
 598         :: GhcMode
 599         -> [Linkable]           -- old linkables
 600         -> [Module]             -- all home modules
 601         -> [SCC ModSummary]     -- all modules in the program, dependency order
 602         -> IO ( [Linkable],     -- still-valid linkables
 603                 [Linkable]      -- new linkables we just found on the disk
 604                                 -- presumably generated by separate run of ghc
 605               )
 606
 607 getValidLinkables mode old_linkables all_home_mods module_graph
 608   = do  {       -- Process the SCCs in bottom-to-top order
 609                 -- (foldM works left-to-right)
 610           ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods)
 611                       [] module_graph
 612         ; return (partition_it ls [] []) }
 613  where
 614   partition_it []         valid new = (valid,new)
 615   partition_it ((l,b):ls) valid new
 616         | b         = partition_it ls valid (l:new)
 617         | otherwise = partition_it ls (l:valid) new
 618
 619
 620 getValidLinkablesSCC
 621         :: GhcMode
 622         -> [Linkable]           -- old linkables
 623         -> [Module]             -- all home modules
 624         -> [(Linkable,Bool)]
 625         -> SCC ModSummary
 626         -> IO [(Linkable,Bool)]
 627
 628 getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0
 629    = let
 630           scc             = flattenSCC scc0
 631           scc_names       = map ms_mod scc
 632           home_module m   = m `elem` all_home_mods && m `notElem` scc_names
 633           scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc))
 634                 -- NB. ms_imps, not ms_allimps above.  We don't want to
 635                 -- force a module's SOURCE imports to be already compiled for
 636                 -- its object linkable to be valid.
 637
 638                 -- The new_linkables is only the *valid* linkables below here
 639           has_object m = case findModuleLinkable_maybe (map fst new_linkables) m of
 640                             Nothing -> False
 641                             Just l  -> isObjectLinkable l
 642
 643           objects_allowed = mode == BatchCompile || all has_object scc_allhomeimps
 644      in do
 645
 646      new_linkables'
 647         <- foldM (getValidLinkable old_linkables objects_allowed) [] scc
 648
 649         -- since an scc can contain only all objects or no objects at all,
 650         -- we have to check whether we got all objects or not, and re-do
 651         -- the linkable check if not.
 652      new_linkables' <-
 653         if objects_allowed
 654              && not (all isObjectLinkable (map fst new_linkables'))
 655           then foldM (getValidLinkable old_linkables False) [] scc
 656           else return new_linkables'
 657
 658      return (new_linkables ++ new_linkables')
 659
 660
 661 getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary
 662         -> IO [(Linkable,Bool)]
 663         -- True <=> linkable is new; i.e. freshly discovered on the disk
 664         --                                presumably generated 'on the side'
 665         --                                by a separate GHC run
 666 getValidLinkable old_linkables objects_allowed new_linkables summary
 667         -- 'objects_allowed' says whether we permit this module to
 668         -- have a .o-file linkable.  We only permit it if all the
 669         -- modules it depends on also have .o files; a .o file can't
 670         -- link to a bytecode module
 671    = do let mod_name = ms_mod summary
 672
 673         maybe_disk_linkable
 674           <- if (not objects_allowed)
 675                 then return Nothing
 676
 677                 else findLinkable mod_name (ms_location summary)
 678
 679         let old_linkable = findModuleLinkable_maybe old_linkables mod_name
 680
 681             new_linkables' =
 682              case (old_linkable, maybe_disk_linkable) of
 683                 (Nothing, Nothing)                      -> []
 684
 685                 -- new object linkable just appeared
 686                 (Nothing, Just l)                       -> up_to_date l True
 687
 688                 (Just l,  Nothing)
 689                   | isObjectLinkable l                  -> []
 690                     -- object linkable disappeared!  In case we need to
 691                     -- relink the module, disregard the old linkable and
 692                     -- just interpret the module from now on.
 693                   | otherwise                           -> up_to_date l False
 694                     -- old byte code linkable
 695
 696                 (Just l, Just l')
 697                   | not (isObjectLinkable l)            -> up_to_date l  False
 698                     -- if the previous linkable was interpreted, then we
 699                     -- ignore a newly compiled version, because the version
 700                     -- numbers in the interface file will be out-of-sync with
 701                     -- our internal ones.
 702                   | linkableTime l' >  linkableTime l   -> up_to_date l' True
 703                   | linkableTime l' == linkableTime l   -> up_to_date l  False
 704                   | otherwise                           -> []
 705                     -- on-disk linkable has been replaced by an older one!
 706                     -- again, disregard the previous one.
 707
 708             up_to_date l b
 709                 | linkableTime l < ms_hs_date summary = []
 710                 | otherwise = [(l,b)]
 711                 -- why '<' rather than '<=' above?  If the filesystem stores
 712                 -- times to the nearset second, we may occasionally find that
 713                 -- the object & source have the same modification time,
 714                 -- especially if the source was automatically generated
 715                 -- and compiled.  Using >= is slightly unsafe, but it matches
 716                 -- make's behaviour.
 717
 718         return (new_linkables' ++ new_linkables)
 719
 720
 721 hptLinkables :: HomePackageTable -> [Linkable]
 722 -- Get all the linkables from the home package table, one for each module
 723 -- Once the HPT is up to date, these are the ones we should link
 724 hptLinkables hpt = map hm_linkable (moduleEnvElts hpt)
 725
 726
 727 -----------------------------------------------------------------------------
 728 -- Do a pre-upsweep without use of "compile", to establish a
 729 -- (downward-closed) set of stable modules for which we won't call compile.
 730
 731 -- a stable module:
 732 --      * has a valid linkable (see getValidLinkables above)
 733 --      * depends only on stable modules
 734 --      * has an interface in the HPT (interactive mode only)
 735
 736 preUpsweep :: [Linkable]        -- new valid linkables
 737            -> [Module]          -- names of all mods encountered in downsweep
 738            -> [ModSummary]      -- accumulating stable modules
 739            -> [SCC ModSummary]  -- scc-ified mod graph, including src imps
 740            -> IO [ModSummary]   -- stable modules
 741
 742 preUpsweep valid_lis all_home_mods stable []  = return stable
 743 preUpsweep valid_lis all_home_mods stable (scc0:sccs)
 744    = do let scc = flattenSCC scc0
 745             scc_allhomeimps :: [Module]
 746             scc_allhomeimps
 747                = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc))
 748             all_imports_in_scc_or_stable
 749                = all in_stable_or_scc scc_allhomeimps
 750             scc_mods     = map ms_mod scc
 751             stable_names = scc_mods ++ map ms_mod stable
 752             in_stable_or_scc m = m `elem` stable_names
 753
 754             -- now we check for valid linkables: each module in the SCC must
 755             -- have a valid linkable (see getValidLinkables above).
 756             has_valid_linkable scc_mod
 757               = isJust (findModuleLinkable_maybe valid_lis scc_mod)
 758
 759             scc_is_stable = all_imports_in_scc_or_stable
 760                           && all has_valid_linkable scc_mods
 761
 762         if scc_is_stable
 763          then preUpsweep valid_lis all_home_mods (scc ++ stable) sccs
 764          else preUpsweep valid_lis all_home_mods stable          sccs
 765
 766 ms_allimps :: ModSummary -> [Module]
 767 ms_allimps ms = ms_srcimps ms ++ ms_imps ms
 768
 769 -- Return (names of) all those in modsDone who are part of a cycle
 770 -- as defined by theGraph.
 771 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
 772 findPartiallyCompletedCycles modsDone theGraph
 773    = chew theGraph
 774      where
 775         chew [] = []
 776         chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
 777         chew ((CyclicSCC vs):rest)
 778            = let names_in_this_cycle = nub (map ms_mod vs)
 779                  mods_in_this_cycle
 780                     = nub ([done | done <- modsDone,
 781                                    done `elem` names_in_this_cycle])
 782                  chewed_rest = chew rest
 783              in
 784              if   notNull mods_in_this_cycle
 785                   && length mods_in_this_cycle < length names_in_this_cycle
 786              then mods_in_this_cycle ++ chewed_rest
 787              else chewed_rest
 788
 789
 790 -- Compile multiple modules, stopping as soon as an error appears.
 791 -- There better had not be any cyclic groups here -- we check for them.
 792 upsweep_mods :: HscEnv                          -- Includes initially-empty HPT
 793              -> (HomePackageTable, [Linkable])  -- HPT and valid linkables from last time round
 794              -> IO ()                           -- How to clean up unwanted tmp files
 795              -> [SCC ModSummary]                -- Mods to do (the worklist)
 796              -> IO (SuccessFlag,
 797                     HscEnv,             -- With an updated HPT
 798                     [ModSummary])       -- Mods which succeeded
 799
 800 upsweep_mods hsc_env oldUI cleanup
 801      []
 802    = return (Succeeded, hsc_env, [])
 803
 804 upsweep_mods hsc_env oldUI cleanup
 805      (CyclicSCC ms:_)
 806    = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
 807         return (Failed, hsc_env, [])
 808
 809 upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup
 810      (AcyclicSCC mod:mods)
 811    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
 812         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
 813         --                     (moduleEnvElts (hsc_HPT hsc_env)))
 814
 815         mb_mod_info <- upsweep_mod hsc_env oldUI mod
 816
 817         cleanup         -- Remove unwanted tmp files between compilations
 818
 819         case mb_mod_info of
 820             Nothing -> return (Failed, hsc_env, [])
 821             Just mod_info -> do
 822                 { let this_mod = ms_mod mod
 823
 824                         -- Add new info to hsc_env
 825                       hpt1     = extendModuleEnv (hsc_HPT hsc_env) this_mod mod_info
 826                       hsc_env1 = hsc_env { hsc_HPT = hpt1 }
 827                         -- Space-saving: delete the old HPT entry and
 828                         -- linkable for mod BUT if mod is a hs-boot
 829                         -- node, don't delete it For the linkable this
 830                         -- is dead right: the linkable relates only to
 831                         -- the main Haskell source file.  For the
 832                         -- interface, the HPT entry is probaby for the
 833                         -- main Haskell source file.  Deleting it
 834                         -- would force .. (what?? --SDM)
 835                       oldUI1 | isBootSummary mod = oldUI
 836                              | otherwise
 837                              = (delModuleEnv old_hpt this_mod,
 838                                   delModuleLinkable old_linkables this_mod)
 839
 840                 ; (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI1 cleanup mods
 841                 ; return (restOK, hsc_env2, mod:modOKs) }
 842
 843
 844 -- Compile a single module.  Always produce a Linkable for it if
 845 -- successful.  If no compilation happened, return the old Linkable.
 846 upsweep_mod :: HscEnv
 847             -> (HomePackageTable, UnlinkedImage)
 848             -> ModSummary
 849             -> IO (Maybe HomeModInfo)   -- Nothing => Failed
 850
 851 upsweep_mod hsc_env (old_hpt, old_linkables) summary
 852    = do
 853         let this_mod = ms_mod summary
 854
 855         -- The old interface is ok if it's in the old HPT
 856         --      a) we're compiling a source file, and the old HPT
 857         --      entry is for a source file
 858         --      b) we're compiling a hs-boot file
 859         -- Case (b) allows an hs-boot file to get the interface of its
 860         -- real source file on the second iteration of the compilation
 861         -- manager, but that does no harm.  Otherwise the hs-boot file
 862         -- will always be recompiled
 863
 864             mb_old_iface
 865                 = case lookupModuleEnv old_hpt this_mod of
 866                      Nothing                              -> Nothing
 867                      Just hm_info | isBootSummary summary -> Just iface
 868                                   | not (mi_boot iface)   -> Just iface
 869                                   | otherwise             -> Nothing
 870                                    where
 871                                      iface = hm_iface hm_info
 872
 873             maybe_old_linkable = findModuleLinkable_maybe old_linkables this_mod
 874             source_unchanged   = isJust maybe_old_linkable
 875
 876             old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable
 877
 878             have_object
 879                | Just l <- maybe_old_linkable, isObjectLinkable l = True
 880                | otherwise = False
 881
 882         compresult <- compile hsc_env summary source_unchanged have_object mb_old_iface
 883
 884         case compresult of
 885
 886            -- Compilation "succeeded", and may or may not have returned a new
 887            -- linkable (depending on whether compilation was actually performed
 888            -- or not).
 889            CompOK new_details new_iface maybe_new_linkable
 890               -> do let
 891                         new_linkable = maybe_new_linkable `orElse` old_linkable
 892                         new_info = HomeModInfo { hm_iface = new_iface,
 893                                                  hm_details = new_details,
 894                                                  hm_linkable = new_linkable }
 895                     return (Just new_info)
 896
 897            -- Compilation failed.  Compile may still have updated the PCS, tho.
 898            CompErrs -> return Nothing
 899
 900 -- Filter modules in the HPT
 901 retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable
 902 retainInTopLevelEnvs keep_these hpt
 903    = mkModuleEnv [ (mod, fromJust mb_mod_info)
 904                  | mod <- keep_these
 905                  , let mb_mod_info = lookupModuleEnv hpt mod
 906                  , isJust mb_mod_info ]
 907
 908 -- ---------------------------------------------------------------------------
 909 -- Topological sort of the module graph
 910
 911 topSortModuleGraph
 912           :: Bool               -- Drop hi-boot nodes? (see below)
 913           -> [ModSummary]
 914           -> [SCC ModSummary]
 915 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
 916 --
 917 -- Drop hi-boot nodes (first boolean arg)?
 918 --
 919 --   False:     treat the hi-boot summaries as nodes of the graph,
 920 --              so the graph must be acyclic
 921 --
 922 --   True:      eliminate the hi-boot nodes, and instead pretend
 923 --              the a source-import of Foo is an import of Foo
 924 --              The resulting graph has no hi-boot nodes, but can by cyclic
 925
 926 topSortModuleGraph drop_hs_boot_nodes summaries
 927    = stronglyConnComp nodes
 928    where
 929         -- Drop hs-boot nodes by using HsSrcFile as the key
 930         hs_boot_key | drop_hs_boot_nodes = HsSrcFile
 931                     | otherwise          = HsBootFile
 932
 933         -- We use integers as the keys for the SCC algorithm
 934         nodes :: [(ModSummary, Int, [Int])]
 935         nodes = [(s, fromJust (lookup_key (ms_hsc_src s) (ms_mod s)),
 936                      out_edge_keys hs_boot_key (ms_srcimps s) ++
 937                      out_edge_keys HsSrcFile   (ms_imps s)    )
 938                 | s <- summaries
 939                 , not (isBootSummary s && drop_hs_boot_nodes) ]
 940                 -- Drop the hi-boot ones if told to do so
 941
 942         key_map :: NodeMap Int
 943         key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries]
 944                            `zip` [1..])
 945
 946         lookup_key :: HscSource -> Module -> Maybe Int
 947         lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
 948
 949         out_edge_keys :: HscSource -> [Module] -> [Int]
 950         out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
 951                 -- If we want keep_hi_boot_nodes, then we do lookup_key with
 952                 -- the IsBootInterface parameter True; else False
 953
 954
 955 type NodeKey   = (Module, HscSource)      -- The nodes of the graph are
 956 type NodeMap a = FiniteMap NodeKey a      -- keyed by (mod, src_file_type) pairs
 957
 958 msKey :: ModSummary -> NodeKey
 959 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
 960
 961 emptyNodeMap :: NodeMap a
 962 emptyNodeMap = emptyFM
 963
 964 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
 965 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
 966
 967 nodeMapElts :: NodeMap a -> [a]
 968 nodeMapElts = eltsFM
 969
 970 -- -----------------------------------------------------------------
 971 -- The unlinked image
 972 --
 973 -- The compilation manager keeps a list of compiled, but as-yet unlinked
 974 -- binaries (byte code or object code).  Even when it links bytecode
 975 -- it keeps the unlinked version so it can re-link it later without
 976 -- recompiling.
 977
 978 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
 979
 980 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
 981 findModuleLinkable_maybe lis mod
 982    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
 983         []   -> Nothing
 984         [li] -> Just li
 985         many -> pprPanic "findModuleLinkable" (ppr mod)
 986
 987 delModuleLinkable :: [Linkable] -> Module -> [Linkable]
 988 delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ]
 989
 990 -----------------------------------------------------------------------------
 991 -- Downsweep (dependency analysis)
 992
 993 -- Chase downwards from the specified root set, returning summaries
 994 -- for all home modules encountered.  Only follow source-import
 995 -- links.
 996
 997 -- We pass in the previous collection of summaries, which is used as a
 998 -- cache to avoid recalculating a module summary if the source is
 999 -- unchanged.
1000 --
1001 -- The returned list of [ModSummary] nodes has one node for each home-package
1002 -- module, plus one for any hs-boot files.  The imports of these nodes
1003 -- are all there, including the imports of non-home-package modules.
1004
1005 downsweep :: HscEnv
1006           -> [ModSummary]       -- Old summaries
1007           -> [Module]           -- Ignore dependencies on these; treat them as
1008                                 -- if they were package modules
1009           -> IO [ModSummary]
1010 downsweep hsc_env old_summaries excl_mods
1011    = do rootSummaries <- mapM getRootSummary roots
1012         checkDuplicates rootSummaries
1013         loop (concatMap msDeps rootSummaries)
1014              (mkNodeMap rootSummaries)
1015      where
1016         dflags = hsc_dflags hsc_env
1017         roots = hsc_targets hsc_env
1018
1019         old_summary_map :: NodeMap ModSummary
1020         old_summary_map = mkNodeMap old_summaries
1021
1022         getRootSummary :: Target -> IO ModSummary
1023         getRootSummary (Target (TargetFile file) maybe_buf)
1024            = do exists <- doesFileExist file
1025                 if exists then summariseFile hsc_env file else do
1026                 throwDyn (CmdLineError ("can't find file: " ++ file))
1027         getRootSummary (Target (TargetModule modl) maybe_buf)
1028            = do maybe_summary <- summarise hsc_env emptyNodeMap Nothing False
1029                                            modl excl_mods
1030                 case maybe_summary of
1031                    Nothing -> packageModErr modl
1032                    Just s  -> return s
1033
1034         -- In a root module, the filename is allowed to diverge from the module
1035         -- name, so we have to check that there aren't multiple root files
1036         -- defining the same module (otherwise the duplicates will be silently
1037         -- ignored, leading to confusing behaviour).
1038         checkDuplicates :: [ModSummary] -> IO ()
1039         checkDuplicates summaries = mapM_ check summaries
1040           where check summ =
1041                   case dups of
1042                         []     -> return ()
1043                         [_one] -> return ()
1044                         many   -> multiRootsErr modl many
1045                    where modl = ms_mod summ
1046                          dups =
1047                            [ fromJust (ml_hs_file (ms_location summ'))
1048                            | summ' <- summaries, ms_mod summ' == modl ]
1049
1050         loop :: [(FilePath,Module,IsBootInterface)]
1051                         -- Work list: process these modules
1052              -> NodeMap ModSummary
1053                         -- Visited set
1054              -> IO [ModSummary]
1055                         -- The result includes the worklist, except
1056                         -- for those mentioned in the visited set
1057         loop [] done      = return (nodeMapElts done)
1058         loop ((cur_path, wanted_mod, is_boot) : ss) done
1059           | key `elemFM` done = loop ss done
1060           | otherwise         = do { mb_s <- summarise hsc_env old_summary_map
1061                                                  (Just cur_path) is_boot
1062                                                  wanted_mod excl_mods
1063                                    ; case mb_s of
1064                                         Nothing -> loop ss done
1065                                         Just s  -> loop (msDeps s ++ ss)
1066                                                         (addToFM done key s) }
1067           where
1068             key = (wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1069
1070 msDeps :: ModSummary -> [(FilePath,             -- Importing module
1071                           Module,               -- Imported module
1072                           IsBootInterface)]      -- {-# SOURCE #-} import or not
1073 -- (msDeps s) returns the dependencies of the ModSummary s.
1074 -- A wrinkle is that for a {-# SOURCE #-} import we return
1075 --      *both* the hs-boot file
1076 --      *and* the source file
1077 -- as "dependencies".  That ensures that the list of all relevant
1078 -- modules always contains B.hs if it contains B.hs-boot.
1079 -- Remember, this pass isn't doing the topological sort.  It's
1080 -- just gathering the list of all relevant ModSummaries
1081 msDeps s =  concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s]
1082          ++ [(f,m,False) | m <- ms_imps    s]
1083         where
1084           f = msHsFilePath s    -- Keep the importing module for error reporting
1085
1086
1087 -----------------------------------------------------------------------------
1088 -- Summarising modules
1089
1090 -- We have two types of summarisation:
1091 --
1092 --    * Summarise a file.  This is used for the root module(s) passed to
1093 --      cmLoadModules.  The file is read, and used to determine the root
1094 --      module name.  The module name may differ from the filename.
1095 --
1096 --    * Summarise a module.  We are given a module name, and must provide
1097 --      a summary.  The finder is used to locate the file in which the module
1098 --      resides.
1099
1100 summariseFile :: HscEnv -> FilePath -> IO ModSummary
1101 -- Used for Haskell source only, I think
1102 -- We know the file name, and we know it exists,
1103 -- but we don't necessarily know the module name (might differ)
1104 summariseFile hsc_env file
1105    = do let dflags = hsc_dflags hsc_env
1106
1107         (dflags', hspp_fn) <- preprocess dflags file
1108                 -- The dflags' contains the OPTIONS pragmas
1109
1110         -- Read the file into a buffer.  We're going to cache
1111         -- this buffer in the ModLocation (ml_hspp_buf) so that it
1112         -- doesn't have to be slurped again when hscMain parses the
1113         -- file later.
1114         buf <- hGetStringBuffer hspp_fn
1115         (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn
1116
1117         -- Make a ModLocation for this file
1118         location <- mkHomeModLocation dflags mod file
1119
1120         -- Tell the Finder cache where it is, so that subsequent calls
1121         -- to findModule will find it, even if it's not on any search path
1122         addHomeModuleToFinder hsc_env mod location
1123
1124         src_timestamp <- getModificationTime file
1125         return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1126                              ms_location = location,
1127                              ms_hspp_file = Just hspp_fn,
1128                              ms_hspp_buf  = Just buf,
1129                              ms_srcimps = srcimps, ms_imps = the_imps,
1130                              ms_hs_date = src_timestamp })
1131
1132 -- Summarise a module, and pick up source and timestamp.
1133 summarise :: HscEnv
1134           -> NodeMap ModSummary -- Map of old summaries
1135           -> Maybe FilePath     -- Importing module (for error messages)
1136           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
1137           -> Module             -- Imported module to be summarised
1138           -> [Module]           -- Modules to exclude
1139           -> IO (Maybe ModSummary)      -- Its new summary
1140
1141 summarise hsc_env old_summary_map cur_mod is_boot wanted_mod excl_mods
1142   | wanted_mod `elem` excl_mods
1143   = return Nothing
1144
1145   | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1146   = do  {       -- Find its new timestamp; all the
1147                 -- ModSummaries in the old map have valid ml_hs_files
1148            let location = ms_location old_summary
1149                src_fn = fromJust (ml_hs_file location)
1150
1151         ;  src_timestamp <- getModificationTime src_fn
1152
1153                 -- return the cached summary if the source didn't change
1154         ; if ms_hs_date old_summary == src_timestamp
1155           then return (Just old_summary)
1156           else new_summary location
1157         }
1158
1159   | otherwise
1160   = do  { found <- findModule hsc_env wanted_mod True {-explicit-}
1161         ; case found of
1162              Found location pkg
1163                 | not (isHomePackage pkg)      -> return Nothing
1164                         -- Drop external-pkg
1165                 | isJust (ml_hs_file location) -> new_summary location
1166                         -- Home package
1167              err -> noModError dflags cur_mod wanted_mod err
1168                         -- Not found
1169         }
1170   where
1171     dflags = hsc_dflags hsc_env
1172
1173     hsc_src = if is_boot then HsBootFile else HsSrcFile
1174
1175     new_summary location
1176       = do {    -- Adjust location to point to the hs-boot source file,
1177                 -- hi file, object file, when is_boot says so
1178           let location' | is_boot   = addBootSuffixLocn location
1179                         | otherwise = location
1180               src_fn = fromJust (ml_hs_file location')
1181
1182                 -- Check that it exists
1183                 -- It might have been deleted since the Finder last found it
1184         ; exists <- doesFileExist src_fn
1185         ; if exists then return () else noHsFileErr cur_mod src_fn
1186
1187         -- Preprocess the source file and get its imports
1188         -- The dflags' contains the OPTIONS pragmas
1189         ; (dflags', hspp_fn) <- preprocess dflags src_fn
1190         ; buf <- hGetStringBuffer hspp_fn
1191         ; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
1192
1193         ; when (mod_name /= wanted_mod) $
1194                 throwDyn (ProgramError
1195                    (showSDoc (text src_fn
1196                               <>  text ": file name does not match module name"
1197                               <+> quotes (ppr mod_name))))
1198
1199                 -- Find its timestamp, and return the summary
1200         ; src_timestamp <- getModificationTime src_fn
1201         ; return (Just ( ModSummary { ms_mod       = wanted_mod,
1202                                       ms_hsc_src   = hsc_src,
1203                                       ms_location  = location',
1204                                       ms_hspp_file = Just hspp_fn,
1205                                       ms_hspp_buf  = Just buf,
1206                                       ms_srcimps   = srcimps,
1207                                       ms_imps      = the_imps,
1208                                       ms_hs_date   = src_timestamp }))
1209         }
1210
1211
1212 -----------------------------------------------------------------------------
1213 --                      Error messages
1214 -----------------------------------------------------------------------------
1215
1216 noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab
1217 -- ToDo: we don't have a proper line number for this error
1218 noModError dflags cur_mod wanted_mod err
1219   = throwDyn $ ProgramError $ showSDoc $
1220     vcat [cantFindError dflags wanted_mod err,
1221           nest 2 (parens (pp_where cur_mod))]
1222
1223 noHsFileErr cur_mod path
1224   = throwDyn $ CmdLineError $ showSDoc $
1225     vcat [text "Can't find" <+> text path,
1226           nest 2 (parens (pp_where cur_mod))]
1227
1228 pp_where Nothing  = text "one of the roots of the dependency analysis"
1229 pp_where (Just p) = text "imported from" <+> text p
1230
1231 packageModErr mod
1232   = throwDyn (CmdLineError (showSDoc (text "module" <+>
1233                                    quotes (ppr mod) <+>
1234                                    text "is a package module")))
1235
1236 multiRootsErr mod files
1237   = throwDyn (ProgramError (showSDoc (
1238         text "module" <+> quotes (ppr mod) <+>
1239         text "is defined in multiple files:" <+>
1240         sep (map text files))))
1241
1242 cyclicModuleErr :: [ModSummary] -> SDoc
1243 cyclicModuleErr ms
1244   = hang (ptext SLIT("Module imports form a cycle for modules:"))
1245        2 (vcat (map show_one ms))
1246   where
1247     show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1248                         nest 2 $ ptext SLIT("imports:") <+>
1249                                    (pp_imps HsBootFile (ms_srcimps ms)
1250                                    $$ pp_imps HsSrcFile  (ms_imps ms))]
1251     show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1252     pp_imps src mods = fsep (map (show_mod src) mods)
1253
1254
1255 -- | Inform GHC that the working directory has changed.  GHC will flush
1256 -- its cache of module locations, since it may no longer be valid.
1257 -- Note: if you change the working directory, you should also unload
1258 -- the current program (set targets to empty, followed by load).
1259 workingDirectoryChanged :: Session -> IO ()
1260 workingDirectoryChanged s = withSession s $ \hsc_env ->
1261   flushFinderCache (hsc_FC hsc_env)
1262
1263 -- -----------------------------------------------------------------------------
1264 -- inspecting the session
1265
1266 -- | Get the module dependency graph.  After a 'load', this will contain
1267 -- only the modules that were successfully loaded.
1268 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1269 getModuleGraph s = withSession s (return . hsc_mod_graph)
1270
1271 getBindings :: Session -> IO [TyThing]
1272 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1273
1274 getPrintUnqual :: Session -> IO PrintUnqualified
1275 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1276
1277 #if 0
1278 getModuleInfo :: Session -> Module -> IO ModuleInfo
1279
1280 data ObjectCode
1281   = ByteCode
1282   | BinaryCode FilePath
1283
1284 data ModuleInfo = ModuleInfo {
1285   lm_modulename :: Module,
1286   lm_summary    :: ModSummary,
1287   lm_interface  :: ModIface,
1288   lm_tc_code    :: Maybe TypecheckedCode,
1289   lm_rn_code    :: Maybe RenamedCode,
1290   lm_obj        :: Maybe ObjectCode
1291   }
1292
1293 type TypecheckedCode = HsTypecheckedGroup
1294 type RenamedCode     = [HsGroup Name]
1295
1296 -- ToDo: typechecks abstract syntax or renamed abstract syntax.  Issues:
1297 --   - typechecked syntax includes extra dictionary translation and
1298 --     AbsBinds which need to be translated back into something closer to
1299 --     the original source.
1300 --   - renamed syntax currently doesn't exist in a single blob, since
1301 --     renaming and typechecking are interleaved at splice points.  We'd
1302 --     need a restriction that there are no splices in the source module.
1303
1304 -- ToDo:
1305 --   - Data and Typeable instances for HsSyn.
1306
1307 -- ToDo:
1308 --   - things that aren't in the output of the renamer:
1309 --     - the export list
1310 --     - the imports
1311
1312 -- ToDo:
1313 --   - things that aren't in the output of the typechecker right now:
1314 --     - the export list
1315 --     - the imports
1316 --     - type signatures
1317 --     - type/data/newtype declarations
1318 --     - class declarations
1319 --     - instances
1320 --   - extra things in the typechecker's output:
1321 --     - default methods are turned into top-level decls.
1322 --     - dictionary bindings
1323
1324 -- ToDo: check for small transformations that happen to the syntax in
1325 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1326
1327 -- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
1328 -- to get from TyCons, Ids etc. to TH syntax (reify).
1329
1330 -- :browse will use either lm_toplev or inspect lm_interface, depending
1331 -- on whether the module is interpreted or not.
1332
1333 -- various abstract syntax types (perhaps IfaceBlah)
1334 data Type = ...
1335 data Kind = ...
1336
1337 -- This is for reconstructing refactored source code
1338 -- Calls the lexer repeatedly.
1339 -- ToDo: add comment tokens to token stream
1340 getTokenStream :: Session -> Module -> IO [Located Token]
1341 #endif
1342
1343 -- -----------------------------------------------------------------------------
1344 -- Interactive evaluation
1345
1346 #ifdef GHCI
1347
1348 -- | Set the interactive evaluation context.
1349 --
1350 -- Setting the context doesn't throw away any bindings; the bindings
1351 -- we've built up in the InteractiveContext simply move to the new
1352 -- module.  They always shadow anything in scope in the current context.
1353 setContext :: Session
1354            -> [Module]  -- entire top level scope of these modules
1355            -> [Module]  -- exports only of these modules
1356            -> IO ()
1357 setContext (Session ref) toplevs exports = do
1358   hsc_env <- readIORef ref
1359   let old_ic  = hsc_IC     hsc_env
1360       hpt     = hsc_HPT    hsc_env
1361       dflags  = hsc_dflags hsc_env
1362
1363   mapM_ (checkModuleExists hsc_env hpt) exports
1364   export_env  <- mkExportEnv hsc_env exports
1365   toplev_envs <- mapM (mkTopLevEnv hpt) toplevs
1366   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1367   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs,
1368                                             ic_exports      = exports,
1369                                             ic_rn_gbl_env   = all_env } }
1370
1371 checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO ()
1372 checkModuleExists hsc_env hpt mod =
1373   case lookupModuleEnv hpt mod of
1374     Just mod_info -> return ()
1375     _not_a_home_module -> do
1376           res <- findPackageModule hsc_env mod True
1377           case res of
1378             Found _ _ -> return  ()
1379             err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in
1380                    throwDyn (CmdLineError (showSDoc msg))
1381
1382 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1383 mkTopLevEnv hpt modl
1384  = case lookupModuleEnv hpt modl of
1385       Nothing ->
1386          throwDyn (ProgramError ("mkTopLevEnv: not a home module "
1387                         ++ showSDoc (pprModule modl)))
1388       Just details ->
1389          case mi_globals (hm_iface details) of
1390                 Nothing  ->
1391                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1392                                                 ++ showSDoc (pprModule modl)))
1393                 Just env -> return env
1394
1395 -- | Get the interactive evaluation context, consisting of a pair of the
1396 -- set of modules from which we take the full top-level scope, and the set
1397 -- of modules from which we take just the exports respectively.
1398 getContext :: Session -> IO ([Module],[Module])
1399 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1400                                 return (ic_toplev_scope ic, ic_exports ic))
1401
1402 -- | Returns 'True' if the specified module is interpreted, and hence has
1403 -- its full top-level scope available.
1404 moduleIsInterpreted :: Session -> Module -> IO Bool
1405 moduleIsInterpreted s modl = withSession s $ \h ->
1406  case lookupModuleEnv (hsc_HPT h) modl of
1407       Just details       -> return (isJust (mi_globals (hm_iface details)))
1408       _not_a_home_module -> return False
1409
1410 -- | Looks up an identifier in the current interactive context (for :info)
1411 getInfo :: Session -> String -> IO [GetInfoResult]
1412 getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id
1413
1414 -- -----------------------------------------------------------------------------
1415 -- Getting the type of an expression
1416
1417 -- | Get the type of an expression
1418 exprType :: Session -> String -> IO (Maybe Type)
1419 exprType s expr = withSession s $ \hsc_env -> do
1420    maybe_stuff <- hscTcExpr hsc_env expr
1421    case maybe_stuff of
1422         Nothing -> return Nothing
1423         Just ty -> return (Just tidy_ty)
1424              where
1425                 tidy_ty = tidyType emptyTidyEnv ty
1426                 dflags  = hsc_dflags hsc_env
1427
1428 -- -----------------------------------------------------------------------------
1429 -- Getting the kind of a type
1430
1431 -- | Get the kind of a  type
1432 typeKind  :: Session -> String -> IO (Maybe Kind)
1433 typeKind s str = withSession s $ \hsc_env -> do
1434    maybe_stuff <- hscKcType hsc_env str
1435    case maybe_stuff of
1436         Nothing -> return Nothing
1437         Just kind -> return (Just kind)
1438
1439 -----------------------------------------------------------------------------
1440 -- lookupName: returns the TyThing for a Name in the interactive context.
1441 -- ToDo: should look it up in the full environment
1442
1443 lookupName :: Session -> Name -> IO (Maybe TyThing)
1444 lookupName s name = withSession s $ \hsc_env -> do
1445   return $! lookupNameEnv (ic_type_env (hsc_IC hsc_env)) name
1446
1447 -----------------------------------------------------------------------------
1448 -- cmCompileExpr: compile an expression and deliver an HValue
1449
1450 compileExpr :: Session -> String -> IO (Maybe HValue)
1451 compileExpr s expr = withSession s $ \hsc_env -> do
1452   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
1453   case maybe_stuff of
1454         Nothing -> return Nothing
1455         Just (new_ic, names, hval) -> do
1456                         -- Run it!
1457                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
1458
1459                 case (names,hvals) of
1460                   ([n],[hv]) -> return (Just hv)
1461                   _          -> panic "compileExpr"
1462
1463 -- -----------------------------------------------------------------------------
1464 -- running a statement interactively
1465
1466 data RunResult
1467   = RunOk [Name]                -- ^ names bound by this evaluation
1468   | RunFailed                   -- ^ statement failed compilation
1469   | RunException Exception      -- ^ statement raised an exception
1470
1471 -- | Run a statement in the current interactive context.  Statemenet
1472 -- may bind multple values.
1473 runStmt :: Session -> String -> IO RunResult
1474 runStmt (Session ref) expr
1475    = do
1476         hsc_env <- readIORef ref
1477
1478         -- Turn off -fwarn-unused-bindings when running a statement, to hide
1479         -- warnings about the implicit bindings we introduce.
1480         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
1481             hsc_env' = hsc_env{ hsc_dflags = dflags' }
1482
1483         maybe_stuff <- hscStmt hsc_env' expr
1484
1485         case maybe_stuff of
1486            Nothing -> return RunFailed
1487            Just (new_hsc_env, names, hval) -> do
1488
1489                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
1490                 either_hvals <- sandboxIO thing_to_run
1491
1492                 case either_hvals of
1493                     Left e -> do
1494                         -- on error, keep the *old* interactive context,
1495                         -- so that 'it' is not bound to something
1496                         -- that doesn't exist.
1497                         return (RunException e)
1498
1499                     Right hvals -> do
1500                         -- Get the newly bound things, and bind them.
1501                         -- Don't need to delete any shadowed bindings;
1502                         -- the new ones override the old ones.
1503                         extendLinkEnv (zip names hvals)
1504
1505                         writeIORef ref new_hsc_env
1506                         return (RunOk names)
1507
1508
1509 -- We run the statement in a "sandbox" to protect the rest of the
1510 -- system from anything the expression might do.  For now, this
1511 -- consists of just wrapping it in an exception handler, but see below
1512 -- for another version.
1513
1514 sandboxIO :: IO a -> IO (Either Exception a)
1515 sandboxIO thing = Exception.try thing
1516
1517 {-
1518 -- This version of sandboxIO runs the expression in a completely new
1519 -- RTS main thread.  It is disabled for now because ^C exceptions
1520 -- won't be delivered to the new thread, instead they'll be delivered
1521 -- to the (blocked) GHCi main thread.
1522
1523 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
1524
1525 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
1526 sandboxIO thing = do
1527   st_thing <- newStablePtr (Exception.try thing)
1528   alloca $ \ p_st_result -> do
1529     stat <- rts_evalStableIO st_thing p_st_result
1530     freeStablePtr st_thing
1531     if stat == 1
1532         then do st_result <- peek p_st_result
1533                 result <- deRefStablePtr st_result
1534                 freeStablePtr st_result
1535                 return (Right result)
1536         else do
1537                 return (Left (fromIntegral stat))
1538
1539 foreign import "rts_evalStableIO"  {- safe -}
1540   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
1541   -- more informative than the C type!
1542 -}
1543
1544 -- ---------------------------------------------------------------------------
1545 -- cmBrowseModule: get all the TyThings defined in a module
1546
1547 browseModule :: Session -> Module -> Bool -> IO [IfaceDecl]
1548 browseModule s modl exports_only = withSession s $ \hsc_env -> do
1549   mb_decls <- getModuleContents hsc_env modl exports_only
1550   case mb_decls of
1551         Nothing -> return []            -- An error of some kind
1552         Just ds -> return ds
1553
1554
1555 -----------------------------------------------------------------------------
1556 -- show a module and it's source/object filenames
1557
1558 showModule :: Session -> ModSummary -> IO String
1559 showModule s mod_summary = withSession s $ \hsc_env -> do
1560   case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of
1561         Nothing       -> panic "missing linkable"
1562         Just mod_info -> return (showModMsg obj_linkable mod_summary)
1563                       where
1564                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
1565
1566 #endif /* GHCI */