compiler/main/GHC.hs

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