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