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