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