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