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