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