1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow, 2005
7 -- -----------------------------------------------------------------------------
12 defaultCleanupHandler,
15 Ghc, GhcT, GhcMonad(..),
16 runGhc, runGhcT, initGhcMonad,
17 gcatch, gbracket, gfinally,
18 clearWarnings, getWarnings, hasWarnings,
19 printExceptionAndWarnings, printWarnings,
22 -- * Flags and settings
23 DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
24 GhcMode(..), GhcLink(..), defaultObjectTarget,
31 Target(..), TargetId(..), Phase,
38 -- * Extending the program scope
41 extendGlobalTypeScope,
44 -- * Loading\/compiling the program
46 load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
47 defaultWarnErrLogger, WarnErrLogger,
48 workingDirectoryChanged,
49 parseModule, typecheckModule, desugarModule, loadModule,
50 ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
51 TypecheckedSource, ParsedSource, RenamedSource, -- ditto
52 moduleInfo, renamedSource, typecheckedSource,
53 parsedSource, coreModule,
54 compileToCoreModule, compileToCoreSimplified,
58 -- * Parsing Haddock comments
61 -- * Inspecting the module structure of the program
62 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
67 -- * Inspecting modules
74 modInfoIsExportedName,
77 mkPrintUnqualifiedForModule,
80 PrintUnqualified, alwaysQualify,
82 -- * Interactive evaluation
83 getBindings, getPrintUnqual,
86 setContext, getContext,
96 runStmt, SingleStep(..),
98 Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
99 resumeHistory, resumeHistoryIx),
100 History(historyBreakInfo, historyEnclosingDecl),
101 GHC.getHistorySpan, getHistoryModule,
104 InteractiveEval.back,
105 InteractiveEval.forward,
108 InteractiveEval.compileExpr, HValue, dynCompileExpr,
110 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
112 ModBreaks(..), BreakIndex,
113 BreakInfo(breakInfo_number, breakInfo_module),
114 BreakArray, setBreakOn, setBreakOff, getBreak,
117 -- * Abstract syntax elements
123 Module, mkModule, pprModule, moduleName, modulePackageId,
124 ModuleName, mkModuleName, moduleNameString,
128 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
130 RdrName(Qual,Unqual),
134 isImplicitId, isDeadBinder,
135 isExportedId, isLocalId, isGlobalId,
137 isPrimOpId, isFCallId, isClassOpId_maybe,
138 isDataConWorkId, idDataCon,
139 isBottomingId, isDictonaryId,
140 recordSelectorFieldLabel,
142 -- ** Type constructors
144 tyConTyVars, tyConDataCons, tyConArity,
145 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
147 synTyConDefn, synTyConType, synTyConResKind,
153 -- ** Data constructors
155 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
156 dataConIsInfix, isVanillaDataCon,
158 StrictnessMark(..), isMarkedStrict,
162 classMethods, classSCTheta, classTvsFds,
167 instanceDFunId, pprInstance, pprInstanceHdr,
169 -- ** Types and Kinds
170 Type, splitForAllTys, funResultTy,
171 pprParendType, pprTypeApp,
174 ThetaType, pprThetaArrow,
180 module HsSyn, -- ToDo: remove extraneous bits
184 defaultFixity, maxPrecedence,
188 -- ** Source locations
190 mkSrcLoc, isGoodSrcLoc, noSrcLoc,
191 srcLocFile, srcLocLine, srcLocCol,
193 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
194 srcSpanStart, srcSpanEnd,
196 srcSpanStartLine, srcSpanEndLine,
197 srcSpanStartCol, srcSpanEndCol,
200 GhcException(..), showGhcException,
202 -- * Token stream manipulations
204 getTokenStream, getRichTokenStream,
205 showRichTokenStream, addSourceToTokens,
215 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
216 * what StaticFlags should we expose, if any?
219 #include "HsVersions.h"
222 import qualified Linker
223 import Linker ( HValue )
227 import InteractiveEval
232 import TcRnTypes hiding (LIE)
233 import TcRnMonad ( initIfaceCheck )
237 import qualified HsSyn -- hack as we want to reexport the whole module
238 import HsSyn hiding ((<.>))
239 import Type hiding (typeKind)
240 import TcType hiding (typeKind)
243 import TysPrim ( alphaTyVars )
248 import Name hiding ( varName )
249 import OccName ( parenSymOcc )
250 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
252 import FamInstEnv ( emptyFamInstEnv )
256 import DriverPipeline
257 import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
263 import StaticFlagParser
264 import qualified StaticFlags
265 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
274 import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
278 import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
281 import Maybes ( expectJust, mapCatMaybes )
283 import HaddockLex ( tokenise )
287 import Control.Concurrent
288 import System.Directory ( getModificationTime, doesFileExist,
289 getCurrentDirectory )
292 import qualified Data.List as List
294 import System.Exit ( exitWith, ExitCode(..) )
295 import System.Time ( ClockTime, getClockTime )
298 import System.FilePath
300 import System.IO.Error ( try, isDoesNotExistError )
301 import Prelude hiding (init)
304 -- -----------------------------------------------------------------------------
305 -- Exception handlers
307 -- | Install some default exception handlers and run the inner computation.
308 -- Unless you want to handle exceptions yourself, you should wrap this around
309 -- the top level of your program. The default handlers output the error
310 -- message(s) to stderr and exit cleanly.
311 defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
312 defaultErrorHandler dflags inner =
313 -- top-level exception handler: any unrecognised exception is a compiler bug.
314 ghandle (\exception -> liftIO $ do
316 case fromException exception of
317 -- an IO exception probably isn't our fault, so don't panic
318 Just (ioe :: IOException) ->
319 fatalErrorMsg dflags (text (show ioe))
320 _ -> case fromException exception of
321 Just StackOverflow ->
322 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
323 _ -> case fromException exception of
324 Just (ex :: ExitCode) -> throw ex
327 (text (show (Panic (show exception))))
328 exitWith (ExitFailure 1)
331 -- error messages propagated as exceptions
336 PhaseFailed _ code -> exitWith code
337 Interrupted -> exitWith (ExitFailure 1)
338 _ -> do fatalErrorMsg dflags (text (show ge))
339 exitWith (ExitFailure 1)
343 -- | Install a default cleanup handler to remove temporary files deposited by
344 -- a GHC run. This is seperate from 'defaultErrorHandler', because you might
345 -- want to override the error handling, but still get the ordinary cleanup
347 defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
348 DynFlags -> m a -> m a
349 defaultCleanupHandler dflags inner =
350 -- make sure we clean up after ourselves
353 cleanTempFiles dflags
356 -- exceptions will be blocked while we clean the temporary files,
357 -- so there shouldn't be any difficulty if we receive further
360 -- | Print the error message and all warnings. Useful inside exception
361 -- handlers. Clears warnings after printing.
362 printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
363 printExceptionAndWarnings err = do
364 let errs = srcErrorMessages err
366 dflags <- getSessionDynFlags
368 -- Empty errors means we failed due to -Werror. (Since this function
369 -- takes a source error as argument, we know for sure _some_ error
370 -- did indeed happen.)
372 printBagOfWarnings dflags warns
373 printBagOfErrors dflags (unitBag warnIsErrorMsg)
374 else liftIO $ printBagOfErrors dflags errs
377 -- | Print all accumulated warnings using 'log_action'.
378 printWarnings :: GhcMonad m => m ()
380 dflags <- getSessionDynFlags
382 liftIO $ printBagOfWarnings dflags warns
385 -- | Run function for the 'Ghc' monad.
387 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
388 -- to this function will create a new session which should not be shared among
391 -- Any errors not handled inside the 'Ghc' action are propagated as IO
394 runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
395 -> Ghc a -- ^ The action to perform.
397 runGhc mb_top_dir ghc = do
398 wref <- newIORef emptyBag
399 ref <- newIORef undefined
400 let session = Session ref wref
401 flip unGhc session $ do
402 initGhcMonad mb_top_dir
404 -- XXX: unregister interrupt handlers here?
406 -- | Run function for 'GhcT' monad transformer.
408 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
409 -- to this function will create a new session which should not be shared among
412 runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
413 Maybe FilePath -- ^ See argument to 'initGhcMonad'.
414 -> GhcT m a -- ^ The action to perform.
416 runGhcT mb_top_dir ghct = do
417 wref <- liftIO $ newIORef emptyBag
418 ref <- liftIO $ newIORef undefined
419 let session = Session ref wref
420 flip unGhcT session $ do
421 initGhcMonad mb_top_dir
424 -- | Initialise a GHC session.
426 -- If you implement a custom 'GhcMonad' you must call this function in the
427 -- monad run function. It will initialise the session variable and clear all
430 -- The first argument should point to the directory where GHC's library files
431 -- reside. More precisely, this should be the output of @ghc --print-libdir@
432 -- of the version of GHC the module using this API is compiled with. For
433 -- portability, you should use the @ghc-paths@ package, available at
434 -- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
436 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
437 initGhcMonad mb_top_dir = do
439 main_thread <- liftIO $ myThreadId
440 liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
441 liftIO $ installSignalHandlers
443 liftIO $ StaticFlags.initStaticOpts
445 dflags0 <- liftIO $ initDynFlags defaultDynFlags
446 dflags <- liftIO $ initSysTools mb_top_dir dflags0
447 env <- liftIO $ newHscEnv dflags
451 -- -----------------------------------------------------------------------------
454 -- | Grabs the DynFlags from the Session
455 getSessionDynFlags :: GhcMonad m => m DynFlags
456 getSessionDynFlags = withSession (return . hsc_dflags)
458 -- | Updates the DynFlags in a Session. This also reads
459 -- the package database (unless it has already been read),
460 -- and prepares the compilers knowledge about packages. It
461 -- can be called again to load new packages: just add new
462 -- package flags to (packageFlags dflags).
464 -- Returns a list of new packages that may need to be linked in using
465 -- the dynamic linker (see 'linkPackages') as a result of new package
466 -- flags. If you are not doing linking or doing static linking, you
467 -- can ignore the list of packages returned.
469 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
470 setSessionDynFlags dflags = do
471 (dflags', preload) <- liftIO $ initPackages dflags
472 modifySession (\h -> h{ hsc_dflags = dflags' })
475 -- | If there is no -o option, guess the name of target executable
476 -- by using top-level source file name as a base.
477 guessOutputFile :: GhcMonad m => m ()
478 guessOutputFile = modifySession $ \env ->
479 let dflags = hsc_dflags env
480 mod_graph = hsc_mod_graph env
481 mainModuleSrcPath :: Maybe String
482 mainModuleSrcPath = do
483 let isMain = (== mainModIs dflags) . ms_mod
484 [ms] <- return (filter isMain mod_graph)
485 ml_hs_file (ms_location ms)
486 name = fmap dropExtension mainModuleSrcPath
488 #if defined(mingw32_HOST_OS)
489 -- we must add the .exe extention unconditionally here, otherwise
490 -- when name has an extension of its own, the .exe extension will
491 -- not be added by DriverPipeline.exeFileName. See #2248
492 name_exe = fmap (<.> "exe") name
497 case outputFile dflags of
499 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
501 -- -----------------------------------------------------------------------------
504 -- ToDo: think about relative vs. absolute file paths. And what
505 -- happens when the current directory changes.
507 -- | Sets the targets for this session. Each target may be a module name
508 -- or a filename. The targets correspond to the set of root modules for
509 -- the program\/library. Unloading the current program is achieved by
510 -- setting the current set of targets to be empty, followed by 'load'.
511 setTargets :: GhcMonad m => [Target] -> m ()
512 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
514 -- | Returns the current set of targets
515 getTargets :: GhcMonad m => m [Target]
516 getTargets = withSession (return . hsc_targets)
518 -- | Add another target.
519 addTarget :: GhcMonad m => Target -> m ()
521 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
524 removeTarget :: GhcMonad m => TargetId -> m ()
525 removeTarget target_id
526 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
528 filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
530 -- | Attempts to guess what Target a string refers to. This function
531 -- implements the @--make@/GHCi command-line syntax for filenames:
533 -- - if the string looks like a Haskell source filename, then interpret it
536 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
539 -- - otherwise interpret the string as a module name
541 guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
542 guessTarget str (Just phase)
543 = return (Target (TargetFile str (Just phase)) True Nothing)
544 guessTarget str Nothing
545 | isHaskellSrcFilename file
546 = return (target (TargetFile file Nothing))
548 = do exists <- liftIO $ doesFileExist hs_file
550 then return (target (TargetFile hs_file Nothing))
552 exists <- liftIO $ doesFileExist lhs_file
554 then return (target (TargetFile lhs_file Nothing))
556 if looksLikeModuleName file
557 then return (target (TargetModule (mkModuleName file)))
560 (ProgramError (showSDoc $
561 text "target" <+> quotes (text file) <+>
562 text "is not a module name or a source file"))
565 | '*':rest <- str = (rest, False)
566 | otherwise = (str, True)
568 hs_file = file <.> "hs"
569 lhs_file = file <.> "lhs"
571 target tid = Target tid obj_allowed Nothing
573 -- -----------------------------------------------------------------------------
574 -- Extending the program scope
576 extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
577 extendGlobalRdrScope rdrElts
578 = modifySession $ \hscEnv ->
579 let global_rdr = hsc_global_rdr_env hscEnv
580 in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
582 setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
583 setGlobalRdrScope rdrElts
584 = modifySession $ \hscEnv ->
585 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
587 extendGlobalTypeScope :: GhcMonad m => [Id] -> m ()
588 extendGlobalTypeScope ids
589 = modifySession $ \hscEnv ->
590 let global_type = hsc_global_type_env hscEnv
591 in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
593 setGlobalTypeScope :: GhcMonad m => [Id] -> m ()
594 setGlobalTypeScope ids
595 = modifySession $ \hscEnv ->
596 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
598 -- -----------------------------------------------------------------------------
599 -- Parsing Haddock comments
601 parseHaddockComment :: String -> Either String (HsDoc RdrName)
602 parseHaddockComment string =
603 case parseHaddockParagraphs (tokenise string) of
607 -- -----------------------------------------------------------------------------
608 -- Loading the program
610 -- | Perform a dependency analysis starting from the current targets
611 -- and update the session with the new module graph.
612 depanal :: GhcMonad m =>
613 [ModuleName] -- ^ excluded modules
614 -> Bool -- ^ allow duplicate roots
616 depanal excluded_mods allow_dup_roots = do
617 hsc_env <- getSession
619 dflags = hsc_dflags hsc_env
620 targets = hsc_targets hsc_env
621 old_graph = hsc_mod_graph hsc_env
623 liftIO $ showPass dflags "Chasing dependencies"
624 liftIO $ debugTraceMsg dflags 2 (hcat [
625 text "Chasing modules from: ",
626 hcat (punctuate comma (map pprTarget targets))])
628 mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
629 modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
634 | LoadUpTo ModuleName
635 | LoadDependenciesOf ModuleName
637 -- | Try to load the program. Calls 'loadWithLogger' with the default
638 -- compiler that just immediately logs all warnings and errors.
639 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
641 loadWithLogger defaultWarnErrLogger how_much
643 -- | A function called to log warnings and errors.
644 type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
646 defaultWarnErrLogger :: WarnErrLogger
647 defaultWarnErrLogger Nothing = printWarnings
648 defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
650 -- | Try to load the program. If a Module is supplied, then just
651 -- attempt to load up to this target. If no Module is supplied,
652 -- then try to load all targets.
654 -- The first argument is a function that is called after compiling each
655 -- module to print wanrings and errors.
657 loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
658 loadWithLogger logger how_much = do
659 -- Dependency analysis first. Note that this fixes the module graph:
660 -- even if we don't get a fully successful upsweep, the full module
661 -- graph is still retained in the Session. We can tell which modules
662 -- were successfully loaded by inspecting the Session's HPT.
663 mod_graph <- depanal [] False
664 load2 how_much mod_graph logger
666 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger
668 load2 how_much mod_graph logger = do
670 hsc_env <- getSession
672 let hpt1 = hsc_HPT hsc_env
673 let dflags = hsc_dflags hsc_env
675 -- The "bad" boot modules are the ones for which we have
676 -- B.hs-boot in the module graph, but no B.hs
677 -- The downsweep should have ensured this does not happen
679 let all_home_mods = [ms_mod_name s
680 | s <- mod_graph, not (isBootSummary s)]
681 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
682 not (ms_mod_name s `elem` all_home_mods)]
683 ASSERT( null bad_boot_mods ) return ()
685 -- check that the module given in HowMuch actually exists, otherwise
686 -- topSortModuleGraph will bomb later.
687 let checkHowMuch (LoadUpTo m) = checkMod m
688 checkHowMuch (LoadDependenciesOf m) = checkMod m
692 | m `elem` all_home_mods = and_then
694 liftIO $ errorMsg dflags (text "no such module:" <+>
698 checkHowMuch how_much $ do
700 -- mg2_with_srcimps drops the hi-boot nodes, returning a
701 -- graph with cycles. Among other things, it is used for
702 -- backing out partially complete cycles following a failed
703 -- upsweep, and for removing from hpt all the modules
704 -- not in strict downwards closure, during calls to compile.
705 let mg2_with_srcimps :: [SCC ModSummary]
706 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
708 -- If we can determine that any of the {-# SOURCE #-} imports
709 -- are definitely unnecessary, then emit a warning.
710 warnUnnecessarySourceImports dflags mg2_with_srcimps
713 -- check the stability property for each module.
714 stable_mods@(stable_obj,stable_bco)
715 = checkStability hpt1 mg2_with_srcimps all_home_mods
717 -- prune bits of the HPT which are definitely redundant now,
719 pruned_hpt = pruneHomePackageTable hpt1
720 (flattenSCCs mg2_with_srcimps)
723 liftIO $ evaluate pruned_hpt
725 -- before we unload anything, make sure we don't leave an old
726 -- interactive context around pointing to dead bindings. Also,
727 -- write the pruned HPT to allow the old HPT to be GC'd.
728 modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
729 hsc_HPT = pruned_hpt }
731 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
732 text "Stable BCO:" <+> ppr stable_bco)
734 -- Unload any modules which are going to be re-linked this time around.
735 let stable_linkables = [ linkable
736 | m <- stable_obj++stable_bco,
737 Just hmi <- [lookupUFM pruned_hpt m],
738 Just linkable <- [hm_linkable hmi] ]
739 liftIO $ unload hsc_env stable_linkables
741 -- We could at this point detect cycles which aren't broken by
742 -- a source-import, and complain immediately, but it seems better
743 -- to let upsweep_mods do this, so at least some useful work gets
744 -- done before the upsweep is abandoned.
745 --hPutStrLn stderr "after tsort:\n"
746 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
748 -- Now do the upsweep, calling compile for each module in
749 -- turn. Final result is version 3 of everything.
751 -- Topologically sort the module graph, this time including hi-boot
752 -- nodes, and possibly just including the portion of the graph
753 -- reachable from the module specified in the 2nd argument to load.
754 -- This graph should be cycle-free.
755 -- If we're restricting the upsweep to a portion of the graph, we
756 -- also want to retain everything that is still stable.
757 let full_mg :: [SCC ModSummary]
758 full_mg = topSortModuleGraph False mod_graph Nothing
760 maybe_top_mod = case how_much of
762 LoadDependenciesOf m -> Just m
765 partial_mg0 :: [SCC ModSummary]
766 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
768 -- LoadDependenciesOf m: we want the upsweep to stop just
769 -- short of the specified module (unless the specified module
772 | LoadDependenciesOf _mod <- how_much
773 = ASSERT( case last partial_mg0 of
774 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
775 List.init partial_mg0
781 | AcyclicSCC ms <- full_mg,
782 ms_mod_name ms `elem` stable_obj++stable_bco,
783 ms_mod_name ms `notElem` [ ms_mod_name ms' |
784 AcyclicSCC ms' <- partial_mg ] ]
786 mg = stable_mg ++ partial_mg
788 -- clean up between compilations
789 let cleanup = cleanTempFilesExcept dflags
790 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
792 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
794 (upsweep_ok, hsc_env1, modsUpswept)
796 (hsc_env { hsc_HPT = emptyHomePackageTable })
797 pruned_hpt stable_mods cleanup mg
799 -- Make modsDone be the summaries for each home module now
800 -- available; this should equal the domain of hpt3.
801 -- Get in in a roughly top .. bottom order (hence reverse).
803 let modsDone = reverse modsUpswept
805 -- Try and do linking in some form, depending on whether the
806 -- upsweep was completely or only partially successful.
808 if succeeded upsweep_ok
811 -- Easy; just relink it all.
812 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
814 -- Clean up after ourselves
815 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
817 -- Issue a warning for the confusing case where the user
818 -- said '-o foo' but we're not going to do any linking.
819 -- We attempt linking if either (a) one of the modules is
820 -- called Main, or (b) the user said -no-hs-main, indicating
821 -- that main() is going to come from somewhere else.
823 let ofile = outputFile dflags
824 let no_hs_main = dopt Opt_NoHsMain dflags
826 main_mod = mainModIs dflags
827 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
828 do_linking = a_root_is_Main || no_hs_main
830 when (ghcLink dflags == LinkBinary
831 && isJust ofile && not do_linking) $
832 liftIO $ debugTraceMsg dflags 1 $
833 text ("Warning: output was redirected with -o, " ++
834 "but no output will be generated\n" ++
835 "because there is no " ++
836 moduleNameString (moduleName main_mod) ++ " module.")
838 -- link everything together
839 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
841 loadFinish Succeeded linkresult hsc_env1
844 -- Tricky. We need to back out the effects of compiling any
845 -- half-done cycles, both so as to clean up the top level envs
846 -- and to avoid telling the interactive linker to link them.
847 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
850 = map ms_mod modsDone
851 let mods_to_zap_names
852 = findPartiallyCompletedCycles modsDone_names
855 = filter ((`notElem` mods_to_zap_names).ms_mod)
858 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
861 -- Clean up after ourselves
862 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
864 -- there should be no Nothings where linkables should be, now
865 ASSERT(all (isJust.hm_linkable)
866 (eltsUFM (hsc_HPT hsc_env))) do
868 -- Link everything together
869 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
871 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
872 loadFinish Failed linkresult hsc_env4
874 -- Finish up after a load.
876 -- If the link failed, unload everything and return.
877 loadFinish :: GhcMonad m =>
878 SuccessFlag -> SuccessFlag -> HscEnv
880 loadFinish _all_ok Failed hsc_env
881 = do liftIO $ unload hsc_env []
882 modifySession $ \_ -> discardProg hsc_env
885 -- Empty the interactive context and set the module context to the topmost
886 -- newly loaded module, or the Prelude if none were loaded.
887 loadFinish all_ok Succeeded hsc_env
888 = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
892 -- Forget the current program, but retain the persistent info in HscEnv
893 discardProg :: HscEnv -> HscEnv
895 = hsc_env { hsc_mod_graph = emptyMG,
896 hsc_IC = emptyInteractiveContext,
897 hsc_HPT = emptyHomePackageTable }
899 -- used to fish out the preprocess output files for the purposes of
900 -- cleaning up. The preprocessed file *might* be the same as the
901 -- source file, but that doesn't do any harm.
902 ppFilesFromSummaries :: [ModSummary] -> [FilePath]
903 ppFilesFromSummaries summaries = map ms_hspp_file summaries
905 -- -----------------------------------------------------------------------------
907 class ParsedMod m where
908 modSummary :: m -> ModSummary
909 parsedSource :: m -> ParsedSource
911 class ParsedMod m => TypecheckedMod m where
912 renamedSource :: m -> Maybe RenamedSource
913 typecheckedSource :: m -> TypecheckedSource
914 moduleInfo :: m -> ModuleInfo
915 tm_internals :: m -> (TcGblEnv, ModDetails)
916 -- ToDo: improvements that could be made here:
917 -- if the module succeeded renaming but not typechecking,
918 -- we can still get back the GlobalRdrEnv and exports, so
919 -- perhaps the ModuleInfo should be split up into separate
922 class TypecheckedMod m => DesugaredMod m where
923 coreModule :: m -> ModGuts
925 -- | The result of successful parsing.
927 ParsedModule { pm_mod_summary :: ModSummary
928 , pm_parsed_source :: ParsedSource }
930 instance ParsedMod ParsedModule where
931 modSummary m = pm_mod_summary m
932 parsedSource m = pm_parsed_source m
934 -- | The result of successful typechecking. It also contains the parser
936 data TypecheckedModule =
937 TypecheckedModule { tm_parsed_module :: ParsedModule
938 , tm_renamed_source :: Maybe RenamedSource
939 , tm_typechecked_source :: TypecheckedSource
940 , tm_checked_module_info :: ModuleInfo
941 , tm_internals_ :: (TcGblEnv, ModDetails)
944 instance ParsedMod TypecheckedModule where
945 modSummary m = modSummary (tm_parsed_module m)
946 parsedSource m = parsedSource (tm_parsed_module m)
948 instance TypecheckedMod TypecheckedModule where
949 renamedSource m = tm_renamed_source m
950 typecheckedSource m = tm_typechecked_source m
951 moduleInfo m = tm_checked_module_info m
952 tm_internals m = tm_internals_ m
954 -- | The result of successful desugaring (i.e., translation to core). Also
955 -- contains all the information of a typechecked module.
956 data DesugaredModule =
957 DesugaredModule { dm_typechecked_module :: TypecheckedModule
958 , dm_core_module :: ModGuts
961 instance ParsedMod DesugaredModule where
962 modSummary m = modSummary (dm_typechecked_module m)
963 parsedSource m = parsedSource (dm_typechecked_module m)
965 instance TypecheckedMod DesugaredModule where
966 renamedSource m = renamedSource (dm_typechecked_module m)
967 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
968 moduleInfo m = moduleInfo (dm_typechecked_module m)
969 tm_internals m = tm_internals_ (dm_typechecked_module m)
971 instance DesugaredMod DesugaredModule where
972 coreModule m = dm_core_module m
974 type ParsedSource = Located (HsModule RdrName)
975 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
976 Maybe (HsDoc Name), HaddockModInfo Name)
977 type TypecheckedSource = LHsBinds Id
980 -- - things that aren't in the output of the typechecker right now:
984 -- - type/data/newtype declarations
985 -- - class declarations
987 -- - extra things in the typechecker's output:
988 -- - default methods are turned into top-level decls.
989 -- - dictionary bindings
991 -- | Return the 'ModSummary' of a module with the given name.
993 -- The module must be part of the module graph (see 'hsc_mod_graph' and
994 -- 'ModuleGraph'). If this is not the case, this function will throw a
997 -- This function ignores boot modules and requires that there is only one
998 -- non-boot module with the given name.
999 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
1000 getModSummary mod = do
1001 mg <- liftM hsc_mod_graph getSession
1002 case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
1003 [] -> throw $ mkApiErr (text "Module not part of module graph")
1005 multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
1007 -- | Parse a module.
1009 -- Throws a 'SourceError' on parse error.
1010 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
1012 hsc_env0 <- getSession
1013 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1014 rdr_module <- parseFile hsc_env ms
1015 return (ParsedModule ms rdr_module)
1017 -- | Typecheck and rename a parsed module.
1019 -- Throws a 'SourceError' if either fails.
1020 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
1021 typecheckModule pmod = do
1022 let ms = modSummary pmod
1023 hsc_env0 <- getSession
1024 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1025 (tc_gbl_env, rn_info)
1026 <- typecheckRenameModule hsc_env ms (parsedSource pmod)
1027 details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env
1030 tm_internals_ = (tc_gbl_env, details),
1031 tm_parsed_module = pmod,
1032 tm_renamed_source = rn_info,
1033 tm_typechecked_source = tcg_binds tc_gbl_env,
1034 tm_checked_module_info =
1036 minf_type_env = md_types details,
1037 minf_exports = availsToNameSet $ md_exports details,
1038 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
1039 minf_instances = md_insts details
1041 ,minf_modBreaks = emptyModBreaks
1045 -- | Desugar a typechecked module.
1046 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
1047 desugarModule tcm = do
1048 let ms = modSummary tcm
1049 hsc_env0 <- getSession
1050 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1051 let (tcg, _) = tm_internals tcm
1052 guts <- deSugarModule hsc_env ms tcg
1055 dm_typechecked_module = tcm,
1056 dm_core_module = guts
1059 -- | Load a module. Input doesn't need to be desugared.
1061 -- XXX: Describe usage.
1062 loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
1064 let ms = modSummary tcm
1065 let mod = ms_mod_name ms
1066 hsc_env0 <- getSession
1067 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1068 let (tcg, details) = tm_internals tcm
1069 (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details
1070 let mod_info = HomeModInfo {
1072 hm_details = details,
1073 hm_linkable = Nothing }
1074 let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
1075 modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new }
1078 -- | This is the way to get access to the Core bindings corresponding
1079 -- to a module. 'compileToCore' parses, typechecks, and
1080 -- desugars the module, then returns the resulting Core module (consisting of
1081 -- the module name, type declarations, and function declarations) if
1083 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1084 compileToCoreModule = compileCore False
1086 -- | Like compileToCoreModule, but invokes the simplifier, so
1087 -- as to return simplified and tidied Core.
1088 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1089 compileToCoreSimplified = compileCore True
1091 -- | Provided for backwards-compatibility: compileToCore returns just the Core
1092 -- bindings, but for most purposes, you probably want to call
1093 -- compileToCoreModule.
1094 compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
1095 compileToCore fn = do
1096 mod <- compileToCoreModule session fn
1097 return $ cm_binds mod
1099 -- | Takes a CoreModule and compiles the bindings therein
1100 -- to object code. The first argument is a bool flag indicating
1101 -- whether to run the simplifier.
1102 -- The resulting .o, .hi, and executable files, if any, are stored in the
1103 -- current directory, and named according to the module name.
1104 -- Returns True iff compilation succeeded.
1105 -- This has only so far been tested with a single self-contained module.
1106 compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
1107 compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
1108 hscEnv <- getSession
1109 dflags <- getSessionDynFlags
1110 currentTime <- liftIO $ getClockTime
1111 cwd <- liftIO $ getCurrentDirectory
1112 modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
1113 ((moduleNameSlashes . moduleName) mName)
1115 let modSummary = ModSummary { ms_mod = mName,
1116 ms_hsc_src = ExtCoreFile,
1117 ms_location = modLocation,
1118 -- By setting the object file timestamp to Nothing,
1119 -- we always force recompilation, which is what we
1120 -- want. (Thus it doesn't matter what the timestamp
1121 -- for the (nonexistent) source file is.)
1122 ms_hs_date = currentTime,
1123 ms_obj_date = Nothing,
1124 -- Only handling the single-module case for now, so no imports.
1129 ms_hspp_opts = dflags,
1130 ms_hspp_buf = Nothing
1133 ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv,
1134 compModSummary=modSummary,
1135 compOldIface=Nothing}) $
1136 let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
1137 | otherwise = return mod_guts
1138 in maybe_simplify (mkModGuts cm)
1144 -- Makes a "vanilla" ModGuts.
1145 mkModGuts :: CoreModule -> ModGuts
1146 mkModGuts coreModule = ModGuts {
1147 mg_module = cm_module coreModule,
1150 mg_deps = noDependencies,
1151 mg_dir_imps = emptyModuleEnv,
1152 mg_used_names = emptyNameSet,
1153 mg_rdr_env = emptyGlobalRdrEnv,
1154 mg_fix_env = emptyFixityEnv,
1155 mg_types = emptyTypeEnv,
1159 mg_binds = cm_binds coreModule,
1160 mg_foreign = NoStubs,
1161 mg_warns = NoWarnings,
1162 mg_hpc_info = emptyHpcInfo False,
1163 mg_modBreaks = emptyModBreaks,
1164 mg_vect_info = noVectInfo,
1165 mg_inst_env = emptyInstEnv,
1166 mg_fam_inst_env = emptyFamInstEnv
1169 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1170 compileCore simplify fn = do
1171 -- First, set the target to the desired filename
1172 target <- guessTarget fn Nothing
1175 -- Then find dependencies
1176 modGraph <- depanal [] True
1177 case find ((== fn) . msHsFilePath) modGraph of
1178 Just modSummary -> do
1179 -- Now we have the module name;
1180 -- parse, typecheck and desugar the module
1181 mod_guts <- coreModule `fmap`
1182 (desugarModule =<< typecheckModule =<< parseModule modSummary)
1183 liftM gutsToCoreModule $
1186 -- If simplify is true: simplify (hscSimplify), then tidy
1188 hsc_env <- getSession
1189 simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts)
1191 compHscEnv = hsc_env,
1192 compModSummary = modSummary,
1193 compOldIface = Nothing})
1194 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1195 return $ Left tidy_guts
1197 return $ Right mod_guts
1199 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1200 module dependency graph"
1201 where -- two versions, based on whether we simplify (thus run tidyProgram,
1202 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1203 -- we just have a ModGuts.
1204 gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
1205 gutsToCoreModule (Left (cg, md)) = CoreModule {
1206 cm_module = cg_module cg, cm_types = md_types md,
1207 cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
1209 gutsToCoreModule (Right mg) = CoreModule {
1210 cm_module = mg_module mg, cm_types = mg_types mg,
1211 cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
1214 -- ---------------------------------------------------------------------------
1217 unload :: HscEnv -> [Linkable] -> IO ()
1218 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
1219 = case ghcLink (hsc_dflags hsc_env) of
1221 LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
1223 LinkInMemory -> panic "unload: no interpreter"
1224 -- urgh. avoid warnings:
1225 hsc_env stable_linkables
1229 -- -----------------------------------------------------------------------------
1233 Stability tells us which modules definitely do not need to be recompiled.
1234 There are two main reasons for having stability:
1236 - avoid doing a complete upsweep of the module graph in GHCi when
1237 modules near the bottom of the tree have not changed.
1239 - to tell GHCi when it can load object code: we can only load object code
1240 for a module when we also load object code fo all of the imports of the
1241 module. So we need to know that we will definitely not be recompiling
1242 any of these modules, and we can use the object code.
1244 The stability check is as follows. Both stableObject and
1245 stableBCO are used during the upsweep phase later.
1248 stable m = stableObject m || stableBCO m
1251 all stableObject (imports m)
1252 && old linkable does not exist, or is == on-disk .o
1253 && date(on-disk .o) > date(.hs)
1256 all stable (imports m)
1257 && date(BCO) > date(.hs)
1260 These properties embody the following ideas:
1262 - if a module is stable, then:
1264 - if it has been compiled in a previous pass (present in HPT)
1265 then it does not need to be compiled or re-linked.
1267 - if it has not been compiled in a previous pass,
1268 then we only need to read its .hi file from disk and
1269 link it to produce a 'ModDetails'.
1271 - if a modules is not stable, we will definitely be at least
1272 re-linking, and possibly re-compiling it during the 'upsweep'.
1273 All non-stable modules can (and should) therefore be unlinked
1274 before the 'upsweep'.
1276 - Note that objects are only considered stable if they only depend
1277 on other objects. We can't link object code against byte code.
1281 :: HomePackageTable -- HPT from last compilation
1282 -> [SCC ModSummary] -- current module graph (cyclic)
1283 -> [ModuleName] -- all home modules
1284 -> ([ModuleName], -- stableObject
1285 [ModuleName]) -- stableBCO
1287 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
1289 checkSCC (stable_obj, stable_bco) scc0
1290 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
1291 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
1292 | otherwise = (stable_obj, stable_bco)
1294 scc = flattenSCC scc0
1295 scc_mods = map ms_mod_name scc
1296 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
1298 scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
1299 -- all imports outside the current SCC, but in the home pkg
1301 stable_obj_imps = map (`elem` stable_obj) scc_allimps
1302 stable_bco_imps = map (`elem` stable_bco) scc_allimps
1306 && all object_ok scc
1309 and (zipWith (||) stable_obj_imps stable_bco_imps)
1313 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
1317 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
1318 Just hmi | Just l <- hm_linkable hmi
1319 -> isObjectLinkable l && t == linkableTime l
1321 -- why '>=' rather than '>' above? If the filesystem stores
1322 -- times to the nearset second, we may occasionally find that
1323 -- the object & source have the same modification time,
1324 -- especially if the source was automatically generated
1325 -- and compiled. Using >= is slightly unsafe, but it matches
1326 -- make's behaviour.
1329 = case lookupUFM hpt (ms_mod_name ms) of
1330 Just hmi | Just l <- hm_linkable hmi ->
1331 not (isObjectLinkable l) &&
1332 linkableTime l >= ms_hs_date ms
1335 ms_allimps :: ModSummary -> [ModuleName]
1336 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
1338 -- -----------------------------------------------------------------------------
1340 -- | Prune the HomePackageTable
1342 -- Before doing an upsweep, we can throw away:
1344 -- - For non-stable modules:
1345 -- - all ModDetails, all linked code
1346 -- - all unlinked code that is out of date with respect to
1349 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
1350 -- space at the end of the upsweep, because the topmost ModDetails of the
1351 -- old HPT holds on to the entire type environment from the previous
1354 pruneHomePackageTable
1357 -> ([ModuleName],[ModuleName])
1360 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
1363 | is_stable modl = hmi'
1364 | otherwise = hmi'{ hm_details = emptyModDetails }
1366 modl = moduleName (mi_module (hm_iface hmi))
1367 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1368 = hmi{ hm_linkable = Nothing }
1371 where ms = expectJust "prune" (lookupUFM ms_map modl)
1373 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1375 is_stable m = m `elem` stable_obj || m `elem` stable_bco
1377 -- -----------------------------------------------------------------------------
1379 -- Return (names of) all those in modsDone who are part of a cycle
1380 -- as defined by theGraph.
1381 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1382 findPartiallyCompletedCycles modsDone theGraph
1386 chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
1387 chew ((CyclicSCC vs):rest)
1388 = let names_in_this_cycle = nub (map ms_mod vs)
1390 = nub ([done | done <- modsDone,
1391 done `elem` names_in_this_cycle])
1392 chewed_rest = chew rest
1394 if notNull mods_in_this_cycle
1395 && length mods_in_this_cycle < length names_in_this_cycle
1396 then mods_in_this_cycle ++ chewed_rest
1399 -- -----------------------------------------------------------------------------
1403 -- This is where we compile each module in the module graph, in a pass
1404 -- from the bottom to the top of the graph.
1406 -- There better had not be any cyclic groups here -- we check for them.
1410 WarnErrLogger -- ^ Called to print warnings and errors.
1411 -> HscEnv -- ^ Includes initially-empty HPT
1412 -> HomePackageTable -- ^ HPT from last time round (pruned)
1413 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1414 -> IO () -- ^ How to clean up unwanted tmp files
1415 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1417 HscEnv, -- With an updated HPT
1418 [ModSummary]) -- Mods which succeeded
1420 upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do
1421 (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
1422 return (res, hsc_env, reverse done)
1425 upsweep' hsc_env _old_hpt done
1427 = return (Succeeded, hsc_env, done)
1429 upsweep' hsc_env _old_hpt done
1430 (CyclicSCC ms:_) _ _
1431 = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1432 return (Failed, hsc_env, done)
1434 upsweep' hsc_env old_hpt done
1435 (AcyclicSCC mod:mods) mod_index nmods
1436 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1437 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1438 -- (moduleEnvElts (hsc_HPT hsc_env)))
1441 <- handleSourceError
1442 (\err -> do logger (Just err); return Nothing) $ do
1443 mod_info <- upsweep_mod hsc_env old_hpt stable_mods
1445 logger Nothing -- log warnings
1446 return (Just mod_info)
1448 liftIO cleanup -- Remove unwanted tmp files between compilations
1451 Nothing -> return (Failed, hsc_env, done)
1453 let this_mod = ms_mod_name mod
1455 -- Add new info to hsc_env
1456 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1457 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1459 -- Space-saving: delete the old HPT entry
1460 -- for mod BUT if mod is a hs-boot
1461 -- node, don't delete it. For the
1462 -- interface, the HPT entry is probaby for the
1463 -- main Haskell source file. Deleting it
1464 -- would force the real module to be recompiled
1466 old_hpt1 | isBootSummary mod = old_hpt
1467 | otherwise = delFromUFM old_hpt this_mod
1471 -- fixup our HomePackageTable after we've finished compiling
1472 -- a mutually-recursive loop. See reTypecheckLoop, below.
1473 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
1475 upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
1477 -- | Compile a single module. Always produce a Linkable for it if
1478 -- successful. If no compilation happened, return the old Linkable.
1479 upsweep_mod :: GhcMonad m =>
1482 -> ([ModuleName],[ModuleName])
1484 -> Int -- index of module
1485 -> Int -- total number of modules
1488 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1490 this_mod_name = ms_mod_name summary
1491 this_mod = ms_mod summary
1492 mb_obj_date = ms_obj_date summary
1493 obj_fn = ml_obj_file (ms_location summary)
1494 hs_date = ms_hs_date summary
1496 is_stable_obj = this_mod_name `elem` stable_obj
1497 is_stable_bco = this_mod_name `elem` stable_bco
1499 old_hmi = lookupUFM old_hpt this_mod_name
1501 -- We're using the dflags for this module now, obtained by
1502 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1503 dflags = ms_hspp_opts summary
1504 prevailing_target = hscTarget (hsc_dflags hsc_env)
1505 local_target = hscTarget dflags
1507 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
1508 -- we don't do anything dodgy: these should only work to change
1509 -- from -fvia-C to -fasm and vice-versa, otherwise we could
1510 -- end up trying to link object code to byte code.
1511 target = if prevailing_target /= local_target
1512 && (not (isObjectTarget prevailing_target)
1513 || not (isObjectTarget local_target))
1514 then prevailing_target
1517 -- store the corrected hscTarget into the summary
1518 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1520 -- The old interface is ok if
1521 -- a) we're compiling a source file, and the old HPT
1522 -- entry is for a source file
1523 -- b) we're compiling a hs-boot file
1524 -- Case (b) allows an hs-boot file to get the interface of its
1525 -- real source file on the second iteration of the compilation
1526 -- manager, but that does no harm. Otherwise the hs-boot file
1527 -- will always be recompiled
1532 Just hm_info | isBootSummary summary -> Just iface
1533 | not (mi_boot iface) -> Just iface
1534 | otherwise -> Nothing
1536 iface = hm_iface hm_info
1538 compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo
1539 compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
1541 compile_it_discard_iface :: GhcMonad m =>
1542 Maybe Linkable -> m HomeModInfo
1543 compile_it_discard_iface
1544 = compile hsc_env summary' mod_index nmods Nothing
1550 -- Regardless of whether we're generating object code or
1551 -- byte code, we can always use an existing object file
1552 -- if it is *stable* (see checkStability).
1553 | is_stable_obj, isJust old_hmi ->
1554 let Just hmi = old_hmi in
1556 -- object is stable, and we have an entry in the
1557 -- old HPT: nothing to do
1559 | is_stable_obj, isNothing old_hmi -> do
1560 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1561 (expectJust "upsweep1" mb_obj_date)
1562 compile_it (Just linkable)
1563 -- object is stable, but we need to load the interface
1564 -- off disk to make a HMI.
1568 ASSERT(isJust old_hmi) -- must be in the old_hpt
1569 let Just hmi = old_hmi in
1571 -- BCO is stable: nothing to do
1573 | Just hmi <- old_hmi,
1574 Just l <- hm_linkable hmi, not (isObjectLinkable l),
1575 linkableTime l >= ms_hs_date summary ->
1577 -- we have an old BCO that is up to date with respect
1578 -- to the source: do a recompilation check as normal.
1582 -- no existing code at all: we must recompile.
1584 -- When generating object code, if there's an up-to-date
1585 -- object file on the disk, then we can use it.
1586 -- However, if the object file is new (compared to any
1587 -- linkable we had from a previous compilation), then we
1588 -- must discard any in-memory interface, because this
1589 -- means the user has compiled the source file
1590 -- separately and generated a new interface, that we must
1591 -- read from the disk.
1593 obj | isObjectTarget obj,
1594 Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1597 | Just l <- hm_linkable hmi,
1598 isObjectLinkable l && linkableTime l == obj_date
1599 -> compile_it (Just l)
1601 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1602 compile_it_discard_iface (Just linkable)
1609 -- Filter modules in the HPT
1610 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1611 retainInTopLevelEnvs keep_these hpt
1612 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1614 , let mb_mod_info = lookupUFM hpt mod
1615 , isJust mb_mod_info ]
1617 -- ---------------------------------------------------------------------------
1618 -- Typecheck module loops
1621 See bug #930. This code fixes a long-standing bug in --make. The
1622 problem is that when compiling the modules *inside* a loop, a data
1623 type that is only defined at the top of the loop looks opaque; but
1624 after the loop is done, the structure of the data type becomes
1627 The difficulty is then that two different bits of code have
1628 different notions of what the data type looks like.
1630 The idea is that after we compile a module which also has an .hs-boot
1631 file, we re-generate the ModDetails for each of the modules that
1632 depends on the .hs-boot file, so that everyone points to the proper
1633 TyCons, Ids etc. defined by the real module, not the boot module.
1634 Fortunately re-generating a ModDetails from a ModIface is easy: the
1635 function TcIface.typecheckIface does exactly that.
1637 Picking the modules to re-typecheck is slightly tricky. Starting from
1638 the module graph consisting of the modules that have already been
1639 compiled, we reverse the edges (so they point from the imported module
1640 to the importing module), and depth-first-search from the .hs-boot
1641 node. This gives us all the modules that depend transitively on the
1642 .hs-boot module, and those are exactly the modules that we need to
1645 Following this fix, GHC can compile itself with --make -O2.
1648 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1649 reTypecheckLoop hsc_env ms graph
1650 | not (isBootSummary ms) &&
1651 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
1653 let mss = reachableBackwards (ms_mod_name ms) graph
1654 non_boot = filter (not.isBootSummary) mss
1655 debugTraceMsg (hsc_dflags hsc_env) 2 $
1656 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
1657 typecheckLoop hsc_env (map ms_mod_name non_boot)
1661 this_mod = ms_mod ms
1663 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
1664 typecheckLoop hsc_env mods = do
1666 fixIO $ \new_hpt -> do
1667 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1668 mds <- initIfaceCheck new_hsc_env $
1669 mapM (typecheckIface . hm_iface) hmis
1670 let new_hpt = addListToUFM old_hpt
1671 (zip mods [ hmi{ hm_details = details }
1672 | (hmi,details) <- zip hmis mds ])
1674 return hsc_env{ hsc_HPT = new_hpt }
1676 old_hpt = hsc_HPT hsc_env
1677 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
1679 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1680 reachableBackwards mod summaries
1681 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
1682 where -- the rest just sets up the graph:
1683 (graph, lookup_node) = moduleGraphNodes False summaries
1684 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1686 -- ---------------------------------------------------------------------------
1687 -- Topological sort of the module graph
1689 type SummaryNode = (ModSummary, Int, [Int])
1692 :: Bool -- Drop hi-boot nodes? (see below)
1696 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1697 -- The resulting list of strongly-connected-components is in topologically
1698 -- sorted order, starting with the module(s) at the bottom of the
1699 -- dependency graph (ie compile them first) and ending with the ones at
1702 -- Drop hi-boot nodes (first boolean arg)?
1704 -- False: treat the hi-boot summaries as nodes of the graph,
1705 -- so the graph must be acyclic
1707 -- True: eliminate the hi-boot nodes, and instead pretend
1708 -- the a source-import of Foo is an import of Foo
1709 -- The resulting graph has no hi-boot nodes, but can be cyclic
1711 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
1712 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1714 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
1716 initial_graph = case mb_root_mod of
1719 -- restrict the graph to just those modules reachable from
1720 -- the specified module. We do this by building a graph with
1721 -- the full set of nodes, and determining the reachable set from
1722 -- the specified node.
1723 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
1724 | otherwise = ghcError (ProgramError "module does not exist")
1725 in graphFromEdgedVertices (seq root (reachableG graph root))
1727 summaryNodeKey :: SummaryNode -> Int
1728 summaryNodeKey (_, k, _) = k
1730 summaryNodeSummary :: SummaryNode -> ModSummary
1731 summaryNodeSummary (s, _, _) = s
1733 moduleGraphNodes :: Bool -> [ModSummary]
1734 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1735 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
1737 numbered_summaries = zip summaries [1..]
1739 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1740 lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
1742 lookup_key :: HscSource -> ModuleName -> Maybe Int
1743 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1745 node_map :: NodeMap SummaryNode
1746 node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
1747 | node@(s, _, _) <- nodes ]
1749 -- We use integers as the keys for the SCC algorithm
1750 nodes :: [SummaryNode]
1751 nodes = [ (s, key, out_keys)
1752 | (s, key) <- numbered_summaries
1753 -- Drop the hi-boot ones if told to do so
1754 , not (isBootSummary s && drop_hs_boot_nodes)
1755 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1756 out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
1757 (-- see [boot-edges] below
1758 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1760 else case lookup_key HsBootFile (ms_mod_name s) of
1764 -- [boot-edges] if this is a .hs and there is an equivalent
1765 -- .hs-boot, add a link from the former to the latter. This
1766 -- has the effect of detecting bogus cases where the .hs-boot
1767 -- depends on the .hs, by introducing a cycle. Additionally,
1768 -- it ensures that we will always process the .hs-boot before
1769 -- the .hs, and so the HomePackageTable will always have the
1770 -- most up to date information.
1772 -- Drop hs-boot nodes by using HsSrcFile as the key
1773 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1774 | otherwise = HsBootFile
1776 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1777 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1778 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1779 -- the IsBootInterface parameter True; else False
1782 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1783 type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
1785 msKey :: ModSummary -> NodeKey
1786 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1788 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1789 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1791 nodeMapElts :: NodeMap a -> [a]
1792 nodeMapElts = eltsFM
1794 -- | If there are {-# SOURCE #-} imports between strongly connected
1795 -- components in the topological sort, then those imports can
1796 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1797 -- were necessary, then the edge would be part of a cycle.
1798 warnUnnecessarySourceImports :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m ()
1799 warnUnnecessarySourceImports dflags sccs =
1800 liftIO $ printBagOfWarnings dflags (listToBag (concatMap (check.flattenSCC) sccs))
1802 let mods_in_this_cycle = map ms_mod_name ms in
1803 [ warn i | m <- ms, i <- ms_srcimps m,
1804 unLoc i `notElem` mods_in_this_cycle ]
1806 warn :: Located ModuleName -> WarnMsg
1809 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1810 <+> quotes (ppr mod))
1812 -----------------------------------------------------------------------------
1813 -- Downsweep (dependency analysis)
1815 -- Chase downwards from the specified root set, returning summaries
1816 -- for all home modules encountered. Only follow source-import
1819 -- We pass in the previous collection of summaries, which is used as a
1820 -- cache to avoid recalculating a module summary if the source is
1823 -- The returned list of [ModSummary] nodes has one node for each home-package
1824 -- module, plus one for any hs-boot files. The imports of these nodes
1825 -- are all there, including the imports of non-home-package modules.
1827 downsweep :: GhcMonad m =>
1829 -> [ModSummary] -- Old summaries
1830 -> [ModuleName] -- Ignore dependencies on these; treat
1831 -- them as if they were package modules
1832 -> Bool -- True <=> allow multiple targets to have
1833 -- the same module name; this is
1834 -- very useful for ghc -M
1836 -- The elts of [ModSummary] all have distinct
1837 -- (Modules, IsBoot) identifiers, unless the Bool is true
1838 -- in which case there can be repeats
1839 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1840 = do -- catch error messages and return them
1841 --handleErrMsg -- should be covered by GhcMonad now
1842 -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1843 rootSummaries <- mapM getRootSummary roots
1844 let root_map = mkRootMap rootSummaries
1845 checkDuplicates root_map
1846 summs <- loop (concatMap msDeps rootSummaries) root_map
1849 roots = hsc_targets hsc_env
1851 old_summary_map :: NodeMap ModSummary
1852 old_summary_map = mkNodeMap old_summaries
1854 getRootSummary :: GhcMonad m => Target -> m ModSummary
1855 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1856 = do exists <- liftIO $ doesFileExist file
1858 then summariseFile hsc_env old_summaries file mb_phase
1859 obj_allowed maybe_buf
1860 else throwOneError $ mkPlainErrMsg noSrcSpan $
1861 text "can't find file:" <+> text file
1862 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1863 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1864 (L rootLoc modl) obj_allowed
1866 case maybe_summary of
1867 Nothing -> packageModErr modl
1870 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1872 -- In a root module, the filename is allowed to diverge from the module
1873 -- name, so we have to check that there aren't multiple root files
1874 -- defining the same module (otherwise the duplicates will be silently
1875 -- ignored, leading to confusing behaviour).
1876 checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m ()
1877 checkDuplicates root_map
1878 | allow_dup_roots = return ()
1879 | null dup_roots = return ()
1880 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1882 dup_roots :: [[ModSummary]] -- Each at least of length 2
1883 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1885 loop :: GhcMonad m =>
1886 [(Located ModuleName,IsBootInterface)]
1887 -- Work list: process these modules
1888 -> NodeMap [ModSummary]
1889 -- Visited set; the range is a list because
1890 -- the roots can have the same module names
1891 -- if allow_dup_roots is True
1893 -- The result includes the worklist, except
1894 -- for those mentioned in the visited set
1895 loop [] done = return (concat (nodeMapElts done))
1896 loop ((wanted_mod, is_boot) : ss) done
1897 | Just summs <- lookupFM done key
1898 = if isSingleton summs then
1901 do { liftIO $ multiRootsErr summs; return [] }
1903 = do mb_s <- summariseModule hsc_env old_summary_map
1904 is_boot wanted_mod True
1907 Nothing -> loop ss done
1908 Just s -> loop (msDeps s ++ ss) (addToFM done key [s])
1910 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1912 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1913 mkRootMap summaries = addListToFM_C (++) emptyFM
1914 [ (msKey s, [s]) | s <- summaries ]
1916 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1917 -- (msDeps s) returns the dependencies of the ModSummary s.
1918 -- A wrinkle is that for a {-# SOURCE #-} import we return
1919 -- *both* the hs-boot file
1920 -- *and* the source file
1921 -- as "dependencies". That ensures that the list of all relevant
1922 -- modules always contains B.hs if it contains B.hs-boot.
1923 -- Remember, this pass isn't doing the topological sort. It's
1924 -- just gathering the list of all relevant ModSummaries
1926 concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1927 ++ [ (m,False) | m <- ms_imps s ]
1929 -----------------------------------------------------------------------------
1930 -- Summarising modules
1932 -- We have two types of summarisation:
1934 -- * Summarise a file. This is used for the root module(s) passed to
1935 -- cmLoadModules. The file is read, and used to determine the root
1936 -- module name. The module name may differ from the filename.
1938 -- * Summarise a module. We are given a module name, and must provide
1939 -- a summary. The finder is used to locate the file in which the module
1945 -> [ModSummary] -- old summaries
1946 -> FilePath -- source file name
1947 -> Maybe Phase -- start phase
1948 -> Bool -- object code allowed?
1949 -> Maybe (StringBuffer,ClockTime)
1952 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1953 -- we can use a cached summary if one is available and the
1954 -- source file hasn't changed, But we have to look up the summary
1955 -- by source file, rather than module name as we do in summarise.
1956 | Just old_summary <- findSummaryBySourceFile old_summaries file
1958 let location = ms_location old_summary
1960 -- return the cached summary if the source didn't change
1961 src_timestamp <- case maybe_buf of
1962 Just (_,t) -> return t
1963 Nothing -> liftIO $ getModificationTime file
1964 -- The file exists; we checked in getRootSummary above.
1965 -- If it gets removed subsequently, then this
1966 -- getModificationTime may fail, but that's the right
1969 if ms_hs_date old_summary == src_timestamp
1970 then do -- update the object-file timestamp
1972 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1973 || obj_allowed -- bug #1205
1974 then liftIO $ getObjTimestamp location False
1976 return old_summary{ ms_obj_date = obj_timestamp }
1984 let dflags = hsc_dflags hsc_env
1986 (dflags', hspp_fn, buf)
1987 <- preprocessFile hsc_env file mb_phase maybe_buf
1989 (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file
1991 -- Make a ModLocation for this file
1992 location <- liftIO $ mkHomeModLocation dflags mod_name file
1994 -- Tell the Finder cache where it is, so that subsequent calls
1995 -- to findModule will find it, even if it's not on any search path
1996 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
1998 src_timestamp <- case maybe_buf of
1999 Just (_,t) -> return t
2000 Nothing -> liftIO $ getModificationTime file
2001 -- getMofificationTime may fail
2003 -- when the user asks to load a source file by name, we only
2004 -- use an object file if -fobject-code is on. See #1205.
2006 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2007 || obj_allowed -- bug #1205
2008 then liftIO $ modificationTimeIfExists (ml_obj_file location)
2011 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
2012 ms_location = location,
2013 ms_hspp_file = hspp_fn,
2014 ms_hspp_opts = dflags',
2015 ms_hspp_buf = Just buf,
2016 ms_srcimps = srcimps, ms_imps = the_imps,
2017 ms_hs_date = src_timestamp,
2018 ms_obj_date = obj_timestamp })
2020 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
2021 findSummaryBySourceFile summaries file
2022 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
2023 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
2027 -- Summarise a module, and pick up source and timestamp.
2031 -> NodeMap ModSummary -- Map of old summaries
2032 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
2033 -> Located ModuleName -- Imported module to be summarised
2034 -> Bool -- object code allowed?
2035 -> Maybe (StringBuffer, ClockTime)
2036 -> [ModuleName] -- Modules to exclude
2037 -> m (Maybe ModSummary) -- Its new summary
2039 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
2040 obj_allowed maybe_buf excl_mods
2041 | wanted_mod `elem` excl_mods
2044 | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
2045 = do -- Find its new timestamp; all the
2046 -- ModSummaries in the old map have valid ml_hs_files
2047 let location = ms_location old_summary
2048 src_fn = expectJust "summariseModule" (ml_hs_file location)
2050 -- check the modification time on the source file, and
2051 -- return the cached summary if it hasn't changed. If the
2052 -- file has disappeared, we need to call the Finder again.
2054 Just (_,t) -> check_timestamp old_summary location src_fn t
2056 m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
2058 Right t -> check_timestamp old_summary location src_fn t
2059 Left e | isDoesNotExistError e -> find_it
2060 | otherwise -> liftIO $ ioError e
2062 | otherwise = find_it
2064 dflags = hsc_dflags hsc_env
2066 hsc_src = if is_boot then HsBootFile else HsSrcFile
2068 check_timestamp old_summary location src_fn src_timestamp
2069 | ms_hs_date old_summary == src_timestamp = do
2070 -- update the object-file timestamp
2071 obj_timestamp <- liftIO $
2072 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2073 || obj_allowed -- bug #1205
2074 then getObjTimestamp location is_boot
2076 return (Just old_summary{ ms_obj_date = obj_timestamp })
2078 -- source changed: re-summarise.
2079 new_summary location (ms_mod old_summary) src_fn src_timestamp
2082 -- Don't use the Finder's cache this time. If the module was
2083 -- previously a package module, it may have now appeared on the
2084 -- search path, so we want to consider it to be a home module. If
2085 -- the module was previously a home module, it may have moved.
2086 liftIO $ uncacheModule hsc_env wanted_mod
2087 found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
2090 | isJust (ml_hs_file location) ->
2092 just_found location mod
2094 -- Drop external-pkg
2095 ASSERT(modulePackageId mod /= thisPackage dflags)
2098 err -> liftIO $ noModError dflags loc wanted_mod err
2101 just_found location mod = do
2102 -- Adjust location to point to the hs-boot source file,
2103 -- hi file, object file, when is_boot says so
2104 let location' | is_boot = addBootSuffixLocn location
2105 | otherwise = location
2106 src_fn = expectJust "summarise2" (ml_hs_file location')
2108 -- Check that it exists
2109 -- It might have been deleted since the Finder last found it
2110 maybe_t <- liftIO $ modificationTimeIfExists src_fn
2112 Nothing -> noHsFileErr loc src_fn
2113 Just t -> new_summary location' mod src_fn t
2116 new_summary location mod src_fn src_timestamp
2118 -- Preprocess the source file and get its imports
2119 -- The dflags' contains the OPTIONS pragmas
2120 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2121 (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn
2123 when (mod_name /= wanted_mod) $
2124 throwOneError $ mkPlainErrMsg mod_loc $
2125 text "File name does not match module name:"
2126 $$ text "Saw:" <+> quotes (ppr mod_name)
2127 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2129 -- Find the object timestamp, and return the summary
2130 obj_timestamp <- liftIO $
2131 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2132 || obj_allowed -- bug #1205
2133 then getObjTimestamp location is_boot
2136 return (Just (ModSummary { ms_mod = mod,
2137 ms_hsc_src = hsc_src,
2138 ms_location = location,
2139 ms_hspp_file = hspp_fn,
2140 ms_hspp_opts = dflags',
2141 ms_hspp_buf = Just buf,
2142 ms_srcimps = srcimps,
2144 ms_hs_date = src_timestamp,
2145 ms_obj_date = obj_timestamp }))
2148 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
2149 getObjTimestamp location is_boot
2150 = if is_boot then return Nothing
2151 else modificationTimeIfExists (ml_obj_file location)
2154 preprocessFile :: GhcMonad m =>
2157 -> Maybe Phase -- ^ Starting phase
2158 -> Maybe (StringBuffer,ClockTime)
2159 -> m (DynFlags, FilePath, StringBuffer)
2160 preprocessFile hsc_env src_fn mb_phase Nothing
2162 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2163 buf <- liftIO $ hGetStringBuffer hspp_fn
2164 return (dflags', hspp_fn, buf)
2166 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2168 let dflags = hsc_dflags hsc_env
2169 -- case we bypass the preprocessing stage?
2171 local_opts = getOptions dflags buf src_fn
2173 (dflags', leftovers, warns)
2174 <- parseDynamicNoPackageFlags dflags local_opts
2175 liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
2176 liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions
2180 | Just (Unlit _) <- mb_phase = True
2181 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2182 -- note: local_opts is only required if there's no Unlit phase
2183 | dopt Opt_Cpp dflags' = True
2184 | dopt Opt_Pp dflags' = True
2187 when needs_preprocessing $
2188 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
2190 return (dflags', src_fn, buf)
2193 -----------------------------------------------------------------------------
2195 -----------------------------------------------------------------------------
2197 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
2198 -- ToDo: we don't have a proper line number for this error
2199 noModError dflags loc wanted_mod err
2200 = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
2202 noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
2203 noHsFileErr loc path
2204 = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
2206 packageModErr :: GhcMonad m => ModuleName -> m a
2208 = throwOneError $ mkPlainErrMsg noSrcSpan $
2209 text "module" <+> quotes (ppr mod) <+> text "is a package module"
2211 multiRootsErr :: [ModSummary] -> IO ()
2212 multiRootsErr [] = panic "multiRootsErr"
2213 multiRootsErr summs@(summ1:_)
2214 = throwOneError $ mkPlainErrMsg noSrcSpan $
2215 text "module" <+> quotes (ppr mod) <+>
2216 text "is defined in multiple files:" <+>
2217 sep (map text files)
2220 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2222 cyclicModuleErr :: [ModSummary] -> SDoc
2224 = hang (ptext (sLit "Module imports form a cycle for modules:"))
2225 2 (vcat (map show_one ms))
2227 show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
2228 nest 2 $ ptext (sLit "imports:") <+>
2229 (pp_imps HsBootFile (ms_srcimps ms)
2230 $$ pp_imps HsSrcFile (ms_imps ms))]
2231 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
2232 pp_imps src mods = fsep (map (show_mod src) mods)
2235 -- | Inform GHC that the working directory has changed. GHC will flush
2236 -- its cache of module locations, since it may no longer be valid.
2237 -- Note: if you change the working directory, you should also unload
2238 -- the current program (set targets to empty, followed by load).
2239 workingDirectoryChanged :: GhcMonad m => m ()
2240 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
2242 -- -----------------------------------------------------------------------------
2243 -- inspecting the session
2245 -- | Get the module dependency graph.
2246 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
2247 getModuleGraph = liftM hsc_mod_graph getSession
2249 -- | Return @True@ <==> module is loaded.
2250 isLoaded :: GhcMonad m => ModuleName -> m Bool
2251 isLoaded m = withSession $ \hsc_env ->
2252 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
2254 -- | Return the bindings for the current interactive session.
2255 getBindings :: GhcMonad m => m [TyThing]
2256 getBindings = withSession $ \hsc_env ->
2257 -- we have to implement the shadowing behaviour of ic_tmp_ids here
2258 -- (see InteractiveContext) and the quickest way is to use an OccEnv.
2260 tmp_ids = ic_tmp_ids (hsc_IC hsc_env)
2261 filtered = foldr f (const []) tmp_ids emptyUniqSet
2263 | uniq `elementOfUniqSet` set = rest set
2264 | otherwise = AnId id : rest (addOneToUniqSet set uniq)
2265 where uniq = getUnique (nameOccName (idName id))
2269 getPrintUnqual :: GhcMonad m => m PrintUnqualified
2270 getPrintUnqual = withSession $ \hsc_env ->
2271 return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
2273 -- | Container for information about a 'Module'.
2274 data ModuleInfo = ModuleInfo {
2275 minf_type_env :: TypeEnv,
2276 minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
2277 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
2278 minf_instances :: [Instance]
2280 ,minf_modBreaks :: ModBreaks
2282 -- ToDo: this should really contain the ModIface too
2284 -- We don't want HomeModInfo here, because a ModuleInfo applies
2285 -- to package modules too.
2287 -- | Request information about a loaded 'Module'
2288 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
2289 getModuleInfo mdl = withSession $ \hsc_env -> do
2290 let mg = hsc_mod_graph hsc_env
2291 if mdl `elem` map ms_mod mg
2292 then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
2294 {- if isHomeModule (hsc_dflags hsc_env) mdl
2296 else -} liftIO $ getPackageModuleInfo hsc_env mdl
2297 -- getPackageModuleInfo will attempt to find the interface, so
2298 -- we don't want to call it for a home module, just in case there
2299 -- was a problem loading the module and the interface doesn't
2300 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
2302 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
2304 getPackageModuleInfo hsc_env mdl = do
2305 (_msgs, mb_avails) <- getModuleExports hsc_env mdl
2307 Nothing -> return Nothing
2309 eps <- readIORef (hsc_EPS hsc_env)
2311 names = availsToNameSet avails
2313 tys = [ ty | name <- concatMap availNames avails,
2314 Just ty <- [lookupTypeEnv pte name] ]
2316 return (Just (ModuleInfo {
2317 minf_type_env = mkTypeEnv tys,
2318 minf_exports = names,
2319 minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
2320 minf_instances = error "getModuleInfo: instances for package module unimplemented",
2321 minf_modBreaks = emptyModBreaks
2324 getPackageModuleInfo _hsc_env _mdl = do
2325 -- bogusly different for non-GHCI (ToDo)
2329 getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
2330 getHomeModuleInfo hsc_env mdl =
2331 case lookupUFM (hsc_HPT hsc_env) mdl of
2332 Nothing -> return Nothing
2334 let details = hm_details hmi
2335 return (Just (ModuleInfo {
2336 minf_type_env = md_types details,
2337 minf_exports = availsToNameSet (md_exports details),
2338 minf_rdr_env = mi_globals $! hm_iface hmi,
2339 minf_instances = md_insts details
2341 ,minf_modBreaks = getModBreaks hmi
2345 -- | The list of top-level entities defined in a module
2346 modInfoTyThings :: ModuleInfo -> [TyThing]
2347 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
2349 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
2350 modInfoTopLevelScope minf
2351 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
2353 modInfoExports :: ModuleInfo -> [Name]
2354 modInfoExports minf = nameSetToList $! minf_exports minf
2356 -- | Returns the instances defined by the specified module.
2357 -- Warning: currently unimplemented for package modules.
2358 modInfoInstances :: ModuleInfo -> [Instance]
2359 modInfoInstances = minf_instances
2361 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
2362 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
2364 mkPrintUnqualifiedForModule :: GhcMonad m =>
2366 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
2367 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
2368 return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
2370 modInfoLookupName :: GhcMonad m =>
2372 -> m (Maybe TyThing) -- XXX: returns a Maybe X
2373 modInfoLookupName minf name = withSession $ \hsc_env -> do
2374 case lookupTypeEnv (minf_type_env minf) name of
2375 Just tyThing -> return (Just tyThing)
2377 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2378 return $! lookupType (hsc_dflags hsc_env)
2379 (hsc_HPT hsc_env) (eps_PTE eps) name
2382 modInfoModBreaks :: ModuleInfo -> ModBreaks
2383 modInfoModBreaks = minf_modBreaks
2386 isDictonaryId :: Id -> Bool
2388 = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
2390 -- | Looks up a global name: that is, any top-level name in any
2391 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
2392 -- the interactive context, and therefore does not require a preceding
2394 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
2395 lookupGlobalName name = withSession $ \hsc_env -> do
2396 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2397 return $! lookupType (hsc_dflags hsc_env)
2398 (hsc_HPT hsc_env) (eps_PTE eps) name
2401 -- | get the GlobalRdrEnv for a session
2402 getGRE :: GhcMonad m => m GlobalRdrEnv
2403 getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
2406 -- -----------------------------------------------------------------------------
2407 -- Misc exported utils
2409 dataConType :: DataCon -> Type
2410 dataConType dc = idType (dataConWrapId dc)
2412 -- | print a 'NamedThing', adding parentheses if the name is an operator.
2413 pprParenSymName :: NamedThing a => a -> SDoc
2414 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
2416 -- ----------------------------------------------------------------------------
2421 -- - Data and Typeable instances for HsSyn.
2423 -- ToDo: check for small transformations that happen to the syntax in
2424 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
2426 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
2427 -- to get from TyCons, Ids etc. to TH syntax (reify).
2429 -- :browse will use either lm_toplev or inspect lm_interface, depending
2430 -- on whether the module is interpreted or not.
2434 -- Extract the filename, stringbuffer content and dynflags associed to a module
2436 -- XXX: Explain pre-conditions
2437 getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
2438 getModuleSourceAndFlags mod = do
2439 m <- getModSummary (moduleName mod)
2440 case ml_hs_file $ ms_location m of
2441 Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
2442 Just sourceFile -> do
2443 source <- liftIO $ hGetStringBuffer sourceFile
2444 return (sourceFile, source, ms_hspp_opts m)
2447 -- | Return module source as token stream, including comments.
2449 -- The module must be in the module graph and its source must be available.
2450 -- Throws a 'HscTypes.SourceError' on parse error.
2451 getTokenStream :: GhcMonad m => Module -> m [Located Token]
2452 getTokenStream mod = do
2453 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2454 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2455 case lexTokenStream source startLoc flags of
2456 POk _ ts -> return ts
2457 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2459 -- | Give even more information on the source than 'getTokenStream'
2460 -- This function allows reconstructing the source completely with
2461 -- 'showRichTokenStream'.
2462 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
2463 getRichTokenStream mod = do
2464 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2465 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2466 case lexTokenStream source startLoc flags of
2467 POk _ ts -> return $ addSourceToTokens startLoc source ts
2468 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2470 -- | Given a source location and a StringBuffer corresponding to this
2471 -- location, return a rich token stream with the source associated to the
2473 addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
2474 -> [(Located Token, String)]
2475 addSourceToTokens _ _ [] = []
2476 addSourceToTokens loc buf (t@(L span _) : ts)
2477 | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
2478 | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
2480 (newLoc, newBuf, str) = go "" loc buf
2481 start = srcSpanStart span
2482 end = srcSpanEnd span
2483 go acc loc buf | loc < start = go acc nLoc nBuf
2484 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
2485 | otherwise = (loc, buf, reverse acc)
2486 where (ch, nBuf) = nextChar buf
2487 nLoc = advanceSrcLoc loc ch
2490 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
2491 -- return source code almost identical to the original code (except for
2492 -- insignificant whitespace.)
2493 showRichTokenStream :: [(Located Token, String)] -> String
2494 showRichTokenStream ts = go startLoc ts ""
2495 where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
2496 startLoc = mkSrcLoc sourceFile 0 0
2498 go loc ((L span _, str):ts)
2499 | not (isGoodSrcSpan span) = go loc ts
2500 | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
2503 | otherwise = ((replicate (tokLine - locLine) '\n') ++)
2504 . ((replicate tokCol ' ') ++)
2507 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
2508 (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
2509 tokEnd = srcSpanEnd span
2511 -- -----------------------------------------------------------------------------
2512 -- Interactive evaluation
2514 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
2515 -- filesystem and package database to find the corresponding 'Module',
2516 -- using the algorithm that is used for an @import@ declaration.
2517 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2518 findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX
2520 dflags = hsc_dflags hsc_env
2521 hpt = hsc_HPT hsc_env
2522 this_pkg = thisPackage dflags
2524 case lookupUFM hpt mod_name of
2525 Just mod_info -> return (mi_module (hm_iface mod_info))
2526 _not_a_home_module -> do
2527 res <- findImportedModule hsc_env mod_name maybe_pkg
2529 Found _ m | modulePackageId m /= this_pkg -> return m
2530 | otherwise -> ghcError (CmdLineError (showSDoc $
2531 text "module" <+> quotes (ppr (moduleName m)) <+>
2532 text "is not loaded"))
2533 err -> let msg = cannotFindModule dflags mod_name err in
2534 ghcError (CmdLineError (showSDoc msg))
2537 getHistorySpan :: GhcMonad m => History -> m SrcSpan
2538 getHistorySpan h = withSession $ \hsc_env ->
2539 return$ InteractiveEval.getHistorySpan hsc_env h
2541 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
2542 obtainTermFromVal bound force ty a =
2543 withSession $ \hsc_env ->
2544 liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
2546 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
2547 obtainTermFromId bound force id =
2548 withSession $ \hsc_env ->
2549 liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
projects / ghc-hetmet.git / blob