ghc/compiler/main/GHC.hs

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