compiler/main/GHC.hs

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