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