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         newSession,
  15
  16         -- * Flags and settings
  17         DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
  18         parseDynamicFlags,
  19         getSessionDynFlags,
  20         setSessionDynFlags,
  21
  22         -- * Targets
  23         Target(..), TargetId(..), Phase,
  24         setTargets,
  25         getTargets,
  26         addTarget,
  27         removeTarget,
  28         guessTarget,
  29
  30         -- * Extending the program scope
  31         extendGlobalRdrScope,  -- :: Session -> [GlobalRdrElt] -> IO ()
  32         setGlobalRdrScope,     -- :: Session -> [GlobalRdrElt] -> IO ()
  33         extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
  34         setGlobalTypeScope,    -- :: Session -> [Id] -> IO ()
  35
  36         -- * Loading\/compiling the program
  37         depanal,
  38         load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
  39         workingDirectoryChanged,
  40         checkModule, CheckedModule(..),
  41         TypecheckedSource, ParsedSource, RenamedSource,
  42
  43         -- * Parsing Haddock comments
  44         parseHaddockComment,
  45
  46         -- * Inspecting the module structure of the program
  47         ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
  48         getModuleGraph,
  49         isLoaded,
  50         topSortModuleGraph,
  51
  52         -- * Inspecting modules
  53         ModuleInfo,
  54         getModuleInfo,
  55         modInfoTyThings,
  56         modInfoTopLevelScope,
  57         modInfoPrintUnqualified,
  58         modInfoExports,
  59         modInfoInstances,
  60         modInfoIsExportedName,
  61         modInfoLookupName,
  62 #if defined(GHCI)
  63         modInfoBkptSites,
  64 #endif
  65         lookupGlobalName,
  66
  67         -- * Printing
  68         PrintUnqualified, alwaysQualify,
  69
  70         -- * Interactive evaluation
  71         getBindings, getPrintUnqual,
  72         findModule,
  73 #ifdef GHCI
  74         setContext, getContext,
  75         getNamesInScope,
  76         getRdrNamesInScope,
  77         moduleIsInterpreted,
  78         getInfo,
  79         exprType,
  80         typeKind,
  81         parseName,
  82         RunResult(..),
  83         runStmt,
  84         showModule,
  85         compileExpr, HValue, dynCompileExpr,
  86         lookupName,
  87
  88         getBreakpointHandler, setBreakpointHandler,
  89         obtainTerm,
  90 #endif
  91
  92         -- * Abstract syntax elements
  93
  94         -- ** Packages
  95         PackageId,
  96
  97         -- ** Modules
  98         Module, mkModule, pprModule, moduleName, modulePackageId,
  99         ModuleName, mkModuleName, moduleNameString,
 100
 101         -- ** Names
 102         Name,
 103         nameModule, pprParenSymName, nameSrcLoc,
 104         NamedThing(..),
 105         RdrName(Qual,Unqual),
 106
 107         -- ** Identifiers
 108         Id, idType,
 109         isImplicitId, isDeadBinder,
 110         isExportedId, isLocalId, isGlobalId,
 111         isRecordSelector,
 112         isPrimOpId, isFCallId, isClassOpId_maybe,
 113         isDataConWorkId, idDataCon,
 114         isBottomingId, isDictonaryId,
 115         recordSelectorFieldLabel,
 116
 117         -- ** Type constructors
 118         TyCon,
 119         tyConTyVars, tyConDataCons, tyConArity,
 120         isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
 121         isOpenTyCon,
 122         synTyConDefn, synTyConType, synTyConResKind,
 123
 124         -- ** Type variables
 125         TyVar,
 126         alphaTyVars,
 127
 128         -- ** Data constructors
 129         DataCon,
 130         dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
 131         dataConIsInfix, isVanillaDataCon,
 132         dataConStrictMarks,
 133         StrictnessMark(..), isMarkedStrict,
 134
 135         -- ** Classes
 136         Class,
 137         classMethods, classSCTheta, classTvsFds,
 138         pprFundeps,
 139
 140         -- ** Instances
 141         Instance,
 142         instanceDFunId, pprInstance, pprInstanceHdr,
 143
 144         -- ** Types and Kinds
 145         Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
 146         Kind,
 147         PredType,
 148         ThetaType, pprThetaArrow,
 149
 150         -- ** Entities
 151         TyThing(..),
 152
 153         -- ** Syntax
 154         module HsSyn, -- ToDo: remove extraneous bits
 155
 156         -- ** Fixities
 157         FixityDirection(..),
 158         defaultFixity, maxPrecedence,
 159         negateFixity,
 160         compareFixity,
 161
 162         -- ** Source locations
 163         SrcLoc, pprDefnLoc,
 164
 165         -- * Exceptions
 166         GhcException(..), showGhcException,
 167
 168         -- * Miscellaneous
 169         sessionHscEnv,
 170         cyclicModuleErr,
 171   ) where
 172
 173 {-
 174  ToDo:
 175
 176   * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
 177   * what StaticFlags should we expose, if any?
 178 -}
 179
 180 #include "HsVersions.h"
 181
 182 #ifdef GHCI
 183 import RtClosureInspect ( cvObtainTerm, Term )
 184 import TcRnDriver       ( tcRnLookupRdrName, tcRnGetInfo,
 185                           tcRnLookupName, getModuleExports )
 186 import RdrName          ( plusGlobalRdrEnv, Provenance(..),
 187                           ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
 188                           mkGlobalRdrEnv )
 189 import HscMain          ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
 190 import Name             ( nameOccName )
 191 import Type             ( tidyType )
 192 import VarEnv           ( emptyTidyEnv )
 193 import GHC.Exts         ( unsafeCoerce# )
 194
 195 -- For breakpoints
 196 import Breakpoints      ( SiteNumber, Coord, nullBkptHandler,
 197                           BkptHandler(..), BkptLocation, noDbgSites )
 198 import Linker           ( initDynLinker )
 199 import PrelNames        ( breakpointJumpName, breakpointCondJumpName,
 200                           breakpointAutoJumpName )
 201
 202 import GHC.Exts         ( Int(..), Ptr(..), int2Addr#, indexArray# )
 203 import GHC.Base         ( Opaque(..) )
 204 import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
 205 import Foreign          ( unsafePerformIO )
 206 import Data.Maybe       ( fromMaybe)
 207 import qualified Linker
 208
 209 import Data.Dynamic     ( Dynamic )
 210 import Linker           ( HValue, getHValue, extendLinkEnv )
 211 #endif
 212
 213 import Packages         ( initPackages )
 214 import NameSet          ( NameSet, nameSetToList, elemNameSet )
 215 import RdrName          ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
 216                           globalRdrEnvElts, extendGlobalRdrEnv,
 217                           emptyGlobalRdrEnv )
 218 import HsSyn
 219 import Type             ( Kind, Type, dropForAlls, PredType, ThetaType,
 220                           pprThetaArrow, pprParendType, splitForAllTys,
 221                           funResultTy )
 222 import Id               ( Id, idType, isImplicitId, isDeadBinder,
 223                           isExportedId, isLocalId, isGlobalId,
 224                           isRecordSelector, recordSelectorFieldLabel,
 225                           isPrimOpId, isFCallId, isClassOpId_maybe,
 226                           isDataConWorkId, idDataCon,
 227                           isBottomingId )
 228 import Var              ( TyVar, varName )
 229 import TysPrim          ( alphaTyVars )
 230 import TyCon            ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
 231                           isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
 232                           tyConTyVars, tyConDataCons, synTyConDefn,
 233                           synTyConType, synTyConResKind )
 234 import Class            ( Class, classSCTheta, classTvsFds, classMethods )
 235 import FunDeps          ( pprFundeps )
 236 import DataCon          ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
 237                           dataConFieldLabels, dataConStrictMarks,
 238                           dataConIsInfix, isVanillaDataCon )
 239 import Name             ( Name, nameModule, NamedThing(..), nameSrcLoc )
 240 import OccName          ( parenSymOcc )
 241 import NameEnv          ( nameEnvElts )
 242 import InstEnv          ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 243 import SrcLoc
 244 import DriverPipeline
 245 import DriverPhases     ( Phase(..), isHaskellSrcFilename, startPhase )
 246 import HeaderInfo       ( getImports, getOptions )
 247 import Finder
 248 import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )
 249 import HscTypes
 250 import DynFlags
 251 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
 252                       cleanTempDirs )
 253 import Module
 254 import UniqFM
 255 import PackageConfig    ( PackageId, stringToPackageId )
 256 import FiniteMap
 257 import Panic
 258 import Digraph
 259 import Bag              ( unitBag, listToBag )
 260 import ErrUtils         ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
 261                           mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
 262                           WarnMsg )
 263 import qualified ErrUtils
 264 import Util
 265 import StringBuffer     ( StringBuffer, hGetStringBuffer )
 266 import Outputable
 267 import BasicTypes
 268 import TcType           ( tcSplitSigmaTy, isDictTy )
 269 import Maybes           ( expectJust, mapCatMaybes )
 270 import HaddockParse     ( parseHaddockParagraphs, parseHaddockString )
 271 import HaddockLex       ( tokenise )
 272
 273 import Control.Concurrent
 274 import System.Directory ( getModificationTime, doesFileExist )
 275 import Data.Maybe       ( isJust, isNothing )
 276 import Data.List        ( partition, nub )
 277 import qualified Data.List as List
 278 import Control.Monad    ( unless, when )
 279 import System.Exit      ( exitWith, ExitCode(..) )
 280 import System.Time      ( ClockTime )
 281 import Control.Exception as Exception hiding (handle)
 282 import Data.IORef
 283 import System.IO
 284 import System.IO.Error  ( isDoesNotExistError )
 285 import Prelude hiding (init)
 286
 287 #if __GLASGOW_HASKELL__ < 600
 288 import System.IO as System.IO.Error ( try )
 289 #else
 290 import System.IO.Error  ( try )
 291 #endif
 292
 293 -- -----------------------------------------------------------------------------
 294 -- Exception handlers
 295
 296 -- | Install some default exception handlers and run the inner computation.
 297 -- Unless you want to handle exceptions yourself, you should wrap this around
 298 -- the top level of your program.  The default handlers output the error
 299 -- message(s) to stderr and exit cleanly.
 300 defaultErrorHandler :: DynFlags -> IO a -> IO a
 301 defaultErrorHandler dflags inner =
 302   -- top-level exception handler: any unrecognised exception is a compiler bug.
 303   handle (\exception -> do
 304            hFlush stdout
 305            case exception of
 306                 -- an IO exception probably isn't our fault, so don't panic
 307                 IOException _ ->
 308                   fatalErrorMsg dflags (text (show exception))
 309                 AsyncException StackOverflow ->
 310                   fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
 311                 _other ->
 312                   fatalErrorMsg dflags (text (show (Panic (show exception))))
 313            exitWith (ExitFailure 1)
 314          ) $
 315
 316   -- program errors: messages with locations attached.  Sometimes it is
 317   -- convenient to just throw these as exceptions.
 318   handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
 319                         exitWith (ExitFailure 1)) $
 320
 321   -- error messages propagated as exceptions
 322   handleDyn (\dyn -> do
 323                 hFlush stdout
 324                 case dyn of
 325                      PhaseFailed _ code -> exitWith code
 326                      Interrupted -> exitWith (ExitFailure 1)
 327                      _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
 328                              exitWith (ExitFailure 1)
 329             ) $
 330   inner
 331
 332 -- | Install a default cleanup handler to remove temporary files
 333 -- deposited by a GHC run.  This is seperate from
 334 -- 'defaultErrorHandler', because you might want to override the error
 335 -- handling, but still get the ordinary cleanup behaviour.
 336 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 337 defaultCleanupHandler dflags inner =
 338     -- make sure we clean up after ourselves
 339     later (unless (dopt Opt_KeepTmpFiles dflags) $
 340                do cleanTempFiles dflags
 341                   cleanTempDirs dflags
 342           )
 343           -- exceptions will be blocked while we clean the temporary files,
 344           -- so there shouldn't be any difficulty if we receive further
 345           -- signals.
 346     inner
 347
 348
 349 #if defined(GHCI)
 350 GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)])
 351         -- stores the current breakpoint handler to help setContext to
 352         -- restore it after a context change
 353 #endif
 354
 355 -- | Starts a new session.  A session consists of a set of loaded
 356 -- modules, a set of options (DynFlags), and an interactive context.
 357 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
 358 -- code".
 359 newSession :: GhcMode -> Maybe FilePath -> IO Session
 360 newSession mode mb_top_dir = do
 361   -- catch ^C
 362   main_thread <- myThreadId
 363   modifyMVar_ interruptTargetThread (return . (main_thread :))
 364   installSignalHandlers
 365
 366   dflags0 <- initSysTools mb_top_dir defaultDynFlags
 367   dflags  <- initDynFlags dflags0
 368   env <- newHscEnv dflags{ ghcMode=mode }
 369   ref <- newIORef env
 370   return (Session ref)
 371
 372 -- tmp: this breaks the abstraction, but required because DriverMkDepend
 373 -- needs to call the Finder.  ToDo: untangle this.
 374 sessionHscEnv :: Session -> IO HscEnv
 375 sessionHscEnv (Session ref) = readIORef ref
 376
 377 withSession :: Session -> (HscEnv -> IO a) -> IO a
 378 withSession (Session ref) f = do h <- readIORef ref; f h
 379
 380 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
 381 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
 382
 383 -- -----------------------------------------------------------------------------
 384 -- Flags & settings
 385
 386 -- | Grabs the DynFlags from the Session
 387 getSessionDynFlags :: Session -> IO DynFlags
 388 getSessionDynFlags s = withSession s (return . hsc_dflags)
 389
 390 -- | Updates the DynFlags in a Session.  This also reads
 391 -- the package database (unless it has already been read),
 392 -- and prepares the compilers knowledge about packages.  It
 393 -- can be called again to load new packages: just add new
 394 -- package flags to (packageFlags dflags).
 395 --
 396 -- Returns a list of new packages that may need to be linked in using
 397 -- the dynamic linker (see 'linkPackages') as a result of new package
 398 -- flags.  If you are not doing linking or doing static linking, you
 399 -- can ignore the list of packages returned.
 400 --
 401 setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
 402 setSessionDynFlags (Session ref) dflags = do
 403   hsc_env <- readIORef ref
 404   (dflags', preload) <- initPackages dflags
 405   writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
 406   return preload
 407
 408 -- | If there is no -o option, guess the name of target executable
 409 -- by using top-level source file name as a base.
 410 guessOutputFile :: Session -> IO ()
 411 guessOutputFile s = modifySession s $ \env ->
 412     let dflags = hsc_dflags env
 413         mod_graph = hsc_mod_graph env
 414         mainModuleSrcPath, guessedName :: Maybe String
 415         mainModuleSrcPath = do
 416             let isMain = (== mainModIs dflags) . ms_mod
 417             [ms] <- return (filter isMain mod_graph)
 418             ml_hs_file (ms_location ms)
 419         guessedName = fmap basenameOf mainModuleSrcPath
 420     in
 421     case outputFile dflags of
 422         Just _ -> env
 423         Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
 424
 425 -- -----------------------------------------------------------------------------
 426 -- Targets
 427
 428 -- ToDo: think about relative vs. absolute file paths. And what
 429 -- happens when the current directory changes.
 430
 431 -- | Sets the targets for this session.  Each target may be a module name
 432 -- or a filename.  The targets correspond to the set of root modules for
 433 -- the program\/library.  Unloading the current program is achieved by
 434 -- setting the current set of targets to be empty, followed by load.
 435 setTargets :: Session -> [Target] -> IO ()
 436 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
 437
 438 -- | returns the current set of targets
 439 getTargets :: Session -> IO [Target]
 440 getTargets s = withSession s (return . hsc_targets)
 441
 442 -- | Add another target
 443 addTarget :: Session -> Target -> IO ()
 444 addTarget s target
 445   = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
 446
 447 -- | Remove a target
 448 removeTarget :: Session -> TargetId -> IO ()
 449 removeTarget s target_id
 450   = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
 451   where
 452    filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
 453
 454 -- Attempts to guess what Target a string refers to.  This function implements
 455 -- the --make/GHCi command-line syntax for filenames:
 456 --
 457 --      - if the string looks like a Haskell source filename, then interpret
 458 --        it as such
 459 --      - if adding a .hs or .lhs suffix yields the name of an existing file,
 460 --        then use that
 461 --      - otherwise interpret the string as a module name
 462 --
 463 guessTarget :: String -> Maybe Phase -> IO Target
 464 guessTarget file (Just phase)
 465    = return (Target (TargetFile file (Just phase)) Nothing)
 466 guessTarget file Nothing
 467    | isHaskellSrcFilename file
 468    = return (Target (TargetFile file Nothing) Nothing)
 469    | otherwise
 470    = do exists <- doesFileExist hs_file
 471         if exists
 472            then return (Target (TargetFile hs_file Nothing) Nothing)
 473            else do
 474         exists <- doesFileExist lhs_file
 475         if exists
 476            then return (Target (TargetFile lhs_file Nothing) Nothing)
 477            else do
 478         return (Target (TargetModule (mkModuleName file)) Nothing)
 479      where
 480          hs_file  = file `joinFileExt` "hs"
 481          lhs_file = file `joinFileExt` "lhs"
 482
 483 -- -----------------------------------------------------------------------------
 484 -- Extending the program scope
 485
 486 extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
 487 extendGlobalRdrScope session rdrElts
 488     = modifySession session $ \hscEnv ->
 489       let global_rdr = hsc_global_rdr_env hscEnv
 490       in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
 491
 492 setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
 493 setGlobalRdrScope session rdrElts
 494     = modifySession session $ \hscEnv ->
 495       hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
 496
 497 extendGlobalTypeScope :: Session -> [Id] -> IO ()
 498 extendGlobalTypeScope session ids
 499     = modifySession session $ \hscEnv ->
 500       let global_type = hsc_global_type_env hscEnv
 501       in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
 502
 503 setGlobalTypeScope :: Session -> [Id] -> IO ()
 504 setGlobalTypeScope session ids
 505     = modifySession session $ \hscEnv ->
 506       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 507
 508 -- -----------------------------------------------------------------------------
 509 -- Parsing Haddock comments
 510
 511 parseHaddockComment :: String -> Either String (HsDoc RdrName)
 512 parseHaddockComment string = parseHaddockParagraphs (tokenise string)
 513
 514 -- -----------------------------------------------------------------------------
 515 -- Loading the program
 516
 517 -- Perform a dependency analysis starting from the current targets
 518 -- and update the session with the new module graph.
 519 depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
 520 depanal (Session ref) excluded_mods allow_dup_roots = do
 521   hsc_env <- readIORef ref
 522   let
 523          dflags  = hsc_dflags hsc_env
 524          gmode   = ghcMode (hsc_dflags hsc_env)
 525          targets = hsc_targets hsc_env
 526          old_graph = hsc_mod_graph hsc_env
 527
 528   showPass dflags "Chasing dependencies"
 529   when (gmode == BatchCompile) $
 530         debugTraceMsg dflags 2 (hcat [
 531                      text "Chasing modules from: ",
 532                         hcat (punctuate comma (map pprTarget targets))])
 533
 534   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
 535   case r of
 536     Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
 537     _ -> return ()
 538   return r
 539
 540 {-
 541 -- | The result of load.
 542 data LoadResult
 543   = LoadOk      Errors  -- ^ all specified targets were loaded successfully.
 544   | LoadFailed  Errors  -- ^ not all modules were loaded.
 545
 546 type Errors = [String]
 547
 548 data ErrMsg = ErrMsg {
 549         errMsgSeverity  :: Severity,  -- warning, error, etc.
 550         errMsgSpans     :: [SrcSpan],
 551         errMsgShortDoc  :: Doc,
 552         errMsgExtraInfo :: Doc
 553         }
 554 -}
 555
 556 data LoadHowMuch
 557    = LoadAllTargets
 558    | LoadUpTo ModuleName
 559    | LoadDependenciesOf ModuleName
 560
 561 -- | Try to load the program.  If a Module is supplied, then just
 562 -- attempt to load up to this target.  If no Module is supplied,
 563 -- then try to load all targets.
 564 load :: Session -> LoadHowMuch -> IO SuccessFlag
 565 load s@(Session ref) how_much
 566    = do
 567         -- Dependency analysis first.  Note that this fixes the module graph:
 568         -- even if we don't get a fully successful upsweep, the full module
 569         -- graph is still retained in the Session.  We can tell which modules
 570         -- were successfully loaded by inspecting the Session's HPT.
 571         mb_graph <- depanal s [] False
 572         case mb_graph of
 573            Just mod_graph -> load2 s how_much mod_graph
 574            Nothing        -> return Failed
 575
 576 load2 s@(Session ref) how_much mod_graph = do
 577         guessOutputFile s
 578         hsc_env <- readIORef ref
 579
 580         let hpt1      = hsc_HPT hsc_env
 581         let dflags    = hsc_dflags hsc_env
 582         let ghci_mode = ghcMode dflags -- this never changes
 583
 584         -- The "bad" boot modules are the ones for which we have
 585         -- B.hs-boot in the module graph, but no B.hs
 586         -- The downsweep should have ensured this does not happen
 587         -- (see msDeps)
 588         let all_home_mods = [ms_mod_name s
 589                             | s <- mod_graph, not (isBootSummary s)]
 590 #ifdef DEBUG
 591             bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
 592                                         not (ms_mod_name s `elem` all_home_mods)]
 593 #endif
 594         ASSERT( null bad_boot_mods ) return ()
 595
 596         -- mg2_with_srcimps drops the hi-boot nodes, returning a
 597         -- graph with cycles.  Among other things, it is used for
 598         -- backing out partially complete cycles following a failed
 599         -- upsweep, and for removing from hpt all the modules
 600         -- not in strict downwards closure, during calls to compile.
 601         let mg2_with_srcimps :: [SCC ModSummary]
 602             mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 603
 604         -- If we can determine that any of the {-# SOURCE #-} imports
 605         -- are definitely unnecessary, then emit a warning.
 606         warnUnnecessarySourceImports dflags mg2_with_srcimps
 607
 608         let
 609             -- check the stability property for each module.
 610             stable_mods@(stable_obj,stable_bco)
 611                 | BatchCompile <- ghci_mode = ([],[])
 612                 | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
 613
 614             -- prune bits of the HPT which are definitely redundant now,
 615             -- to save space.
 616             pruned_hpt = pruneHomePackageTable hpt1
 617                                 (flattenSCCs mg2_with_srcimps)
 618                                 stable_mods
 619
 620         evaluate pruned_hpt
 621
 622         debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
 623                                 text "Stable BCO:" <+> ppr stable_bco)
 624
 625         -- Unload any modules which are going to be re-linked this time around.
 626         let stable_linkables = [ linkable
 627                                | m <- stable_obj++stable_bco,
 628                                  Just hmi <- [lookupUFM pruned_hpt m],
 629                                  Just linkable <- [hm_linkable hmi] ]
 630         unload hsc_env stable_linkables
 631
 632         -- We could at this point detect cycles which aren't broken by
 633         -- a source-import, and complain immediately, but it seems better
 634         -- to let upsweep_mods do this, so at least some useful work gets
 635         -- done before the upsweep is abandoned.
 636         --hPutStrLn stderr "after tsort:\n"
 637         --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 638
 639         -- Now do the upsweep, calling compile for each module in
 640         -- turn.  Final result is version 3 of everything.
 641
 642         -- Topologically sort the module graph, this time including hi-boot
 643         -- nodes, and possibly just including the portion of the graph
 644         -- reachable from the module specified in the 2nd argument to load.
 645         -- This graph should be cycle-free.
 646         -- If we're restricting the upsweep to a portion of the graph, we
 647         -- also want to retain everything that is still stable.
 648         let full_mg :: [SCC ModSummary]
 649             full_mg    = topSortModuleGraph False mod_graph Nothing
 650
 651             maybe_top_mod = case how_much of
 652                                 LoadUpTo m           -> Just m
 653                                 LoadDependenciesOf m -> Just m
 654                                 _                    -> Nothing
 655
 656             partial_mg0 :: [SCC ModSummary]
 657             partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
 658
 659             -- LoadDependenciesOf m: we want the upsweep to stop just
 660             -- short of the specified module (unless the specified module
 661             -- is stable).
 662             partial_mg
 663                 | LoadDependenciesOf mod <- how_much
 664                 = ASSERT( case last partial_mg0 of
 665                             AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
 666                   List.init partial_mg0
 667                 | otherwise
 668                 = partial_mg0
 669
 670             stable_mg =
 671                 [ AcyclicSCC ms
 672                 | AcyclicSCC ms <- full_mg,
 673                   ms_mod_name ms `elem` stable_obj++stable_bco,
 674                   ms_mod_name ms `notElem` [ ms_mod_name ms' |
 675                                                 AcyclicSCC ms' <- partial_mg ] ]
 676
 677             mg = stable_mg ++ partial_mg
 678
 679         -- clean up between compilations
 680         let cleanup = cleanTempFilesExcept dflags
 681                           (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
 682
 683         debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
 684                                    2 (ppr mg))
 685         (upsweep_ok, hsc_env1, modsUpswept)
 686            <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
 687                            pruned_hpt stable_mods cleanup mg
 688
 689         -- Make modsDone be the summaries for each home module now
 690         -- available; this should equal the domain of hpt3.
 691         -- Get in in a roughly top .. bottom order (hence reverse).
 692
 693         let modsDone = reverse modsUpswept
 694
 695         -- Try and do linking in some form, depending on whether the
 696         -- upsweep was completely or only partially successful.
 697
 698         if succeeded upsweep_ok
 699
 700          then
 701            -- Easy; just relink it all.
 702            do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
 703
 704               -- Clean up after ourselves
 705               cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
 706
 707               -- Issue a warning for the confusing case where the user
 708               -- said '-o foo' but we're not going to do any linking.
 709               -- We attempt linking if either (a) one of the modules is
 710               -- called Main, or (b) the user said -no-hs-main, indicating
 711               -- that main() is going to come from somewhere else.
 712               --
 713               let ofile = outputFile dflags
 714               let no_hs_main = dopt Opt_NoHsMain dflags
 715               let
 716                 main_mod = mainModIs dflags
 717                 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
 718                 do_linking = a_root_is_Main || no_hs_main
 719
 720               when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
 721                 debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
 722                                               "but no output will be generated\n" ++
 723                                               "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
 724
 725               -- link everything together
 726               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
 727
 728               loadFinish Succeeded linkresult ref hsc_env1
 729
 730          else
 731            -- Tricky.  We need to back out the effects of compiling any
 732            -- half-done cycles, both so as to clean up the top level envs
 733            -- and to avoid telling the interactive linker to link them.
 734            do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
 735
 736               let modsDone_names
 737                      = map ms_mod modsDone
 738               let mods_to_zap_names
 739                      = findPartiallyCompletedCycles modsDone_names
 740                           mg2_with_srcimps
 741               let mods_to_keep
 742                      = filter ((`notElem` mods_to_zap_names).ms_mod)
 743                           modsDone
 744
 745               let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
 746                                               (hsc_HPT hsc_env1)
 747
 748               -- Clean up after ourselves
 749               cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
 750
 751               -- there should be no Nothings where linkables should be, now
 752               ASSERT(all (isJust.hm_linkable)
 753                         (eltsUFM (hsc_HPT hsc_env))) do
 754
 755               -- Link everything together
 756               linkresult <- link ghci_mode dflags False hpt4
 757
 758               let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
 759               loadFinish Failed linkresult ref hsc_env4
 760
 761 -- Finish up after a load.
 762
 763 -- If the link failed, unload everything and return.
 764 loadFinish all_ok Failed ref hsc_env
 765   = do unload hsc_env []
 766        writeIORef ref $! discardProg hsc_env
 767        return Failed
 768
 769 -- Empty the interactive context and set the module context to the topmost
 770 -- newly loaded module, or the Prelude if none were loaded.
 771 loadFinish all_ok Succeeded ref hsc_env
 772   = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
 773        return all_ok
 774
 775
 776 -- Forget the current program, but retain the persistent info in HscEnv
 777 discardProg :: HscEnv -> HscEnv
 778 discardProg hsc_env
 779   = hsc_env { hsc_mod_graph = emptyMG,
 780               hsc_IC = emptyInteractiveContext,
 781               hsc_HPT = emptyHomePackageTable }
 782
 783 -- used to fish out the preprocess output files for the purposes of
 784 -- cleaning up.  The preprocessed file *might* be the same as the
 785 -- source file, but that doesn't do any harm.
 786 ppFilesFromSummaries summaries = map ms_hspp_file summaries
 787
 788 -- -----------------------------------------------------------------------------
 789 -- Check module
 790
 791 data CheckedModule =
 792   CheckedModule { parsedSource      :: ParsedSource,
 793                   renamedSource     :: Maybe RenamedSource,
 794                   typecheckedSource :: Maybe TypecheckedSource,
 795                   checkedModuleInfo :: Maybe ModuleInfo
 796                 }
 797         -- ToDo: improvements that could be made here:
 798         --  if the module succeeded renaming but not typechecking,
 799         --  we can still get back the GlobalRdrEnv and exports, so
 800         --  perhaps the ModuleInfo should be split up into separate
 801         --  fields within CheckedModule.
 802
 803 type ParsedSource      = Located (HsModule RdrName)
 804 type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
 805                           Maybe (HsDoc Name), HaddockModInfo Name)
 806 type TypecheckedSource = LHsBinds Id
 807
 808 -- NOTE:
 809 --   - things that aren't in the output of the typechecker right now:
 810 --     - the export list
 811 --     - the imports
 812 --     - type signatures
 813 --     - type/data/newtype declarations
 814 --     - class declarations
 815 --     - instances
 816 --   - extra things in the typechecker's output:
 817 --     - default methods are turned into top-level decls.
 818 --     - dictionary bindings
 819
 820
 821 -- | This is the way to get access to parsed and typechecked source code
 822 -- for a module.  'checkModule' loads all the dependencies of the specified
 823 -- module in the Session, and then attempts to typecheck the module.  If
 824 -- successful, it returns the abstract syntax for the module.
 825 checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
 826 checkModule session@(Session ref) mod = do
 827         -- load up the dependencies first
 828    r <- load session (LoadDependenciesOf mod)
 829    if (failed r) then return Nothing else do
 830
 831         -- now parse & typecheck the module
 832    hsc_env <- readIORef ref
 833    let mg  = hsc_mod_graph hsc_env
 834    case [ ms | ms <- mg, ms_mod_name ms == mod ] of
 835         [] -> return Nothing
 836         (ms:_) -> do
 837            mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
 838            case mbChecked of
 839              Nothing -> return Nothing
 840              Just (HscChecked parsed renamed Nothing) ->
 841                    return (Just (CheckedModule {
 842                                         parsedSource = parsed,
 843                                         renamedSource = renamed,
 844                                         typecheckedSource = Nothing,
 845                                         checkedModuleInfo = Nothing }))
 846              Just (HscChecked parsed renamed
 847                            (Just (tc_binds, rdr_env, details))) -> do
 848                    let minf = ModuleInfo {
 849                                 minf_type_env  = md_types details,
 850                                 minf_exports   = availsToNameSet $
 851                                                      md_exports details,
 852                                 minf_rdr_env   = Just rdr_env,
 853                                 minf_instances = md_insts details
 854 #ifdef GHCI
 855                                ,minf_dbg_sites = noDbgSites
 856 #endif
 857                               }
 858                    return (Just (CheckedModule {
 859                                         parsedSource = parsed,
 860                                         renamedSource = renamed,
 861                                         typecheckedSource = Just tc_binds,
 862                                         checkedModuleInfo = Just minf }))
 863
 864 -- ---------------------------------------------------------------------------
 865 -- Unloading
 866
 867 unload :: HscEnv -> [Linkable] -> IO ()
 868 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
 869   = case ghcMode (hsc_dflags hsc_env) of
 870         BatchCompile  -> return ()
 871         JustTypecheck -> return ()
 872 #ifdef GHCI
 873         Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
 874 #else
 875         Interactive -> panic "unload: no interpreter"
 876 #endif
 877         other -> panic "unload: strange mode"
 878
 879 -- -----------------------------------------------------------------------------
 880 -- checkStability
 881
 882 {-
 883   Stability tells us which modules definitely do not need to be recompiled.
 884   There are two main reasons for having stability:
 885
 886    - avoid doing a complete upsweep of the module graph in GHCi when
 887      modules near the bottom of the tree have not changed.
 888
 889    - to tell GHCi when it can load object code: we can only load object code
 890      for a module when we also load object code fo  all of the imports of the
 891      module.  So we need to know that we will definitely not be recompiling
 892      any of these modules, and we can use the object code.
 893
 894   NB. stability is of no importance to BatchCompile at all, only Interactive.
 895   (ToDo: what about JustTypecheck?)
 896
 897   The stability check is as follows.  Both stableObject and
 898   stableBCO are used during the upsweep phase later.
 899
 900   -------------------
 901   stable m = stableObject m || stableBCO m
 902
 903   stableObject m =
 904         all stableObject (imports m)
 905         && old linkable does not exist, or is == on-disk .o
 906         && date(on-disk .o) > date(.hs)
 907
 908   stableBCO m =
 909         all stable (imports m)
 910         && date(BCO) > date(.hs)
 911   -------------------
 912
 913   These properties embody the following ideas:
 914
 915     - if a module is stable:
 916         - if it has been compiled in a previous pass (present in HPT)
 917           then it does not need to be compiled or re-linked.
 918         - if it has not been compiled in a previous pass,
 919           then we only need to read its .hi file from disk and
 920           link it to produce a ModDetails.
 921
 922     - if a modules is not stable, we will definitely be at least
 923       re-linking, and possibly re-compiling it during the upsweep.
 924       All non-stable modules can (and should) therefore be unlinked
 925       before the upsweep.
 926
 927     - Note that objects are only considered stable if they only depend
 928       on other objects.  We can't link object code against byte code.
 929 -}
 930
 931 checkStability
 932         :: HomePackageTable             -- HPT from last compilation
 933         -> [SCC ModSummary]             -- current module graph (cyclic)
 934         -> [ModuleName]                 -- all home modules
 935         -> ([ModuleName],               -- stableObject
 936             [ModuleName])               -- stableBCO
 937
 938 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
 939   where
 940    checkSCC (stable_obj, stable_bco) scc0
 941      | stableObjects = (scc_mods ++ stable_obj, stable_bco)
 942      | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)
 943      | otherwise     = (stable_obj, stable_bco)
 944      where
 945         scc = flattenSCC scc0
 946         scc_mods = map ms_mod_name scc
 947         home_module m   = m `elem` all_home_mods && m `notElem` scc_mods
 948
 949         scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
 950             -- all imports outside the current SCC, but in the home pkg
 951
 952         stable_obj_imps = map (`elem` stable_obj) scc_allimps
 953         stable_bco_imps = map (`elem` stable_bco) scc_allimps
 954
 955         stableObjects =
 956            and stable_obj_imps
 957            && all object_ok scc
 958
 959         stableBCOs =
 960            and (zipWith (||) stable_obj_imps stable_bco_imps)
 961            && all bco_ok scc
 962
 963         object_ok ms
 964           | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
 965                                          && same_as_prev t
 966           | otherwise = False
 967           where
 968              same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
 969                                 Just hmi  | Just l <- hm_linkable hmi
 970                                  -> isObjectLinkable l && t == linkableTime l
 971                                 _other  -> True
 972                 -- why '>=' rather than '>' above?  If the filesystem stores
 973                 -- times to the nearset second, we may occasionally find that
 974                 -- the object & source have the same modification time,
 975                 -- especially if the source was automatically generated
 976                 -- and compiled.  Using >= is slightly unsafe, but it matches
 977                 -- make's behaviour.
 978
 979         bco_ok ms
 980           = case lookupUFM hpt (ms_mod_name ms) of
 981                 Just hmi  | Just l <- hm_linkable hmi ->
 982                         not (isObjectLinkable l) &&
 983                         linkableTime l >= ms_hs_date ms
 984                 _other  -> False
 985
 986 ms_allimps :: ModSummary -> [ModuleName]
 987 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
 988
 989 -- -----------------------------------------------------------------------------
 990 -- Prune the HomePackageTable
 991
 992 -- Before doing an upsweep, we can throw away:
 993 --
 994 --   - For non-stable modules:
 995 --      - all ModDetails, all linked code
 996 --   - all unlinked code that is out of date with respect to
 997 --     the source file
 998 --
 999 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
1000 -- space at the end of the upsweep, because the topmost ModDetails of the
1001 -- old HPT holds on to the entire type environment from the previous
1002 -- compilation.
1003
1004 pruneHomePackageTable
1005    :: HomePackageTable
1006    -> [ModSummary]
1007    -> ([ModuleName],[ModuleName])
1008    -> HomePackageTable
1009
1010 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
1011   = mapUFM prune hpt
1012   where prune hmi
1013           | is_stable modl = hmi'
1014           | otherwise      = hmi'{ hm_details = emptyModDetails }
1015           where
1016            modl = moduleName (mi_module (hm_iface hmi))
1017            hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1018                 = hmi{ hm_linkable = Nothing }
1019                 | otherwise
1020                 = hmi
1021                 where ms = expectJust "prune" (lookupUFM ms_map modl)
1022
1023         ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1024
1025         is_stable m = m `elem` stable_obj || m `elem` stable_bco
1026
1027 -- -----------------------------------------------------------------------------
1028
1029 -- Return (names of) all those in modsDone who are part of a cycle
1030 -- as defined by theGraph.
1031 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1032 findPartiallyCompletedCycles modsDone theGraph
1033    = chew theGraph
1034      where
1035         chew [] = []
1036         chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
1037         chew ((CyclicSCC vs):rest)
1038            = let names_in_this_cycle = nub (map ms_mod vs)
1039                  mods_in_this_cycle
1040                     = nub ([done | done <- modsDone,
1041                                    done `elem` names_in_this_cycle])
1042                  chewed_rest = chew rest
1043              in
1044              if   notNull mods_in_this_cycle
1045                   && length mods_in_this_cycle < length names_in_this_cycle
1046              then mods_in_this_cycle ++ chewed_rest
1047              else chewed_rest
1048
1049 -- -----------------------------------------------------------------------------
1050 -- The upsweep
1051
1052 -- This is where we compile each module in the module graph, in a pass
1053 -- from the bottom to the top of the graph.
1054
1055 -- There better had not be any cyclic groups here -- we check for them.
1056
1057 upsweep
1058     :: HscEnv                   -- Includes initially-empty HPT
1059     -> HomePackageTable         -- HPT from last time round (pruned)
1060     -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
1061     -> IO ()                    -- How to clean up unwanted tmp files
1062     -> [SCC ModSummary]         -- Mods to do (the worklist)
1063     -> IO (SuccessFlag,
1064            HscEnv,              -- With an updated HPT
1065            [ModSummary])        -- Mods which succeeded
1066
1067 upsweep hsc_env old_hpt stable_mods cleanup mods
1068    = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
1069
1070 upsweep' hsc_env old_hpt stable_mods cleanup
1071      [] _ _
1072    = return (Succeeded, hsc_env, [])
1073
1074 upsweep' hsc_env old_hpt stable_mods cleanup
1075      (CyclicSCC ms:_) _ _
1076    = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1077         return (Failed, hsc_env, [])
1078
1079 upsweep' hsc_env old_hpt stable_mods cleanup
1080      (AcyclicSCC mod:mods) mod_index nmods
1081    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1082         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
1083         --                     (moduleEnvElts (hsc_HPT hsc_env)))
1084
1085         mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
1086                        mod_index nmods
1087
1088         cleanup         -- Remove unwanted tmp files between compilations
1089
1090         case mb_mod_info of
1091             Nothing -> return (Failed, hsc_env, [])
1092             Just mod_info -> do
1093                 { let this_mod = ms_mod_name mod
1094
1095                         -- Add new info to hsc_env
1096                       hpt1     = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1097                       hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1098
1099                         -- Space-saving: delete the old HPT entry
1100                         -- for mod BUT if mod is a hs-boot
1101                         -- node, don't delete it.  For the
1102                         -- interface, the HPT entry is probaby for the
1103                         -- main Haskell source file.  Deleting it
1104                         -- would force .. (what?? --SDM)
1105                       old_hpt1 | isBootSummary mod = old_hpt
1106                                | otherwise = delFromUFM old_hpt this_mod
1107
1108                 ; (restOK, hsc_env2, modOKs)
1109                         <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
1110                                 mods (mod_index+1) nmods
1111                 ; return (restOK, hsc_env2, mod:modOKs)
1112                 }
1113
1114
1115 -- Compile a single module.  Always produce a Linkable for it if
1116 -- successful.  If no compilation happened, return the old Linkable.
1117 upsweep_mod :: HscEnv
1118             -> HomePackageTable
1119             -> ([ModuleName],[ModuleName])
1120             -> ModSummary
1121             -> Int  -- index of module
1122             -> Int  -- total number of modules
1123             -> IO (Maybe HomeModInfo)   -- Nothing => Failed
1124
1125 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1126    = do
1127         let
1128             this_mod_name = ms_mod_name summary
1129             this_mod    = ms_mod summary
1130             mb_obj_date = ms_obj_date summary
1131             obj_fn      = ml_obj_file (ms_location summary)
1132             hs_date     = ms_hs_date summary
1133
1134             compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
1135             compile_it  = upsweep_compile hsc_env old_hpt this_mod_name
1136                                 summary mod_index nmods
1137
1138         case ghcMode (hsc_dflags hsc_env) of
1139             BatchCompile ->
1140                 case () of
1141                    -- Batch-compilating is easy: just check whether we have
1142                    -- an up-to-date object file.  If we do, then the compiler
1143                    -- needs to do a recompilation check.
1144                    _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1145                            linkable <-
1146                                 findObjectLinkable this_mod obj_fn obj_date
1147                            compile_it (Just linkable)
1148
1149                      | otherwise ->
1150                            compile_it Nothing
1151
1152             interactive ->
1153                 case () of
1154                     _ | is_stable_obj, isJust old_hmi ->
1155                            return old_hmi
1156                         -- object is stable, and we have an entry in the
1157                         -- old HPT: nothing to do
1158
1159                       | is_stable_obj, isNothing old_hmi -> do
1160                            linkable <-
1161                                 findObjectLinkable this_mod obj_fn
1162                                         (expectJust "upseep1" mb_obj_date)
1163                            compile_it (Just linkable)
1164                         -- object is stable, but we need to load the interface
1165                         -- off disk to make a HMI.
1166
1167                       | is_stable_bco ->
1168                            ASSERT(isJust old_hmi) -- must be in the old_hpt
1169                            return old_hmi
1170                         -- BCO is stable: nothing to do
1171
1172                       | Just hmi <- old_hmi,
1173                         Just l <- hm_linkable hmi, not (isObjectLinkable l),
1174                         linkableTime l >= ms_hs_date summary ->
1175                            compile_it (Just l)
1176                         -- we have an old BCO that is up to date with respect
1177                         -- to the source: do a recompilation check as normal.
1178
1179                       | otherwise ->
1180                           compile_it Nothing
1181                         -- no existing code at all: we must recompile.
1182                    where
1183                     is_stable_obj = this_mod_name `elem` stable_obj
1184                     is_stable_bco = this_mod_name `elem` stable_bco
1185
1186                     old_hmi = lookupUFM old_hpt this_mod_name
1187
1188 -- Run hsc to compile a module
1189 upsweep_compile hsc_env old_hpt this_mod summary
1190                 mod_index nmods
1191                 mb_old_linkable = do
1192   let
1193         -- The old interface is ok if it's in the old HPT
1194         --      a) we're compiling a source file, and the old HPT
1195         --         entry is for a source file
1196         --      b) we're compiling a hs-boot file
1197         -- Case (b) allows an hs-boot file to get the interface of its
1198         -- real source file on the second iteration of the compilation
1199         -- manager, but that does no harm.  Otherwise the hs-boot file
1200         -- will always be recompiled
1201
1202         mb_old_iface
1203                 = case lookupUFM old_hpt this_mod of
1204                      Nothing                              -> Nothing
1205                      Just hm_info | isBootSummary summary -> Just iface
1206                                   | not (mi_boot iface)   -> Just iface
1207                                   | otherwise             -> Nothing
1208                                    where
1209                                      iface = hm_iface hm_info
1210
1211   compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
1212                         mod_index nmods
1213
1214   case compresult of
1215         -- Compilation failed.  Compile may still have updated the PCS, tho.
1216         CompErrs -> return Nothing
1217
1218         -- Compilation "succeeded", and may or may not have returned a new
1219         -- linkable (depending on whether compilation was actually performed
1220         -- or not).
1221         CompOK new_details new_iface new_linkable
1222               -> do let new_info = HomeModInfo { hm_iface = new_iface,
1223                                                  hm_details = new_details,
1224                                                  hm_linkable = new_linkable }
1225                     return (Just new_info)
1226
1227
1228 -- Filter modules in the HPT
1229 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1230 retainInTopLevelEnvs keep_these hpt
1231    = listToUFM   [ (mod, expectJust "retain" mb_mod_info)
1232                  | mod <- keep_these
1233                  , let mb_mod_info = lookupUFM hpt mod
1234                  , isJust mb_mod_info ]
1235
1236 -- ---------------------------------------------------------------------------
1237 -- Topological sort of the module graph
1238
1239 topSortModuleGraph
1240           :: Bool               -- Drop hi-boot nodes? (see below)
1241           -> [ModSummary]
1242           -> Maybe ModuleName
1243           -> [SCC ModSummary]
1244 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1245 -- The resulting list of strongly-connected-components is in topologically
1246 -- sorted order, starting with the module(s) at the bottom of the
1247 -- dependency graph (ie compile them first) and ending with the ones at
1248 -- the top.
1249 --
1250 -- Drop hi-boot nodes (first boolean arg)?
1251 --
1252 --   False:     treat the hi-boot summaries as nodes of the graph,
1253 --              so the graph must be acyclic
1254 --
1255 --   True:      eliminate the hi-boot nodes, and instead pretend
1256 --              the a source-import of Foo is an import of Foo
1257 --              The resulting graph has no hi-boot nodes, but can by cyclic
1258
1259 topSortModuleGraph drop_hs_boot_nodes summaries Nothing
1260   = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
1261 topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
1262   = stronglyConnComp (map vertex_fn (reachable graph root))
1263   where
1264         -- restrict the graph to just those modules reachable from
1265         -- the specified module.  We do this by building a graph with
1266         -- the full set of nodes, and determining the reachable set from
1267         -- the specified node.
1268         (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
1269         (graph, vertex_fn, key_fn) = graphFromEdges' nodes
1270         root
1271           | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1272           | otherwise  = throwDyn (ProgramError "module does not exist")
1273
1274 moduleGraphNodes :: Bool -> [ModSummary]
1275   -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
1276 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1277    where
1278         -- Drop hs-boot nodes by using HsSrcFile as the key
1279         hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1280                     | otherwise          = HsBootFile
1281
1282         -- We use integers as the keys for the SCC algorithm
1283         nodes :: [(ModSummary, Int, [Int])]
1284         nodes = [(s, expectJust "topSort" $
1285                         lookup_key (ms_hsc_src s) (ms_mod_name s),
1286                      out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1287                      out_edge_keys HsSrcFile   (map unLoc (ms_imps s)) ++
1288                      (-- see [boot-edges] below
1289                       if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1290                         then []
1291                         else case lookup_key HsBootFile (ms_mod_name s) of
1292                                 Nothing -> []
1293                                 Just k  -> [k])
1294                  )
1295                 | s <- summaries
1296                 , not (isBootSummary s && drop_hs_boot_nodes) ]
1297                 -- Drop the hi-boot ones if told to do so
1298
1299         -- [boot-edges] if this is a .hs and there is an equivalent
1300         -- .hs-boot, add a link from the former to the latter.  This
1301         -- has the effect of detecting bogus cases where the .hs-boot
1302         -- depends on the .hs, by introducing a cycle.  Additionally,
1303         -- it ensures that we will always process the .hs-boot before
1304         -- the .hs, and so the HomePackageTable will always have the
1305         -- most up to date information.
1306
1307         key_map :: NodeMap Int
1308         key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
1309                             | s <- summaries]
1310                            `zip` [1..])
1311
1312         lookup_key :: HscSource -> ModuleName -> Maybe Int
1313         lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1314
1315         out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1316         out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1317                 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1318                 -- the IsBootInterface parameter True; else False
1319
1320
1321 type NodeKey   = (ModuleName, HscSource)  -- The nodes of the graph are
1322 type NodeMap a = FiniteMap NodeKey a      -- keyed by (mod, src_file_type) pairs
1323
1324 msKey :: ModSummary -> NodeKey
1325 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1326
1327 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1328 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1329
1330 nodeMapElts :: NodeMap a -> [a]
1331 nodeMapElts = eltsFM
1332
1333 ms_mod_name :: ModSummary -> ModuleName
1334 ms_mod_name = moduleName . ms_mod
1335
1336 -- If there are {-# SOURCE #-} imports between strongly connected
1337 -- components in the topological sort, then those imports can
1338 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1339 -- were necessary, then the edge would be part of a cycle.
1340 warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO ()
1341 warnUnnecessarySourceImports dflags sccs =
1342   printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs)))
1343   where check ms =
1344            let mods_in_this_cycle = map ms_mod_name ms in
1345            [ warn m i | m <- ms, i <- ms_srcimps m,
1346                         unLoc i `notElem`  mods_in_this_cycle ]
1347
1348         warn :: ModSummary -> Located ModuleName -> WarnMsg
1349         warn ms (L loc mod) =
1350            mkPlainErrMsg loc
1351                 (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
1352                  <+> quotes (ppr mod))
1353
1354 -----------------------------------------------------------------------------
1355 -- Downsweep (dependency analysis)
1356
1357 -- Chase downwards from the specified root set, returning summaries
1358 -- for all home modules encountered.  Only follow source-import
1359 -- links.
1360
1361 -- We pass in the previous collection of summaries, which is used as a
1362 -- cache to avoid recalculating a module summary if the source is
1363 -- unchanged.
1364 --
1365 -- The returned list of [ModSummary] nodes has one node for each home-package
1366 -- module, plus one for any hs-boot files.  The imports of these nodes
1367 -- are all there, including the imports of non-home-package modules.
1368
1369 downsweep :: HscEnv
1370           -> [ModSummary]       -- Old summaries
1371           -> [ModuleName]       -- Ignore dependencies on these; treat
1372                                 -- them as if they were package modules
1373           -> Bool               -- True <=> allow multiple targets to have
1374                                 --          the same module name; this is
1375                                 --          very useful for ghc -M
1376           -> IO (Maybe [ModSummary])
1377                 -- The elts of [ModSummary] all have distinct
1378                 -- (Modules, IsBoot) identifiers, unless the Bool is true
1379                 -- in which case there can be repeats
1380 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1381    = -- catch error messages and return them
1382      handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1383        rootSummaries <- mapM getRootSummary roots
1384        let root_map = mkRootMap rootSummaries
1385        checkDuplicates root_map
1386        summs <- loop (concatMap msDeps rootSummaries) root_map
1387        return (Just summs)
1388      where
1389         roots = hsc_targets hsc_env
1390
1391         old_summary_map :: NodeMap ModSummary
1392         old_summary_map = mkNodeMap old_summaries
1393
1394         getRootSummary :: Target -> IO ModSummary
1395         getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1396            = do exists <- doesFileExist file
1397                 if exists
1398                     then summariseFile hsc_env old_summaries file mb_phase maybe_buf
1399                     else throwDyn $ mkPlainErrMsg noSrcSpan $
1400                            text "can't find file:" <+> text file
1401         getRootSummary (Target (TargetModule modl) maybe_buf)
1402            = do maybe_summary <- summariseModule hsc_env old_summary_map False
1403                                            (L rootLoc modl) maybe_buf excl_mods
1404                 case maybe_summary of
1405                    Nothing -> packageModErr modl
1406                    Just s  -> return s
1407
1408         rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
1409
1410         -- In a root module, the filename is allowed to diverge from the module
1411         -- name, so we have to check that there aren't multiple root files
1412         -- defining the same module (otherwise the duplicates will be silently
1413         -- ignored, leading to confusing behaviour).
1414         checkDuplicates :: NodeMap [ModSummary] -> IO ()
1415         checkDuplicates root_map
1416            | allow_dup_roots = return ()
1417            | null dup_roots  = return ()
1418            | otherwise       = multiRootsErr (head dup_roots)
1419            where
1420              dup_roots :: [[ModSummary]]        -- Each at least of length 2
1421              dup_roots = filterOut isSingleton (nodeMapElts root_map)
1422
1423         loop :: [(Located ModuleName,IsBootInterface)]
1424                         -- Work list: process these modules
1425              -> NodeMap [ModSummary]
1426                         -- Visited set; the range is a list because
1427                         -- the roots can have the same module names
1428                         -- if allow_dup_roots is True
1429              -> IO [ModSummary]
1430                         -- The result includes the worklist, except
1431                         -- for those mentioned in the visited set
1432         loop [] done      = return (concat (nodeMapElts done))
1433         loop ((wanted_mod, is_boot) : ss) done
1434           | Just summs <- lookupFM done key
1435           = if isSingleton summs then
1436                 loop ss done
1437             else
1438                 do { multiRootsErr summs; return [] }
1439           | otherwise         = do { mb_s <- summariseModule hsc_env old_summary_map
1440                                                  is_boot wanted_mod Nothing excl_mods
1441                                    ; case mb_s of
1442                                         Nothing -> loop ss done
1443                                         Just s  -> loop (msDeps s ++ ss)
1444                                                         (addToFM done key [s]) }
1445           where
1446             key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1447
1448 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1449 mkRootMap summaries = addListToFM_C (++) emptyFM
1450                         [ (msKey s, [s]) | s <- summaries ]
1451
1452 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1453 -- (msDeps s) returns the dependencies of the ModSummary s.
1454 -- A wrinkle is that for a {-# SOURCE #-} import we return
1455 --      *both* the hs-boot file
1456 --      *and* the source file
1457 -- as "dependencies".  That ensures that the list of all relevant
1458 -- modules always contains B.hs if it contains B.hs-boot.
1459 -- Remember, this pass isn't doing the topological sort.  It's
1460 -- just gathering the list of all relevant ModSummaries
1461 msDeps s =
1462     concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1463          ++ [ (m,False) | m <- ms_imps s ]
1464
1465 -----------------------------------------------------------------------------
1466 -- Summarising modules
1467
1468 -- We have two types of summarisation:
1469 --
1470 --    * Summarise a file.  This is used for the root module(s) passed to
1471 --      cmLoadModules.  The file is read, and used to determine the root
1472 --      module name.  The module name may differ from the filename.
1473 --
1474 --    * Summarise a module.  We are given a module name, and must provide
1475 --      a summary.  The finder is used to locate the file in which the module
1476 --      resides.
1477
1478 summariseFile
1479         :: HscEnv
1480         -> [ModSummary]                 -- old summaries
1481         -> FilePath                     -- source file name
1482         -> Maybe Phase                  -- start phase
1483         -> Maybe (StringBuffer,ClockTime)
1484         -> IO ModSummary
1485
1486 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1487         -- we can use a cached summary if one is available and the
1488         -- source file hasn't changed,  But we have to look up the summary
1489         -- by source file, rather than module name as we do in summarise.
1490    | Just old_summary <- findSummaryBySourceFile old_summaries file
1491    = do
1492         let location = ms_location old_summary
1493
1494                 -- return the cached summary if the source didn't change
1495         src_timestamp <- case maybe_buf of
1496                            Just (_,t) -> return t
1497                            Nothing    -> getModificationTime file
1498                 -- The file exists; we checked in getRootSummary above.
1499                 -- If it gets removed subsequently, then this
1500                 -- getModificationTime may fail, but that's the right
1501                 -- behaviour.
1502
1503         if ms_hs_date old_summary == src_timestamp
1504            then do -- update the object-file timestamp
1505                   obj_timestamp <- getObjTimestamp location False
1506                   return old_summary{ ms_obj_date = obj_timestamp }
1507            else
1508                 new_summary
1509
1510    | otherwise
1511    = new_summary
1512   where
1513     new_summary = do
1514         let dflags = hsc_dflags hsc_env
1515
1516         (dflags', hspp_fn, buf)
1517             <- preprocessFile dflags file mb_phase maybe_buf
1518
1519         (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
1520
1521         -- Make a ModLocation for this file
1522         location <- mkHomeModLocation dflags mod_name file
1523
1524         -- Tell the Finder cache where it is, so that subsequent calls
1525         -- to findModule will find it, even if it's not on any search path
1526         mod <- addHomeModuleToFinder hsc_env mod_name location
1527
1528         src_timestamp <- case maybe_buf of
1529                            Just (_,t) -> return t
1530                            Nothing    -> getModificationTime file
1531                         -- getMofificationTime may fail
1532
1533         obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1534
1535         return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1536                              ms_location = location,
1537                              ms_hspp_file = hspp_fn,
1538                              ms_hspp_opts = dflags',
1539                              ms_hspp_buf  = Just buf,
1540                              ms_srcimps = srcimps, ms_imps = the_imps,
1541                              ms_hs_date = src_timestamp,
1542                              ms_obj_date = obj_timestamp })
1543
1544 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1545 findSummaryBySourceFile summaries file
1546   = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1547                                  expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1548         [] -> Nothing
1549         (x:xs) -> Just x
1550
1551 -- Summarise a module, and pick up source and timestamp.
1552 summariseModule
1553           :: HscEnv
1554           -> NodeMap ModSummary -- Map of old summaries
1555           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
1556           -> Located ModuleName -- Imported module to be summarised
1557           -> Maybe (StringBuffer, ClockTime)
1558           -> [ModuleName]               -- Modules to exclude
1559           -> IO (Maybe ModSummary)      -- Its new summary
1560
1561 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
1562   | wanted_mod `elem` excl_mods
1563   = return Nothing
1564
1565   | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1566   = do          -- Find its new timestamp; all the
1567                 -- ModSummaries in the old map have valid ml_hs_files
1568         let location = ms_location old_summary
1569             src_fn = expectJust "summariseModule" (ml_hs_file location)
1570
1571                 -- check the modification time on the source file, and
1572                 -- return the cached summary if it hasn't changed.  If the
1573                 -- file has disappeared, we need to call the Finder again.
1574         case maybe_buf of
1575            Just (_,t) -> check_timestamp old_summary location src_fn t
1576            Nothing    -> do
1577                 m <- System.IO.Error.try (getModificationTime src_fn)
1578                 case m of
1579                    Right t -> check_timestamp old_summary location src_fn t
1580                    Left e | isDoesNotExistError e -> find_it
1581                           | otherwise             -> ioError e
1582
1583   | otherwise  = find_it
1584   where
1585     dflags = hsc_dflags hsc_env
1586
1587     hsc_src = if is_boot then HsBootFile else HsSrcFile
1588
1589     check_timestamp old_summary location src_fn src_timestamp
1590         | ms_hs_date old_summary == src_timestamp = do
1591                 -- update the object-file timestamp
1592                 obj_timestamp <- getObjTimestamp location is_boot
1593                 return (Just old_summary{ ms_obj_date = obj_timestamp })
1594         | otherwise =
1595                 -- source changed: re-summarise.
1596                 new_summary location (ms_mod old_summary) src_fn src_timestamp
1597
1598     find_it = do
1599         -- Don't use the Finder's cache this time.  If the module was
1600         -- previously a package module, it may have now appeared on the
1601         -- search path, so we want to consider it to be a home module.  If
1602         -- the module was previously a home module, it may have moved.
1603         uncacheModule hsc_env wanted_mod
1604         found <- findImportedModule hsc_env wanted_mod Nothing
1605         case found of
1606              Found location mod
1607                 | isJust (ml_hs_file location) ->
1608                         -- Home package
1609                          just_found location mod
1610                 | otherwise ->
1611                         -- Drop external-pkg
1612                         ASSERT(modulePackageId mod /= thisPackage dflags)
1613                         return Nothing
1614                 where
1615
1616              err -> noModError dflags loc wanted_mod err
1617                         -- Not found
1618
1619     just_found location mod = do
1620                 -- Adjust location to point to the hs-boot source file,
1621                 -- hi file, object file, when is_boot says so
1622         let location' | is_boot   = addBootSuffixLocn location
1623                       | otherwise = location
1624             src_fn = expectJust "summarise2" (ml_hs_file location')
1625
1626                 -- Check that it exists
1627                 -- It might have been deleted since the Finder last found it
1628         maybe_t <- modificationTimeIfExists src_fn
1629         case maybe_t of
1630           Nothing -> noHsFileErr loc src_fn
1631           Just t  -> new_summary location' mod src_fn t
1632
1633
1634     new_summary location mod src_fn src_timestamp
1635       = do
1636         -- Preprocess the source file and get its imports
1637         -- The dflags' contains the OPTIONS pragmas
1638         (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1639         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
1640
1641         when (mod_name /= wanted_mod) $
1642                 throwDyn $ mkPlainErrMsg mod_loc $
1643                               text "file name does not match module name"
1644                               <+> quotes (ppr mod_name)
1645
1646                 -- Find the object timestamp, and return the summary
1647         obj_timestamp <- getObjTimestamp location is_boot
1648
1649         return (Just ( ModSummary { ms_mod       = mod,
1650                                     ms_hsc_src   = hsc_src,
1651                                     ms_location  = location,
1652                                     ms_hspp_file = hspp_fn,
1653                                     ms_hspp_opts = dflags',
1654                                     ms_hspp_buf  = Just buf,
1655                                     ms_srcimps   = srcimps,
1656                                     ms_imps      = the_imps,
1657                                     ms_hs_date   = src_timestamp,
1658                                     ms_obj_date  = obj_timestamp }))
1659
1660
1661 getObjTimestamp location is_boot
1662   = if is_boot then return Nothing
1663                else modificationTimeIfExists (ml_obj_file location)
1664
1665
1666 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1667   -> IO (DynFlags, FilePath, StringBuffer)
1668 preprocessFile dflags src_fn mb_phase Nothing
1669   = do
1670         (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1671         buf <- hGetStringBuffer hspp_fn
1672         return (dflags', hspp_fn, buf)
1673
1674 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1675   = do
1676         -- case we bypass the preprocessing stage?
1677         let
1678             local_opts = getOptions buf src_fn
1679         --
1680         (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
1681
1682         let
1683             needs_preprocessing
1684                 | Just (Unlit _) <- mb_phase    = True
1685                 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
1686                   -- note: local_opts is only required if there's no Unlit phase
1687                 | dopt Opt_Cpp dflags'          = True
1688                 | dopt Opt_Pp  dflags'          = True
1689                 | otherwise                     = False
1690
1691         when needs_preprocessing $
1692            ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1693
1694         return (dflags', src_fn, buf)
1695
1696
1697 -----------------------------------------------------------------------------
1698 --                      Error messages
1699 -----------------------------------------------------------------------------
1700
1701 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1702 -- ToDo: we don't have a proper line number for this error
1703 noModError dflags loc wanted_mod err
1704   = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1705
1706 noHsFileErr loc path
1707   = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1708
1709 packageModErr mod
1710   = throwDyn $ mkPlainErrMsg noSrcSpan $
1711         text "module" <+> quotes (ppr mod) <+> text "is a package module"
1712
1713 multiRootsErr :: [ModSummary] -> IO ()
1714 multiRootsErr summs@(summ1:_)
1715   = throwDyn $ mkPlainErrMsg noSrcSpan $
1716         text "module" <+> quotes (ppr mod) <+>
1717         text "is defined in multiple files:" <+>
1718         sep (map text files)
1719   where
1720     mod = ms_mod summ1
1721     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1722
1723 cyclicModuleErr :: [ModSummary] -> SDoc
1724 cyclicModuleErr ms
1725   = hang (ptext SLIT("Module imports form a cycle for modules:"))
1726        2 (vcat (map show_one ms))
1727   where
1728     show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1729                         nest 2 $ ptext SLIT("imports:") <+>
1730                                    (pp_imps HsBootFile (ms_srcimps ms)
1731                                    $$ pp_imps HsSrcFile  (ms_imps ms))]
1732     show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1733     pp_imps src mods = fsep (map (show_mod src) mods)
1734
1735
1736 -- | Inform GHC that the working directory has changed.  GHC will flush
1737 -- its cache of module locations, since it may no longer be valid.
1738 -- Note: if you change the working directory, you should also unload
1739 -- the current program (set targets to empty, followed by load).
1740 workingDirectoryChanged :: Session -> IO ()
1741 workingDirectoryChanged s = withSession s $ flushFinderCaches
1742
1743 -- -----------------------------------------------------------------------------
1744 -- inspecting the session
1745
1746 -- | Get the module dependency graph.
1747 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1748 getModuleGraph s = withSession s (return . hsc_mod_graph)
1749
1750 isLoaded :: Session -> ModuleName -> IO Bool
1751 isLoaded s m = withSession s $ \hsc_env ->
1752   return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1753
1754 getBindings :: Session -> IO [TyThing]
1755 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1756
1757 getPrintUnqual :: Session -> IO PrintUnqualified
1758 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1759
1760 -- | Container for information about a 'Module'.
1761 data ModuleInfo = ModuleInfo {
1762         minf_type_env  :: TypeEnv,
1763         minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
1764         minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
1765         minf_instances :: [Instance]
1766 #ifdef GHCI
1767         ,minf_dbg_sites :: [(SiteNumber,Coord)]
1768 #endif
1769         -- ToDo: this should really contain the ModIface too
1770   }
1771         -- We don't want HomeModInfo here, because a ModuleInfo applies
1772         -- to package modules too.
1773
1774 -- | Request information about a loaded 'Module'
1775 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1776 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1777   let mg = hsc_mod_graph hsc_env
1778   if mdl `elem` map ms_mod mg
1779         then getHomeModuleInfo hsc_env (moduleName mdl)
1780         else do
1781   {- if isHomeModule (hsc_dflags hsc_env) mdl
1782         then return Nothing
1783         else -} getPackageModuleInfo hsc_env mdl
1784    -- getPackageModuleInfo will attempt to find the interface, so
1785    -- we don't want to call it for a home module, just in case there
1786    -- was a problem loading the module and the interface doesn't
1787    -- exist... hence the isHomeModule test here.  (ToDo: reinstate)
1788
1789 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1790 getPackageModuleInfo hsc_env mdl = do
1791 #ifdef GHCI
1792   (_msgs, mb_avails) <- getModuleExports hsc_env mdl
1793   case mb_avails of
1794     Nothing -> return Nothing
1795     Just avails -> do
1796         eps <- readIORef (hsc_EPS hsc_env)
1797         let
1798             names  = availsToNameSet avails
1799             pte    = eps_PTE eps
1800             tys    = [ ty | name <- concatMap availNames avails,
1801                             Just ty <- [lookupTypeEnv pte name] ]
1802         --
1803         return (Just (ModuleInfo {
1804                         minf_type_env  = mkTypeEnv tys,
1805                         minf_exports   = names,
1806                         minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
1807                         minf_instances = error "getModuleInfo: instances for package module unimplemented",
1808                         minf_dbg_sites = noDbgSites
1809                 }))
1810 #else
1811   -- bogusly different for non-GHCI (ToDo)
1812   return Nothing
1813 #endif
1814
1815 getHomeModuleInfo hsc_env mdl =
1816   case lookupUFM (hsc_HPT hsc_env) mdl of
1817     Nothing  -> return Nothing
1818     Just hmi -> do
1819       let details = hm_details hmi
1820       return (Just (ModuleInfo {
1821                         minf_type_env  = md_types details,
1822                         minf_exports   = availsToNameSet (md_exports details),
1823                         minf_rdr_env   = mi_globals $! hm_iface hmi,
1824                         minf_instances = md_insts details
1825 #ifdef GHCI
1826                        ,minf_dbg_sites = md_dbg_sites details
1827 #endif
1828                         }))
1829
1830 -- | The list of top-level entities defined in a module
1831 modInfoTyThings :: ModuleInfo -> [TyThing]
1832 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1833
1834 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1835 modInfoTopLevelScope minf
1836   = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1837
1838 modInfoExports :: ModuleInfo -> [Name]
1839 modInfoExports minf = nameSetToList $! minf_exports minf
1840
1841 -- | Returns the instances defined by the specified module.
1842 -- Warning: currently unimplemented for package modules.
1843 modInfoInstances :: ModuleInfo -> [Instance]
1844 modInfoInstances = minf_instances
1845
1846 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1847 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1848
1849 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1850 modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
1851
1852 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1853 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1854    case lookupTypeEnv (minf_type_env minf) name of
1855      Just tyThing -> return (Just tyThing)
1856      Nothing      -> do
1857        eps <- readIORef (hsc_EPS hsc_env)
1858        return $! lookupType (hsc_dflags hsc_env)
1859                             (hsc_HPT hsc_env) (eps_PTE eps) name
1860
1861 #ifdef GHCI
1862 modInfoBkptSites = minf_dbg_sites
1863 #endif
1864
1865 isDictonaryId :: Id -> Bool
1866 isDictonaryId id
1867   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1868
1869 -- | Looks up a global name: that is, any top-level name in any
1870 -- visible module.  Unlike 'lookupName', lookupGlobalName does not use
1871 -- the interactive context, and therefore does not require a preceding
1872 -- 'setContext'.
1873 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1874 lookupGlobalName s name = withSession s $ \hsc_env -> do
1875    eps <- readIORef (hsc_EPS hsc_env)
1876    return $! lookupType (hsc_dflags hsc_env)
1877                         (hsc_HPT hsc_env) (eps_PTE eps) name
1878
1879 -- -----------------------------------------------------------------------------
1880 -- Misc exported utils
1881
1882 dataConType :: DataCon -> Type
1883 dataConType dc = idType (dataConWrapId dc)
1884
1885 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1886 pprParenSymName :: NamedThing a => a -> SDoc
1887 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1888
1889 -- ----------------------------------------------------------------------------
1890
1891 #if 0
1892
1893 -- ToDo:
1894 --   - Data and Typeable instances for HsSyn.
1895
1896 -- ToDo: check for small transformations that happen to the syntax in
1897 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1898
1899 -- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
1900 -- to get from TyCons, Ids etc. to TH syntax (reify).
1901
1902 -- :browse will use either lm_toplev or inspect lm_interface, depending
1903 -- on whether the module is interpreted or not.
1904
1905 -- This is for reconstructing refactored source code
1906 -- Calls the lexer repeatedly.
1907 -- ToDo: add comment tokens to token stream
1908 getTokenStream :: Session -> Module -> IO [Located Token]
1909 #endif
1910
1911 -- -----------------------------------------------------------------------------
1912 -- Interactive evaluation
1913
1914 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
1915 -- filesystem and package database to find the corresponding 'Module',
1916 -- using the algorithm that is used for an @import@ declaration.
1917 findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
1918 findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
1919   findModule' hsc_env mod_name maybe_pkg
1920
1921 findModule' hsc_env mod_name maybe_pkg =
1922   let
1923         dflags = hsc_dflags hsc_env
1924         hpt    = hsc_HPT hsc_env
1925         this_pkg = thisPackage dflags
1926   in
1927   case lookupUFM hpt mod_name of
1928     Just mod_info -> return (mi_module (hm_iface mod_info))
1929     _not_a_home_module -> do
1930           res <- findImportedModule hsc_env mod_name Nothing
1931           case res of
1932             Found _ m | modulePackageId m /= this_pkg -> return m
1933                       | otherwise -> throwDyn (CmdLineError (showSDoc $
1934                                         text "module" <+> pprModule m <+>
1935                                         text "is not loaded"))
1936             err -> let msg = cannotFindModule dflags mod_name err in
1937                    throwDyn (CmdLineError (showSDoc msg))
1938
1939 #ifdef GHCI
1940
1941 -- | Set the interactive evaluation context.
1942 --
1943 -- Setting the context doesn't throw away any bindings; the bindings
1944 -- we've built up in the InteractiveContext simply move to the new
1945 -- module.  They always shadow anything in scope in the current context.
1946 setContext :: Session
1947            -> [Module]  -- entire top level scope of these modules
1948            -> [Module]  -- exports only of these modules
1949            -> IO ()
1950 setContext sess@(Session ref) toplev_mods export_mods = do
1951   hsc_env <- readIORef ref
1952   let old_ic  = hsc_IC     hsc_env
1953       hpt     = hsc_HPT    hsc_env
1954   --
1955   export_env  <- mkExportEnv hsc_env export_mods
1956   toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
1957   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1958   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
1959                                             ic_exports      = export_mods,
1960                                             ic_rn_gbl_env   = all_env }}
1961   reinstallBreakpointHandlers sess
1962
1963 -- Make a GlobalRdrEnv based on the exports of the modules only.
1964 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1965 mkExportEnv hsc_env mods = do
1966   stuff <- mapM (getModuleExports hsc_env) mods
1967   let
1968         (_msgs, mb_name_sets) = unzip stuff
1969         gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
1970                | (Just avails, mod) <- zip mb_name_sets mods ]
1971   --
1972   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1973
1974 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
1975 nameSetToGlobalRdrEnv names mod =
1976   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
1977                  | name <- nameSetToList names ]
1978
1979 vanillaProv :: ModuleName -> Provenance
1980 -- We're building a GlobalRdrEnv as if the user imported
1981 -- all the specified modules into the global interactive module
1982 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
1983   where
1984     decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1985                          is_qual = False,
1986                          is_dloc = srcLocSpan interactiveSrcLoc }
1987
1988 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1989 mkTopLevEnv hpt modl
1990   = case lookupUFM hpt (moduleName modl) of
1991       Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
1992                                                 showSDoc (ppr modl)))
1993       Just details ->
1994          case mi_globals (hm_iface details) of
1995                 Nothing  ->
1996                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1997                                                 ++ showSDoc (ppr modl)))
1998                 Just env -> return env
1999
2000 -- | Get the interactive evaluation context, consisting of a pair of the
2001 -- set of modules from which we take the full top-level scope, and the set
2002 -- of modules from which we take just the exports respectively.
2003 getContext :: Session -> IO ([Module],[Module])
2004 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
2005                                 return (ic_toplev_scope ic, ic_exports ic))
2006
2007 -- | Returns 'True' if the specified module is interpreted, and hence has
2008 -- its full top-level scope available.
2009 moduleIsInterpreted :: Session -> Module -> IO Bool
2010 moduleIsInterpreted s modl = withSession s $ \h ->
2011  if modulePackageId modl /= thisPackage (hsc_dflags h)
2012         then return False
2013         else case lookupUFM (hsc_HPT h) (moduleName modl) of
2014                 Just details       -> return (isJust (mi_globals (hm_iface details)))
2015                 _not_a_home_module -> return False
2016
2017 -- | Looks up an identifier in the current interactive context (for :info)
2018 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
2019 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
2020
2021 -- | Returns all names in scope in the current interactive context
2022 getNamesInScope :: Session -> IO [Name]
2023 getNamesInScope s = withSession s $ \hsc_env -> do
2024   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
2025
2026 getRdrNamesInScope :: Session -> IO [RdrName]
2027 getRdrNamesInScope  s = withSession s $ \hsc_env -> do
2028   let env = ic_rn_gbl_env (hsc_IC hsc_env)
2029   return (concat (map greToRdrNames (globalRdrEnvElts env)))
2030
2031 -- ToDo: move to RdrName
2032 greToRdrNames :: GlobalRdrElt -> [RdrName]
2033 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
2034   = case prov of
2035      LocalDef -> [unqual]
2036      Imported specs -> concat (map do_spec (map is_decl specs))
2037   where
2038     occ = nameOccName name
2039     unqual = Unqual occ
2040     do_spec decl_spec
2041         | is_qual decl_spec = [qual]
2042         | otherwise         = [unqual,qual]
2043         where qual = Qual (is_as decl_spec) occ
2044
2045 -- | Parses a string as an identifier, and returns the list of 'Name's that
2046 -- the identifier can refer to in the current interactive context.
2047 parseName :: Session -> String -> IO [Name]
2048 parseName s str = withSession s $ \hsc_env -> do
2049    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
2050    case maybe_rdr_name of
2051         Nothing -> return []
2052         Just (L _ rdr_name) -> do
2053             mb_names <- tcRnLookupRdrName hsc_env rdr_name
2054             case mb_names of
2055                 Nothing -> return []
2056                 Just ns -> return ns
2057                 -- ToDo: should return error messages
2058
2059 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
2060 -- entity known to GHC, including 'Name's defined using 'runStmt'.
2061 lookupName :: Session -> Name -> IO (Maybe TyThing)
2062 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
2063
2064 -- -----------------------------------------------------------------------------
2065 -- Getting the type of an expression
2066
2067 -- | Get the type of an expression
2068 exprType :: Session -> String -> IO (Maybe Type)
2069 exprType s expr = withSession s $ \hsc_env -> do
2070    maybe_stuff <- hscTcExpr hsc_env expr
2071    case maybe_stuff of
2072         Nothing -> return Nothing
2073         Just ty -> return (Just tidy_ty)
2074              where
2075                 tidy_ty = tidyType emptyTidyEnv ty
2076
2077 -- -----------------------------------------------------------------------------
2078 -- Getting the kind of a type
2079
2080 -- | Get the kind of a  type
2081 typeKind  :: Session -> String -> IO (Maybe Kind)
2082 typeKind s str = withSession s $ \hsc_env -> do
2083    maybe_stuff <- hscKcType hsc_env str
2084    case maybe_stuff of
2085         Nothing -> return Nothing
2086         Just kind -> return (Just kind)
2087
2088 -----------------------------------------------------------------------------
2089 -- cmCompileExpr: compile an expression and deliver an HValue
2090
2091 compileExpr :: Session -> String -> IO (Maybe HValue)
2092 compileExpr s expr = withSession s $ \hsc_env -> do
2093   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
2094   case maybe_stuff of
2095         Nothing -> return Nothing
2096         Just (new_ic, names, hval) -> do
2097                         -- Run it!
2098                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
2099
2100                 case (names,hvals) of
2101                   ([n],[hv]) -> return (Just hv)
2102                   _          -> panic "compileExpr"
2103
2104 -- -----------------------------------------------------------------------------
2105 -- Compile an expression into a dynamic
2106
2107 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
2108 dynCompileExpr ses expr = do
2109     (full,exports) <- getContext ses
2110     setContext ses full $
2111         (mkModule
2112             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
2113         ):exports
2114     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
2115     res <- withSession ses (flip hscStmt stmt)
2116     setContext ses full exports
2117     case res of
2118         Nothing -> return Nothing
2119         Just (_, names, hvals) -> do
2120             vals <- (unsafeCoerce# hvals :: IO [Dynamic])
2121             case (names,vals) of
2122                 (_:[], v:[])    -> return (Just v)
2123                 _               -> panic "dynCompileExpr"
2124
2125 -- -----------------------------------------------------------------------------
2126 -- running a statement interactively
2127
2128 data RunResult
2129   = RunOk [Name]                -- ^ names bound by this evaluation
2130   | RunFailed                   -- ^ statement failed compilation
2131   | RunException Exception      -- ^ statement raised an exception
2132
2133 -- | Run a statement in the current interactive context.  Statemenet
2134 -- may bind multple values.
2135 runStmt :: Session -> String -> IO RunResult
2136 runStmt (Session ref) expr
2137    = do
2138         hsc_env <- readIORef ref
2139
2140         -- Turn off -fwarn-unused-bindings when running a statement, to hide
2141         -- warnings about the implicit bindings we introduce.
2142         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
2143             hsc_env' = hsc_env{ hsc_dflags = dflags' }
2144
2145         maybe_stuff <- hscStmt hsc_env' expr
2146
2147         case maybe_stuff of
2148            Nothing -> return RunFailed
2149            Just (new_hsc_env, names, hval) -> do
2150
2151                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
2152                 either_hvals <- sandboxIO thing_to_run
2153
2154                 case either_hvals of
2155                     Left e -> do
2156                         -- on error, keep the *old* interactive context,
2157                         -- so that 'it' is not bound to something
2158                         -- that doesn't exist.
2159                         return (RunException e)
2160
2161                     Right hvals -> do
2162                         -- Get the newly bound things, and bind them.
2163                         -- Don't need to delete any shadowed bindings;
2164                         -- the new ones override the old ones.
2165                         extendLinkEnv (zip names hvals)
2166
2167                         writeIORef ref new_hsc_env
2168                         return (RunOk names)
2169
2170 -- When running a computation, we redirect ^C exceptions to the running
2171 -- thread.  ToDo: we might want a way to continue even if the target
2172 -- thread doesn't die when it receives the exception... "this thread
2173 -- is not responding".
2174 sandboxIO :: IO a -> IO (Either Exception a)
2175 sandboxIO thing = do
2176   m <- newEmptyMVar
2177   ts <- takeMVar interruptTargetThread
2178   child <- forkIO (do res <- Exception.try thing; putMVar m res)
2179   putMVar interruptTargetThread (child:ts)
2180   takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
2181
2182 {-
2183 -- This version of sandboxIO runs the expression in a completely new
2184 -- RTS main thread.  It is disabled for now because ^C exceptions
2185 -- won't be delivered to the new thread, instead they'll be delivered
2186 -- to the (blocked) GHCi main thread.
2187
2188 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
2189
2190 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
2191 sandboxIO thing = do
2192   st_thing <- newStablePtr (Exception.try thing)
2193   alloca $ \ p_st_result -> do
2194     stat <- rts_evalStableIO st_thing p_st_result
2195     freeStablePtr st_thing
2196     if stat == 1
2197         then do st_result <- peek p_st_result
2198                 result <- deRefStablePtr st_result
2199                 freeStablePtr st_result
2200                 return (Right result)
2201         else do
2202                 return (Left (fromIntegral stat))
2203
2204 foreign import "rts_evalStableIO"  {- safe -}
2205   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
2206   -- more informative than the C type!
2207 -}
2208
2209 -----------------------------------------------------------------------------
2210 -- show a module and it's source/object filenames
2211
2212 showModule :: Session -> ModSummary -> IO String
2213 showModule s mod_summary = withSession s $ \hsc_env -> do
2214   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
2215         Nothing       -> panic "missing linkable"
2216         Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
2217                       where
2218                          obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
2219
2220 getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
2221 getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
2222
2223 setBreakpointHandler :: Session -> BkptHandler Module -> IO ()
2224 setBreakpointHandler session handler = do
2225   dflags <- getSessionDynFlags session
2226   setSessionDynFlags session dflags{ bkptHandler = Just handler }
2227   let linkEnv =   [ ( breakpointJumpName
2228                     , unsafeCoerce# (jumpFunction session handler))
2229                   , ( breakpointCondJumpName
2230                     , unsafeCoerce# (jumpCondFunction session handler))
2231                   , ( breakpointAutoJumpName
2232                     , unsafeCoerce# (jumpAutoFunction session handler))
2233                   ]
2234   writeIORef v_bkptLinkEnv linkEnv
2235   dflags <- getSessionDynFlags session
2236   reinstallBreakpointHandlers session
2237
2238 reinstallBreakpointHandlers :: Session -> IO ()
2239 reinstallBreakpointHandlers session = do
2240   dflags <- getSessionDynFlags session
2241   let mode = ghcMode dflags
2242   when (mode == Interactive) $ do
2243     linkEnv <- readIORef v_bkptLinkEnv
2244     initDynLinker dflags
2245     extendLinkEnv linkEnv
2246
2247 type SiteInfo = (String, String, SiteNumber)
2248 jumpFunction, jumpAutoFunction  :: Session -> BkptHandler Module -> Int -> [Opaque]
2249                                 -> SiteInfo -> String -> b -> b
2250 jumpCondFunction  :: Session -> BkptHandler Module -> Int -> [Opaque]
2251                   -> SiteInfo -> String -> Bool -> b -> b
2252 jumpFunctionM :: Session -> BkptHandler a -> Int -> [Opaque] -> BkptLocation a
2253               -> String -> b -> IO b
2254
2255 jumpCondFunction _ _ _ _ _ _ False b = b
2256 jumpCondFunction session handler ptr hValues siteInfo locmsg True b
2257     = jumpFunction session handler ptr hValues siteInfo locmsg b
2258
2259 jumpFunction session handler ptr hValues siteInfo locmsg b
2260     | site <- mkSite siteInfo
2261     = unsafePerformIO $ jumpFunctionM session handler ptr hValues site locmsg b
2262
2263 jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b =
2264       do
2265          ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
2266          ASSERT (length ids == length wrapped_hValues) return ()
2267          let hValues = [unsafeCoerce# hv | O hv <- wrapped_hValues]
2268          handleBreakpoint handler session (zip ids hValues) site locmsg b
2269
2270 jumpAutoFunction session handler ptr hValues siteInfo locmsg b
2271     | site <- mkSite siteInfo
2272     = unsafePerformIO $ do
2273          break <- isAutoBkptEnabled handler session site
2274          if break
2275             then jumpFunctionM session handler ptr hValues site locmsg b
2276             else return b
2277
2278 jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b
2279     | site <- mkSite siteInfo
2280     = unsafePerformIO $ do
2281           jumpFunctionM session handler ptr hValues site locmsg b
2282
2283 mkSite :: SiteInfo -> BkptLocation Module
2284 mkSite (pkgName, modName, sitenum) =
2285   (mkModule (stringToPackageId pkgName) (mkModuleName modName), sitenum)
2286
2287 obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
2288 obtainTerm sess force id = withSession sess $ \hsc_env -> do
2289               mb_v <- getHValue (varName id)
2290               case mb_v of
2291                 Just v  -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
2292                 Nothing -> return Nothing
2293
2294 #endif /* GHCI */