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