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,
20 handleSourceError, defaultCallbacks, GhcApiCallbacks(..),
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(..),
47 SuccessFlag(..), succeeded, failed,
48 defaultWarnErrLogger, WarnErrLogger,
49 workingDirectoryChanged,
50 parseModule, typecheckModule, desugarModule, loadModule,
51 ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
52 TypecheckedSource, ParsedSource, RenamedSource, -- ditto
53 TypecheckedMod, ParsedMod,
54 moduleInfo, renamedSource, typecheckedSource,
55 parsedSource, coreModule,
56 compileToCoreModule, compileToCoreSimplified,
60 -- * Parsing Haddock comments
63 -- * Inspecting the module structure of the program
64 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
69 -- * Inspecting modules
76 modInfoIsExportedName,
80 mkPrintUnqualifiedForModule,
82 -- * Querying the environment
86 PrintUnqualified, alwaysQualify,
88 -- * Interactive evaluation
89 getBindings, getPrintUnqual,
92 setContext, getContext,
102 runStmt, SingleStep(..),
104 Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
105 resumeHistory, resumeHistoryIx),
106 History(historyBreakInfo, historyEnclosingDecl),
107 GHC.getHistorySpan, getHistoryModule,
110 InteractiveEval.back,
111 InteractiveEval.forward,
114 InteractiveEval.compileExpr, HValue, dynCompileExpr,
116 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
118 ModBreaks(..), BreakIndex,
119 BreakInfo(breakInfo_number, breakInfo_module),
120 BreakArray, setBreakOn, setBreakOff, getBreak,
123 -- * Abstract syntax elements
129 Module, mkModule, pprModule, moduleName, modulePackageId,
130 ModuleName, mkModuleName, moduleNameString,
134 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
136 RdrName(Qual,Unqual),
140 isImplicitId, isDeadBinder,
141 isExportedId, isLocalId, isGlobalId,
143 isPrimOpId, isFCallId, isClassOpId_maybe,
144 isDataConWorkId, idDataCon,
145 isBottomingId, isDictonaryId,
146 recordSelectorFieldLabel,
148 -- ** Type constructors
150 tyConTyVars, tyConDataCons, tyConArity,
151 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
153 synTyConDefn, synTyConType, synTyConResKind,
159 -- ** Data constructors
161 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
162 dataConIsInfix, isVanillaDataCon,
164 StrictnessMark(..), isMarkedStrict,
168 classMethods, classSCTheta, classTvsFds,
173 instanceDFunId, pprInstance, pprInstanceHdr,
175 -- ** Types and Kinds
176 Type, splitForAllTys, funResultTy,
177 pprParendType, pprTypeApp,
180 ThetaType, pprThetaArrow,
186 module HsSyn, -- ToDo: remove extraneous bits
190 defaultFixity, maxPrecedence,
194 -- ** Source locations
196 mkSrcLoc, isGoodSrcLoc, noSrcLoc,
197 srcLocFile, srcLocLine, srcLocCol,
199 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
200 srcSpanStart, srcSpanEnd,
202 srcSpanStartLine, srcSpanEndLine,
203 srcSpanStartCol, srcSpanEndCol,
208 -- *** Constructing Located
209 noLoc, mkGeneralLocated,
211 -- *** Deconstructing Located
214 -- *** Combining and comparing Located values
215 eqLocated, cmpLocated, combineLocs, addCLoc,
216 leftmost_smallest, leftmost_largest, rightmost,
220 GhcException(..), showGhcException,
222 -- * Token stream manipulations
224 getTokenStream, getRichTokenStream,
225 showRichTokenStream, addSourceToTokens,
235 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
236 * what StaticFlags should we expose, if any?
239 #include "HsVersions.h"
242 import qualified Linker
243 import Linker ( HValue )
247 import InteractiveEval
252 import TcRnTypes hiding (LIE)
253 import TcRnMonad ( initIfaceCheck )
257 import qualified HsSyn -- hack as we want to reexport the whole module
258 import HsSyn hiding ((<.>))
259 import Type hiding (typeKind)
260 import TcType hiding (typeKind)
263 import TysPrim ( alphaTyVars )
268 import Name hiding ( varName )
269 import OccName ( parenSymOcc )
270 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
272 import FamInstEnv ( emptyFamInstEnv )
276 import DriverPipeline
277 import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
283 import StaticFlagParser
284 import qualified StaticFlags
285 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
290 import qualified UniqFM as UFM
296 import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
300 import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
303 import Maybes ( expectJust, mapCatMaybes )
305 import HaddockLex ( tokenise )
309 import Control.Concurrent
310 import System.Directory ( getModificationTime, doesFileExist,
311 getCurrentDirectory )
314 import qualified Data.List as List
315 import Data.Typeable ( Typeable )
316 import Data.Word ( Word8 )
318 import System.Exit ( exitWith, ExitCode(..) )
319 import System.Time ( ClockTime, getClockTime )
322 import System.FilePath
324 import System.IO.Error ( try, isDoesNotExistError )
325 import Prelude hiding (init)
328 -- -----------------------------------------------------------------------------
329 -- Exception handlers
331 -- | Install some default exception handlers and run the inner computation.
332 -- Unless you want to handle exceptions yourself, you should wrap this around
333 -- the top level of your program. The default handlers output the error
334 -- message(s) to stderr and exit cleanly.
335 defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
336 defaultErrorHandler dflags inner =
337 -- top-level exception handler: any unrecognised exception is a compiler bug.
338 ghandle (\exception -> liftIO $ do
340 case fromException exception of
341 -- an IO exception probably isn't our fault, so don't panic
342 Just (ioe :: IOException) ->
343 fatalErrorMsg dflags (text (show ioe))
344 _ -> case fromException exception of
345 Just StackOverflow ->
346 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
347 _ -> case fromException exception of
348 Just (ex :: ExitCode) -> throw ex
351 (text (show (Panic (show exception))))
352 exitWith (ExitFailure 1)
355 -- error messages propagated as exceptions
360 PhaseFailed _ code -> exitWith code
361 Interrupted -> exitWith (ExitFailure 1)
362 _ -> do fatalErrorMsg dflags (text (show ge))
363 exitWith (ExitFailure 1)
367 -- | Install a default cleanup handler to remove temporary files deposited by
368 -- a GHC run. This is seperate from 'defaultErrorHandler', because you might
369 -- want to override the error handling, but still get the ordinary cleanup
371 defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
372 DynFlags -> m a -> m a
373 defaultCleanupHandler dflags inner =
374 -- make sure we clean up after ourselves
377 cleanTempFiles dflags
380 -- exceptions will be blocked while we clean the temporary files,
381 -- so there shouldn't be any difficulty if we receive further
384 -- | Print the error message and all warnings. Useful inside exception
385 -- handlers. Clears warnings after printing.
386 printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
387 printExceptionAndWarnings err = do
388 let errs = srcErrorMessages err
390 dflags <- getSessionDynFlags
392 -- Empty errors means we failed due to -Werror. (Since this function
393 -- takes a source error as argument, we know for sure _some_ error
394 -- did indeed happen.)
396 printBagOfWarnings dflags warns
397 printBagOfErrors dflags (unitBag warnIsErrorMsg)
398 else liftIO $ printBagOfErrors dflags errs
401 -- | Print all accumulated warnings using 'log_action'.
402 printWarnings :: GhcMonad m => m ()
404 dflags <- getSessionDynFlags
406 liftIO $ printBagOfWarnings dflags warns
409 -- | Run function for the 'Ghc' monad.
411 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
412 -- to this function will create a new session which should not be shared among
415 -- Any errors not handled inside the 'Ghc' action are propagated as IO
418 runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
419 -> Ghc a -- ^ The action to perform.
421 runGhc mb_top_dir ghc = do
422 wref <- newIORef emptyBag
423 ref <- newIORef undefined
424 let session = Session ref wref
425 flip unGhc session $ do
426 initGhcMonad mb_top_dir
428 -- XXX: unregister interrupt handlers here?
430 -- | Run function for 'GhcT' monad transformer.
432 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
433 -- to this function will create a new session which should not be shared among
436 runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
437 Maybe FilePath -- ^ See argument to 'initGhcMonad'.
438 -> GhcT m a -- ^ The action to perform.
440 runGhcT mb_top_dir ghct = do
441 wref <- liftIO $ newIORef emptyBag
442 ref <- liftIO $ newIORef undefined
443 let session = Session ref wref
444 flip unGhcT session $ do
445 initGhcMonad mb_top_dir
448 -- | Initialise a GHC session.
450 -- If you implement a custom 'GhcMonad' you must call this function in the
451 -- monad run function. It will initialise the session variable and clear all
454 -- The first argument should point to the directory where GHC's library files
455 -- reside. More precisely, this should be the output of @ghc --print-libdir@
456 -- of the version of GHC the module using this API is compiled with. For
457 -- portability, you should use the @ghc-paths@ package, available at
458 -- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
460 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
461 initGhcMonad mb_top_dir = do
463 main_thread <- liftIO $ myThreadId
464 liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
465 liftIO $ installSignalHandlers
467 liftIO $ StaticFlags.initStaticOpts
469 dflags0 <- liftIO $ initDynFlags defaultDynFlags
470 dflags <- liftIO $ initSysTools mb_top_dir dflags0
471 env <- liftIO $ newHscEnv defaultCallbacks dflags
475 defaultCallbacks :: GhcApiCallbacks
478 reportModuleCompilationResult =
479 \_ mb_err -> defaultWarnErrLogger mb_err
482 -- -----------------------------------------------------------------------------
485 -- | Grabs the DynFlags from the Session
486 getSessionDynFlags :: GhcMonad m => m DynFlags
487 getSessionDynFlags = withSession (return . hsc_dflags)
489 -- | Updates the DynFlags in a Session. This also reads
490 -- the package database (unless it has already been read),
491 -- and prepares the compilers knowledge about packages. It
492 -- can be called again to load new packages: just add new
493 -- package flags to (packageFlags dflags).
495 -- Returns a list of new packages that may need to be linked in using
496 -- the dynamic linker (see 'linkPackages') as a result of new package
497 -- flags. If you are not doing linking or doing static linking, you
498 -- can ignore the list of packages returned.
500 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
501 setSessionDynFlags dflags = do
502 (dflags', preload) <- liftIO $ initPackages dflags
503 modifySession (\h -> h{ hsc_dflags = dflags' })
506 -- | If there is no -o option, guess the name of target executable
507 -- by using top-level source file name as a base.
508 guessOutputFile :: GhcMonad m => m ()
509 guessOutputFile = modifySession $ \env ->
510 let dflags = hsc_dflags env
511 mod_graph = hsc_mod_graph env
512 mainModuleSrcPath :: Maybe String
513 mainModuleSrcPath = do
514 let isMain = (== mainModIs dflags) . ms_mod
515 [ms] <- return (filter isMain mod_graph)
516 ml_hs_file (ms_location ms)
517 name = fmap dropExtension mainModuleSrcPath
519 #if defined(mingw32_HOST_OS)
520 -- we must add the .exe extention unconditionally here, otherwise
521 -- when name has an extension of its own, the .exe extension will
522 -- not be added by DriverPipeline.exeFileName. See #2248
523 name_exe = fmap (<.> "exe") name
528 case outputFile dflags of
530 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
532 -- -----------------------------------------------------------------------------
535 -- ToDo: think about relative vs. absolute file paths. And what
536 -- happens when the current directory changes.
538 -- | Sets the targets for this session. Each target may be a module name
539 -- or a filename. The targets correspond to the set of root modules for
540 -- the program\/library. Unloading the current program is achieved by
541 -- setting the current set of targets to be empty, followed by 'load'.
542 setTargets :: GhcMonad m => [Target] -> m ()
543 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
545 -- | Returns the current set of targets
546 getTargets :: GhcMonad m => m [Target]
547 getTargets = withSession (return . hsc_targets)
549 -- | Add another target.
550 addTarget :: GhcMonad m => Target -> m ()
552 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
555 removeTarget :: GhcMonad m => TargetId -> m ()
556 removeTarget target_id
557 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
559 filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
561 -- | Attempts to guess what Target a string refers to. This function
562 -- implements the @--make@/GHCi command-line syntax for filenames:
564 -- - if the string looks like a Haskell source filename, then interpret it
567 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
570 -- - otherwise interpret the string as a module name
572 guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
573 guessTarget str (Just phase)
574 = return (Target (TargetFile str (Just phase)) True Nothing)
575 guessTarget str Nothing
576 | isHaskellSrcFilename file
577 = return (target (TargetFile file Nothing))
579 = do exists <- liftIO $ doesFileExist hs_file
581 then return (target (TargetFile hs_file Nothing))
583 exists <- liftIO $ doesFileExist lhs_file
585 then return (target (TargetFile lhs_file Nothing))
587 if looksLikeModuleName file
588 then return (target (TargetModule (mkModuleName file)))
591 (ProgramError (showSDoc $
592 text "target" <+> quotes (text file) <+>
593 text "is not a module name or a source file"))
596 | '*':rest <- str = (rest, False)
597 | otherwise = (str, True)
599 hs_file = file <.> "hs"
600 lhs_file = file <.> "lhs"
602 target tid = Target tid obj_allowed Nothing
604 -- -----------------------------------------------------------------------------
605 -- Extending the program scope
607 extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
608 extendGlobalRdrScope rdrElts
609 = modifySession $ \hscEnv ->
610 let global_rdr = hsc_global_rdr_env hscEnv
611 in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
613 setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
614 setGlobalRdrScope rdrElts
615 = modifySession $ \hscEnv ->
616 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
618 extendGlobalTypeScope :: GhcMonad m => [Id] -> m ()
619 extendGlobalTypeScope ids
620 = modifySession $ \hscEnv ->
621 let global_type = hsc_global_type_env hscEnv
622 in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
624 setGlobalTypeScope :: GhcMonad m => [Id] -> m ()
625 setGlobalTypeScope ids
626 = modifySession $ \hscEnv ->
627 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
629 -- -----------------------------------------------------------------------------
630 -- Parsing Haddock comments
632 parseHaddockComment :: String -> Either String (HsDoc RdrName)
633 parseHaddockComment string =
634 case parseHaddockParagraphs (tokenise string) of
638 -- -----------------------------------------------------------------------------
639 -- Loading the program
641 -- | Perform a dependency analysis starting from the current targets
642 -- and update the session with the new module graph.
643 depanal :: GhcMonad m =>
644 [ModuleName] -- ^ excluded modules
645 -> Bool -- ^ allow duplicate roots
647 depanal excluded_mods allow_dup_roots = do
648 hsc_env <- getSession
650 dflags = hsc_dflags hsc_env
651 targets = hsc_targets hsc_env
652 old_graph = hsc_mod_graph hsc_env
654 liftIO $ showPass dflags "Chasing dependencies"
655 liftIO $ debugTraceMsg dflags 2 (hcat [
656 text "Chasing modules from: ",
657 hcat (punctuate comma (map pprTarget targets))])
659 mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
660 modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
665 | LoadUpTo ModuleName
666 | LoadDependenciesOf ModuleName
668 -- | Try to load the program. Calls 'loadWithLogger' with the default
669 -- compiler that just immediately logs all warnings and errors.
671 -- This function may throw a 'SourceError' if errors are encountered before
672 -- the actual compilation starts (e.g., during dependency analysis).
674 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
676 mod_graph <- depanal [] False
677 load2 how_much mod_graph
679 -- | A function called to log warnings and errors.
680 type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
682 defaultWarnErrLogger :: WarnErrLogger
683 defaultWarnErrLogger Nothing = printWarnings
684 defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
686 -- | Try to load the program. If a Module is supplied, then just
687 -- attempt to load up to this target. If no Module is supplied,
688 -- then try to load all targets.
690 -- The first argument is a function that is called after compiling each
691 -- module to print wanrings and errors.
693 -- While compiling a module, all 'SourceError's are caught and passed to the
694 -- logger, however, this function may still throw a 'SourceError' if
695 -- dependency analysis failed (e.g., due to a parse error).
697 loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
698 loadWithLogger logger how_much = do
699 -- Dependency analysis first. Note that this fixes the module graph:
700 -- even if we don't get a fully successful upsweep, the full module
701 -- graph is still retained in the Session. We can tell which modules
702 -- were successfully loaded by inspecting the Session's HPT.
703 withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult =
707 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
709 load2 how_much mod_graph = do
711 hsc_env <- getSession
713 let hpt1 = hsc_HPT hsc_env
714 let dflags = hsc_dflags hsc_env
716 -- The "bad" boot modules are the ones for which we have
717 -- B.hs-boot in the module graph, but no B.hs
718 -- The downsweep should have ensured this does not happen
720 let all_home_mods = [ms_mod_name s
721 | s <- mod_graph, not (isBootSummary s)]
722 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
723 not (ms_mod_name s `elem` all_home_mods)]
724 ASSERT( null bad_boot_mods ) return ()
726 -- check that the module given in HowMuch actually exists, otherwise
727 -- topSortModuleGraph will bomb later.
728 let checkHowMuch (LoadUpTo m) = checkMod m
729 checkHowMuch (LoadDependenciesOf m) = checkMod m
733 | m `elem` all_home_mods = and_then
735 liftIO $ errorMsg dflags (text "no such module:" <+>
739 checkHowMuch how_much $ do
741 -- mg2_with_srcimps drops the hi-boot nodes, returning a
742 -- graph with cycles. Among other things, it is used for
743 -- backing out partially complete cycles following a failed
744 -- upsweep, and for removing from hpt all the modules
745 -- not in strict downwards closure, during calls to compile.
746 let mg2_with_srcimps :: [SCC ModSummary]
747 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
749 -- If we can determine that any of the {-# SOURCE #-} imports
750 -- are definitely unnecessary, then emit a warning.
751 warnUnnecessarySourceImports mg2_with_srcimps
754 -- check the stability property for each module.
755 stable_mods@(stable_obj,stable_bco)
756 = checkStability hpt1 mg2_with_srcimps all_home_mods
758 -- prune bits of the HPT which are definitely redundant now,
760 pruned_hpt = pruneHomePackageTable hpt1
761 (flattenSCCs mg2_with_srcimps)
764 liftIO $ evaluate pruned_hpt
766 -- before we unload anything, make sure we don't leave an old
767 -- interactive context around pointing to dead bindings. Also,
768 -- write the pruned HPT to allow the old HPT to be GC'd.
769 modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
770 hsc_HPT = pruned_hpt }
772 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
773 text "Stable BCO:" <+> ppr stable_bco)
775 -- Unload any modules which are going to be re-linked this time around.
776 let stable_linkables = [ linkable
777 | m <- stable_obj++stable_bco,
778 Just hmi <- [lookupUFM pruned_hpt m],
779 Just linkable <- [hm_linkable hmi] ]
780 liftIO $ unload hsc_env stable_linkables
782 -- We could at this point detect cycles which aren't broken by
783 -- a source-import, and complain immediately, but it seems better
784 -- to let upsweep_mods do this, so at least some useful work gets
785 -- done before the upsweep is abandoned.
786 --hPutStrLn stderr "after tsort:\n"
787 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
789 -- Now do the upsweep, calling compile for each module in
790 -- turn. Final result is version 3 of everything.
792 -- Topologically sort the module graph, this time including hi-boot
793 -- nodes, and possibly just including the portion of the graph
794 -- reachable from the module specified in the 2nd argument to load.
795 -- This graph should be cycle-free.
796 -- If we're restricting the upsweep to a portion of the graph, we
797 -- also want to retain everything that is still stable.
798 let full_mg :: [SCC ModSummary]
799 full_mg = topSortModuleGraph False mod_graph Nothing
801 maybe_top_mod = case how_much of
803 LoadDependenciesOf m -> Just m
806 partial_mg0 :: [SCC ModSummary]
807 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
809 -- LoadDependenciesOf m: we want the upsweep to stop just
810 -- short of the specified module (unless the specified module
813 | LoadDependenciesOf _mod <- how_much
814 = ASSERT( case last partial_mg0 of
815 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
816 List.init partial_mg0
822 | AcyclicSCC ms <- full_mg,
823 ms_mod_name ms `elem` stable_obj++stable_bco,
824 ms_mod_name ms `notElem` [ ms_mod_name ms' |
825 AcyclicSCC ms' <- partial_mg ] ]
827 mg = stable_mg ++ partial_mg
829 -- clean up between compilations
830 let cleanup = cleanTempFilesExcept dflags
831 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
833 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
835 (upsweep_ok, hsc_env1, modsUpswept)
836 <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
837 pruned_hpt stable_mods cleanup mg
839 -- Make modsDone be the summaries for each home module now
840 -- available; this should equal the domain of hpt3.
841 -- Get in in a roughly top .. bottom order (hence reverse).
843 let modsDone = reverse modsUpswept
845 -- Try and do linking in some form, depending on whether the
846 -- upsweep was completely or only partially successful.
848 if succeeded upsweep_ok
851 -- Easy; just relink it all.
852 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
854 -- Clean up after ourselves
855 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
857 -- Issue a warning for the confusing case where the user
858 -- said '-o foo' but we're not going to do any linking.
859 -- We attempt linking if either (a) one of the modules is
860 -- called Main, or (b) the user said -no-hs-main, indicating
861 -- that main() is going to come from somewhere else.
863 let ofile = outputFile dflags
864 let no_hs_main = dopt Opt_NoHsMain dflags
866 main_mod = mainModIs dflags
867 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
868 do_linking = a_root_is_Main || no_hs_main
870 when (ghcLink dflags == LinkBinary
871 && isJust ofile && not do_linking) $
872 liftIO $ debugTraceMsg dflags 1 $
873 text ("Warning: output was redirected with -o, " ++
874 "but no output will be generated\n" ++
875 "because there is no " ++
876 moduleNameString (moduleName main_mod) ++ " module.")
878 -- link everything together
879 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
881 loadFinish Succeeded linkresult hsc_env1
884 -- Tricky. We need to back out the effects of compiling any
885 -- half-done cycles, both so as to clean up the top level envs
886 -- and to avoid telling the interactive linker to link them.
887 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
890 = map ms_mod modsDone
891 let mods_to_zap_names
892 = findPartiallyCompletedCycles modsDone_names
895 = filter ((`notElem` mods_to_zap_names).ms_mod)
898 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
901 -- Clean up after ourselves
902 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
904 -- there should be no Nothings where linkables should be, now
905 ASSERT(all (isJust.hm_linkable)
906 (eltsUFM (hsc_HPT hsc_env))) do
908 -- Link everything together
909 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
911 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
912 loadFinish Failed linkresult hsc_env4
914 -- Finish up after a load.
916 -- If the link failed, unload everything and return.
917 loadFinish :: GhcMonad m =>
918 SuccessFlag -> SuccessFlag -> HscEnv
920 loadFinish _all_ok Failed hsc_env
921 = do liftIO $ unload hsc_env []
922 modifySession $ \_ -> discardProg hsc_env
925 -- Empty the interactive context and set the module context to the topmost
926 -- newly loaded module, or the Prelude if none were loaded.
927 loadFinish all_ok Succeeded hsc_env
928 = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
932 -- Forget the current program, but retain the persistent info in HscEnv
933 discardProg :: HscEnv -> HscEnv
935 = hsc_env { hsc_mod_graph = emptyMG,
936 hsc_IC = emptyInteractiveContext,
937 hsc_HPT = emptyHomePackageTable }
939 -- used to fish out the preprocess output files for the purposes of
940 -- cleaning up. The preprocessed file *might* be the same as the
941 -- source file, but that doesn't do any harm.
942 ppFilesFromSummaries :: [ModSummary] -> [FilePath]
943 ppFilesFromSummaries summaries = map ms_hspp_file summaries
945 -- -----------------------------------------------------------------------------
947 class ParsedMod m where
948 modSummary :: m -> ModSummary
949 parsedSource :: m -> ParsedSource
951 class ParsedMod m => TypecheckedMod m where
952 renamedSource :: m -> Maybe RenamedSource
953 typecheckedSource :: m -> TypecheckedSource
954 moduleInfo :: m -> ModuleInfo
955 tm_internals :: m -> (TcGblEnv, ModDetails)
956 -- ToDo: improvements that could be made here:
957 -- if the module succeeded renaming but not typechecking,
958 -- we can still get back the GlobalRdrEnv and exports, so
959 -- perhaps the ModuleInfo should be split up into separate
962 class TypecheckedMod m => DesugaredMod m where
963 coreModule :: m -> ModGuts
965 -- | The result of successful parsing.
967 ParsedModule { pm_mod_summary :: ModSummary
968 , pm_parsed_source :: ParsedSource }
970 instance ParsedMod ParsedModule where
971 modSummary m = pm_mod_summary m
972 parsedSource m = pm_parsed_source m
974 -- | The result of successful typechecking. It also contains the parser
976 data TypecheckedModule =
977 TypecheckedModule { tm_parsed_module :: ParsedModule
978 , tm_renamed_source :: Maybe RenamedSource
979 , tm_typechecked_source :: TypecheckedSource
980 , tm_checked_module_info :: ModuleInfo
981 , tm_internals_ :: (TcGblEnv, ModDetails)
984 instance ParsedMod TypecheckedModule where
985 modSummary m = modSummary (tm_parsed_module m)
986 parsedSource m = parsedSource (tm_parsed_module m)
988 instance TypecheckedMod TypecheckedModule where
989 renamedSource m = tm_renamed_source m
990 typecheckedSource m = tm_typechecked_source m
991 moduleInfo m = tm_checked_module_info m
992 tm_internals m = tm_internals_ m
994 -- | The result of successful desugaring (i.e., translation to core). Also
995 -- contains all the information of a typechecked module.
996 data DesugaredModule =
997 DesugaredModule { dm_typechecked_module :: TypecheckedModule
998 , dm_core_module :: ModGuts
1001 instance ParsedMod DesugaredModule where
1002 modSummary m = modSummary (dm_typechecked_module m)
1003 parsedSource m = parsedSource (dm_typechecked_module m)
1005 instance TypecheckedMod DesugaredModule where
1006 renamedSource m = renamedSource (dm_typechecked_module m)
1007 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
1008 moduleInfo m = moduleInfo (dm_typechecked_module m)
1009 tm_internals m = tm_internals_ (dm_typechecked_module m)
1011 instance DesugaredMod DesugaredModule where
1012 coreModule m = dm_core_module m
1014 type ParsedSource = Located (HsModule RdrName)
1015 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
1016 Maybe (HsDoc Name), HaddockModInfo Name)
1017 type TypecheckedSource = LHsBinds Id
1020 -- - things that aren't in the output of the typechecker right now:
1021 -- - the export list
1023 -- - type signatures
1024 -- - type/data/newtype declarations
1025 -- - class declarations
1027 -- - extra things in the typechecker's output:
1028 -- - default methods are turned into top-level decls.
1029 -- - dictionary bindings
1031 -- | Return the 'ModSummary' of a module with the given name.
1033 -- The module must be part of the module graph (see 'hsc_mod_graph' and
1034 -- 'ModuleGraph'). If this is not the case, this function will throw a
1037 -- This function ignores boot modules and requires that there is only one
1038 -- non-boot module with the given name.
1039 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
1040 getModSummary mod = do
1041 mg <- liftM hsc_mod_graph getSession
1042 case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
1043 [] -> throw $ mkApiErr (text "Module not part of module graph")
1045 multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
1047 -- | Parse a module.
1049 -- Throws a 'SourceError' on parse error.
1050 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
1052 rdr_module <- withTempSession
1053 (\e -> e { hsc_dflags = ms_hspp_opts ms }) $
1055 return (ParsedModule ms rdr_module)
1057 -- | Typecheck and rename a parsed module.
1059 -- Throws a 'SourceError' if either fails.
1060 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
1061 typecheckModule pmod = do
1062 let ms = modSummary pmod
1063 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1064 (tc_gbl_env, rn_info)
1065 <- hscTypecheckRename ms (parsedSource pmod)
1066 details <- makeSimpleDetails tc_gbl_env
1069 tm_internals_ = (tc_gbl_env, details),
1070 tm_parsed_module = pmod,
1071 tm_renamed_source = rn_info,
1072 tm_typechecked_source = tcg_binds tc_gbl_env,
1073 tm_checked_module_info =
1075 minf_type_env = md_types details,
1076 minf_exports = availsToNameSet $ md_exports details,
1077 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
1078 minf_instances = md_insts details
1080 ,minf_modBreaks = emptyModBreaks
1084 -- | Desugar a typechecked module.
1085 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
1086 desugarModule tcm = do
1087 let ms = modSummary tcm
1088 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1089 let (tcg, _) = tm_internals tcm
1090 guts <- hscDesugar ms tcg
1093 dm_typechecked_module = tcm,
1094 dm_core_module = guts
1097 -- | Load a module. Input doesn't need to be desugared.
1099 -- XXX: Describe usage.
1100 loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
1102 let ms = modSummary tcm
1103 let mod = ms_mod_name ms
1104 let (tcg, _details) = tm_internals tcm
1106 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1108 let compilerBackend comp env ms' _ _mb_old_iface _ =
1109 withTempSession (\_ -> env) $
1110 hscBackend comp tcg ms'
1112 hsc_env <- getSession
1114 <- compile' (compilerBackend hscNothingCompiler
1115 ,compilerBackend hscInteractiveCompiler
1116 ,compilerBackend hscBatchCompiler)
1117 hsc_env ms 1 1 Nothing Nothing
1118 -- compile' shouldn't change the environment
1119 return $ addToUFM (hsc_HPT hsc_env) mod mod_info
1120 modifySession $ \e -> e{ hsc_HPT = hpt_new }
1123 -- | This is the way to get access to the Core bindings corresponding
1124 -- to a module. 'compileToCore' parses, typechecks, and
1125 -- desugars the module, then returns the resulting Core module (consisting of
1126 -- the module name, type declarations, and function declarations) if
1128 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1129 compileToCoreModule = compileCore False
1131 -- | Like compileToCoreModule, but invokes the simplifier, so
1132 -- as to return simplified and tidied Core.
1133 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1134 compileToCoreSimplified = compileCore True
1136 -- | Provided for backwards-compatibility: compileToCore returns just the Core
1137 -- bindings, but for most purposes, you probably want to call
1138 -- compileToCoreModule.
1139 compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
1140 compileToCore fn = do
1141 mod <- compileToCoreModule session fn
1142 return $ cm_binds mod
1144 -- | Takes a CoreModule and compiles the bindings therein
1145 -- to object code. The first argument is a bool flag indicating
1146 -- whether to run the simplifier.
1147 -- The resulting .o, .hi, and executable files, if any, are stored in the
1148 -- current directory, and named according to the module name.
1149 -- This has only so far been tested with a single self-contained module.
1150 compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
1151 compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
1152 dflags <- getSessionDynFlags
1153 currentTime <- liftIO $ getClockTime
1154 cwd <- liftIO $ getCurrentDirectory
1155 modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
1156 ((moduleNameSlashes . moduleName) mName)
1158 let modSummary = ModSummary { ms_mod = mName,
1159 ms_hsc_src = ExtCoreFile,
1160 ms_location = modLocation,
1161 -- By setting the object file timestamp to Nothing,
1162 -- we always force recompilation, which is what we
1163 -- want. (Thus it doesn't matter what the timestamp
1164 -- for the (nonexistent) source file is.)
1165 ms_hs_date = currentTime,
1166 ms_obj_date = Nothing,
1167 -- Only handling the single-module case for now, so no imports.
1172 ms_hspp_opts = dflags,
1173 ms_hspp_buf = Nothing
1176 let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
1177 | otherwise = return mod_guts
1178 guts <- maybe_simplify (mkModGuts cm)
1179 (iface, changed, _details, cgguts)
1180 <- hscNormalIface guts Nothing
1181 hscWriteIface iface changed modSummary
1182 hscGenHardCode cgguts modSummary
1185 -- Makes a "vanilla" ModGuts.
1186 mkModGuts :: CoreModule -> ModGuts
1187 mkModGuts coreModule = ModGuts {
1188 mg_module = cm_module coreModule,
1191 mg_deps = noDependencies,
1192 mg_dir_imps = emptyModuleEnv,
1193 mg_used_names = emptyNameSet,
1194 mg_rdr_env = emptyGlobalRdrEnv,
1195 mg_fix_env = emptyFixityEnv,
1196 mg_types = emptyTypeEnv,
1200 mg_binds = cm_binds coreModule,
1201 mg_foreign = NoStubs,
1202 mg_warns = NoWarnings,
1204 mg_hpc_info = emptyHpcInfo False,
1205 mg_modBreaks = emptyModBreaks,
1206 mg_vect_info = noVectInfo,
1207 mg_inst_env = emptyInstEnv,
1208 mg_fam_inst_env = emptyFamInstEnv
1211 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1212 compileCore simplify fn = do
1213 -- First, set the target to the desired filename
1214 target <- guessTarget fn Nothing
1217 -- Then find dependencies
1218 modGraph <- depanal [] True
1219 case find ((== fn) . msHsFilePath) modGraph of
1220 Just modSummary -> do
1221 -- Now we have the module name;
1222 -- parse, typecheck and desugar the module
1223 mod_guts <- coreModule `fmap`
1224 -- TODO: space leaky: call hsc* directly?
1225 (desugarModule =<< typecheckModule =<< parseModule modSummary)
1226 liftM gutsToCoreModule $
1229 -- If simplify is true: simplify (hscSimplify), then tidy
1231 hsc_env <- getSession
1232 simpl_guts <- hscSimplify mod_guts
1233 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1234 return $ Left tidy_guts
1236 return $ Right mod_guts
1238 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1239 module dependency graph"
1240 where -- two versions, based on whether we simplify (thus run tidyProgram,
1241 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1242 -- we just have a ModGuts.
1243 gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
1244 gutsToCoreModule (Left (cg, md)) = CoreModule {
1245 cm_module = cg_module cg, cm_types = md_types md,
1246 cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
1248 gutsToCoreModule (Right mg) = CoreModule {
1249 cm_module = mg_module mg, cm_types = mg_types mg,
1250 cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
1253 -- ---------------------------------------------------------------------------
1256 unload :: HscEnv -> [Linkable] -> IO ()
1257 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
1258 = case ghcLink (hsc_dflags hsc_env) of
1260 LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
1262 LinkInMemory -> panic "unload: no interpreter"
1263 -- urgh. avoid warnings:
1264 hsc_env stable_linkables
1268 -- -----------------------------------------------------------------------------
1272 Stability tells us which modules definitely do not need to be recompiled.
1273 There are two main reasons for having stability:
1275 - avoid doing a complete upsweep of the module graph in GHCi when
1276 modules near the bottom of the tree have not changed.
1278 - to tell GHCi when it can load object code: we can only load object code
1279 for a module when we also load object code fo all of the imports of the
1280 module. So we need to know that we will definitely not be recompiling
1281 any of these modules, and we can use the object code.
1283 The stability check is as follows. Both stableObject and
1284 stableBCO are used during the upsweep phase later.
1287 stable m = stableObject m || stableBCO m
1290 all stableObject (imports m)
1291 && old linkable does not exist, or is == on-disk .o
1292 && date(on-disk .o) > date(.hs)
1295 all stable (imports m)
1296 && date(BCO) > date(.hs)
1299 These properties embody the following ideas:
1301 - if a module is stable, then:
1303 - if it has been compiled in a previous pass (present in HPT)
1304 then it does not need to be compiled or re-linked.
1306 - if it has not been compiled in a previous pass,
1307 then we only need to read its .hi file from disk and
1308 link it to produce a 'ModDetails'.
1310 - if a modules is not stable, we will definitely be at least
1311 re-linking, and possibly re-compiling it during the 'upsweep'.
1312 All non-stable modules can (and should) therefore be unlinked
1313 before the 'upsweep'.
1315 - Note that objects are only considered stable if they only depend
1316 on other objects. We can't link object code against byte code.
1320 :: HomePackageTable -- HPT from last compilation
1321 -> [SCC ModSummary] -- current module graph (cyclic)
1322 -> [ModuleName] -- all home modules
1323 -> ([ModuleName], -- stableObject
1324 [ModuleName]) -- stableBCO
1326 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
1328 checkSCC (stable_obj, stable_bco) scc0
1329 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
1330 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
1331 | otherwise = (stable_obj, stable_bco)
1333 scc = flattenSCC scc0
1334 scc_mods = map ms_mod_name scc
1335 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
1337 scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
1338 -- all imports outside the current SCC, but in the home pkg
1340 stable_obj_imps = map (`elem` stable_obj) scc_allimps
1341 stable_bco_imps = map (`elem` stable_bco) scc_allimps
1345 && all object_ok scc
1348 and (zipWith (||) stable_obj_imps stable_bco_imps)
1352 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
1356 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
1357 Just hmi | Just l <- hm_linkable hmi
1358 -> isObjectLinkable l && t == linkableTime l
1360 -- why '>=' rather than '>' above? If the filesystem stores
1361 -- times to the nearset second, we may occasionally find that
1362 -- the object & source have the same modification time,
1363 -- especially if the source was automatically generated
1364 -- and compiled. Using >= is slightly unsafe, but it matches
1365 -- make's behaviour.
1368 = case lookupUFM hpt (ms_mod_name ms) of
1369 Just hmi | Just l <- hm_linkable hmi ->
1370 not (isObjectLinkable l) &&
1371 linkableTime l >= ms_hs_date ms
1374 -- -----------------------------------------------------------------------------
1376 -- | Prune the HomePackageTable
1378 -- Before doing an upsweep, we can throw away:
1380 -- - For non-stable modules:
1381 -- - all ModDetails, all linked code
1382 -- - all unlinked code that is out of date with respect to
1385 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
1386 -- space at the end of the upsweep, because the topmost ModDetails of the
1387 -- old HPT holds on to the entire type environment from the previous
1390 pruneHomePackageTable
1393 -> ([ModuleName],[ModuleName])
1396 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
1399 | is_stable modl = hmi'
1400 | otherwise = hmi'{ hm_details = emptyModDetails }
1402 modl = moduleName (mi_module (hm_iface hmi))
1403 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1404 = hmi{ hm_linkable = Nothing }
1407 where ms = expectJust "prune" (lookupUFM ms_map modl)
1409 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1411 is_stable m = m `elem` stable_obj || m `elem` stable_bco
1413 -- -----------------------------------------------------------------------------
1415 -- Return (names of) all those in modsDone who are part of a cycle
1416 -- as defined by theGraph.
1417 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1418 findPartiallyCompletedCycles modsDone theGraph
1422 chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
1423 chew ((CyclicSCC vs):rest)
1424 = let names_in_this_cycle = nub (map ms_mod vs)
1426 = nub ([done | done <- modsDone,
1427 done `elem` names_in_this_cycle])
1428 chewed_rest = chew rest
1430 if notNull mods_in_this_cycle
1431 && length mods_in_this_cycle < length names_in_this_cycle
1432 then mods_in_this_cycle ++ chewed_rest
1435 -- -----------------------------------------------------------------------------
1439 -- This is where we compile each module in the module graph, in a pass
1440 -- from the bottom to the top of the graph.
1442 -- There better had not be any cyclic groups here -- we check for them.
1446 HscEnv -- ^ Includes initially-empty HPT
1447 -> HomePackageTable -- ^ HPT from last time round (pruned)
1448 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1449 -> IO () -- ^ How to clean up unwanted tmp files
1450 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1452 HscEnv, -- With an updated HPT
1453 [ModSummary]) -- Mods which succeeded
1455 upsweep hsc_env old_hpt stable_mods cleanup sccs = do
1456 (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
1457 return (res, hsc_env, reverse done)
1460 upsweep' hsc_env _old_hpt done
1462 = return (Succeeded, hsc_env, done)
1464 upsweep' hsc_env _old_hpt done
1465 (CyclicSCC ms:_) _ _
1466 = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1467 return (Failed, hsc_env, done)
1469 upsweep' hsc_env old_hpt done
1470 (AcyclicSCC mod:mods) mod_index nmods
1471 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1472 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1473 -- (moduleEnvElts (hsc_HPT hsc_env)))
1474 let logger = reportModuleCompilationResult (hsc_callbacks hsc_env)
1477 <- handleSourceError
1478 (\err -> do logger mod (Just err); return Nothing) $ do
1479 mod_info <- upsweep_mod hsc_env old_hpt stable_mods
1481 logger mod Nothing -- log warnings
1482 return (Just mod_info)
1484 liftIO cleanup -- Remove unwanted tmp files between compilations
1487 Nothing -> return (Failed, hsc_env, done)
1489 let this_mod = ms_mod_name mod
1491 -- Add new info to hsc_env
1492 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1493 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1495 -- Space-saving: delete the old HPT entry
1496 -- for mod BUT if mod is a hs-boot
1497 -- node, don't delete it. For the
1498 -- interface, the HPT entry is probaby for the
1499 -- main Haskell source file. Deleting it
1500 -- would force the real module to be recompiled
1502 old_hpt1 | isBootSummary mod = old_hpt
1503 | otherwise = delFromUFM old_hpt this_mod
1507 -- fixup our HomePackageTable after we've finished compiling
1508 -- a mutually-recursive loop. See reTypecheckLoop, below.
1509 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
1511 upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
1513 -- | Compile a single module. Always produce a Linkable for it if
1514 -- successful. If no compilation happened, return the old Linkable.
1515 upsweep_mod :: GhcMonad m =>
1518 -> ([ModuleName],[ModuleName])
1520 -> Int -- index of module
1521 -> Int -- total number of modules
1524 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1526 this_mod_name = ms_mod_name summary
1527 this_mod = ms_mod summary
1528 mb_obj_date = ms_obj_date summary
1529 obj_fn = ml_obj_file (ms_location summary)
1530 hs_date = ms_hs_date summary
1532 is_stable_obj = this_mod_name `elem` stable_obj
1533 is_stable_bco = this_mod_name `elem` stable_bco
1535 old_hmi = lookupUFM old_hpt this_mod_name
1537 -- We're using the dflags for this module now, obtained by
1538 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1539 dflags = ms_hspp_opts summary
1540 prevailing_target = hscTarget (hsc_dflags hsc_env)
1541 local_target = hscTarget dflags
1543 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
1544 -- we don't do anything dodgy: these should only work to change
1545 -- from -fvia-C to -fasm and vice-versa, otherwise we could
1546 -- end up trying to link object code to byte code.
1547 target = if prevailing_target /= local_target
1548 && (not (isObjectTarget prevailing_target)
1549 || not (isObjectTarget local_target))
1550 then prevailing_target
1553 -- store the corrected hscTarget into the summary
1554 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1556 -- The old interface is ok if
1557 -- a) we're compiling a source file, and the old HPT
1558 -- entry is for a source file
1559 -- b) we're compiling a hs-boot file
1560 -- Case (b) allows an hs-boot file to get the interface of its
1561 -- real source file on the second iteration of the compilation
1562 -- manager, but that does no harm. Otherwise the hs-boot file
1563 -- will always be recompiled
1568 Just hm_info | isBootSummary summary -> Just iface
1569 | not (mi_boot iface) -> Just iface
1570 | otherwise -> Nothing
1572 iface = hm_iface hm_info
1574 compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo
1575 compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
1577 compile_it_discard_iface :: GhcMonad m =>
1578 Maybe Linkable -> m HomeModInfo
1579 compile_it_discard_iface
1580 = compile hsc_env summary' mod_index nmods Nothing
1582 -- With the HscNothing target we create empty linkables to avoid
1583 -- recompilation. We have to detect these to recompile anyway if
1584 -- the target changed since the last compile.
1586 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
1587 null (linkableUnlinked l)
1589 -- we have no linkable, so it cannot be fake
1592 implies False _ = True
1598 -- Regardless of whether we're generating object code or
1599 -- byte code, we can always use an existing object file
1600 -- if it is *stable* (see checkStability).
1601 | is_stable_obj, Just hmi <- old_hmi -> do
1602 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1603 (text "skipping stable obj mod:" <+> ppr this_mod_name)
1605 -- object is stable, and we have an entry in the
1606 -- old HPT: nothing to do
1608 | is_stable_obj, isNothing old_hmi -> do
1609 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1610 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
1611 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1612 (expectJust "upsweep1" mb_obj_date)
1613 compile_it (Just linkable)
1614 -- object is stable, but we need to load the interface
1615 -- off disk to make a HMI.
1617 | not (isObjectTarget target), is_stable_bco,
1618 (target /= HscNothing) `implies` not is_fake_linkable ->
1619 ASSERT(isJust old_hmi) -- must be in the old_hpt
1620 let Just hmi = old_hmi in do
1621 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1622 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
1624 -- BCO is stable: nothing to do
1626 | not (isObjectTarget target),
1627 Just hmi <- old_hmi,
1628 Just l <- hm_linkable hmi,
1629 not (isObjectLinkable l),
1630 (target /= HscNothing) `implies` not is_fake_linkable,
1631 linkableTime l >= ms_hs_date summary -> do
1632 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1633 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
1635 -- we have an old BCO that is up to date with respect
1636 -- to the source: do a recompilation check as normal.
1638 -- When generating object code, if there's an up-to-date
1639 -- object file on the disk, then we can use it.
1640 -- However, if the object file is new (compared to any
1641 -- linkable we had from a previous compilation), then we
1642 -- must discard any in-memory interface, because this
1643 -- means the user has compiled the source file
1644 -- separately and generated a new interface, that we must
1645 -- read from the disk.
1647 | isObjectTarget target,
1648 Just obj_date <- mb_obj_date,
1649 obj_date >= hs_date -> do
1652 | Just l <- hm_linkable hmi,
1653 isObjectLinkable l && linkableTime l == obj_date -> do
1654 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1655 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
1658 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1659 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
1660 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1661 compile_it_discard_iface (Just linkable)
1664 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1665 (text "compiling mod:" <+> ppr this_mod_name)
1670 -- Filter modules in the HPT
1671 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1672 retainInTopLevelEnvs keep_these hpt
1673 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1675 , let mb_mod_info = lookupUFM hpt mod
1676 , isJust mb_mod_info ]
1678 -- ---------------------------------------------------------------------------
1679 -- Typecheck module loops
1682 See bug #930. This code fixes a long-standing bug in --make. The
1683 problem is that when compiling the modules *inside* a loop, a data
1684 type that is only defined at the top of the loop looks opaque; but
1685 after the loop is done, the structure of the data type becomes
1688 The difficulty is then that two different bits of code have
1689 different notions of what the data type looks like.
1691 The idea is that after we compile a module which also has an .hs-boot
1692 file, we re-generate the ModDetails for each of the modules that
1693 depends on the .hs-boot file, so that everyone points to the proper
1694 TyCons, Ids etc. defined by the real module, not the boot module.
1695 Fortunately re-generating a ModDetails from a ModIface is easy: the
1696 function TcIface.typecheckIface does exactly that.
1698 Picking the modules to re-typecheck is slightly tricky. Starting from
1699 the module graph consisting of the modules that have already been
1700 compiled, we reverse the edges (so they point from the imported module
1701 to the importing module), and depth-first-search from the .hs-boot
1702 node. This gives us all the modules that depend transitively on the
1703 .hs-boot module, and those are exactly the modules that we need to
1706 Following this fix, GHC can compile itself with --make -O2.
1709 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1710 reTypecheckLoop hsc_env ms graph
1711 | not (isBootSummary ms) &&
1712 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
1714 let mss = reachableBackwards (ms_mod_name ms) graph
1715 non_boot = filter (not.isBootSummary) mss
1716 debugTraceMsg (hsc_dflags hsc_env) 2 $
1717 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
1718 typecheckLoop hsc_env (map ms_mod_name non_boot)
1722 this_mod = ms_mod ms
1724 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
1725 typecheckLoop hsc_env mods = do
1727 fixIO $ \new_hpt -> do
1728 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1729 mds <- initIfaceCheck new_hsc_env $
1730 mapM (typecheckIface . hm_iface) hmis
1731 let new_hpt = addListToUFM old_hpt
1732 (zip mods [ hmi{ hm_details = details }
1733 | (hmi,details) <- zip hmis mds ])
1735 return hsc_env{ hsc_HPT = new_hpt }
1737 old_hpt = hsc_HPT hsc_env
1738 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
1740 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1741 reachableBackwards mod summaries
1742 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
1743 where -- the rest just sets up the graph:
1744 (graph, lookup_node) = moduleGraphNodes False summaries
1745 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1747 -- ---------------------------------------------------------------------------
1748 -- Topological sort of the module graph
1750 type SummaryNode = (ModSummary, Int, [Int])
1754 -- ^ Drop hi-boot nodes? (see below)
1758 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1759 -- The resulting list of strongly-connected-components is in topologically
1760 -- sorted order, starting with the module(s) at the bottom of the
1761 -- dependency graph (ie compile them first) and ending with the ones at
1764 -- Drop hi-boot nodes (first boolean arg)?
1766 -- - @False@: treat the hi-boot summaries as nodes of the graph,
1767 -- so the graph must be acyclic
1769 -- - @True@: eliminate the hi-boot nodes, and instead pretend
1770 -- the a source-import of Foo is an import of Foo
1771 -- The resulting graph has no hi-boot nodes, but can be cyclic
1773 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
1774 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1776 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
1778 initial_graph = case mb_root_mod of
1781 -- restrict the graph to just those modules reachable from
1782 -- the specified module. We do this by building a graph with
1783 -- the full set of nodes, and determining the reachable set from
1784 -- the specified node.
1785 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
1786 | otherwise = ghcError (ProgramError "module does not exist")
1787 in graphFromEdgedVertices (seq root (reachableG graph root))
1789 summaryNodeKey :: SummaryNode -> Int
1790 summaryNodeKey (_, k, _) = k
1792 summaryNodeSummary :: SummaryNode -> ModSummary
1793 summaryNodeSummary (s, _, _) = s
1795 moduleGraphNodes :: Bool -> [ModSummary]
1796 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1797 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
1799 numbered_summaries = zip summaries [1..]
1801 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1802 lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
1804 lookup_key :: HscSource -> ModuleName -> Maybe Int
1805 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1807 node_map :: NodeMap SummaryNode
1808 node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
1809 | node@(s, _, _) <- nodes ]
1811 -- We use integers as the keys for the SCC algorithm
1812 nodes :: [SummaryNode]
1813 nodes = [ (s, key, out_keys)
1814 | (s, key) <- numbered_summaries
1815 -- Drop the hi-boot ones if told to do so
1816 , not (isBootSummary s && drop_hs_boot_nodes)
1817 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1818 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1819 (-- see [boot-edges] below
1820 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1822 else case lookup_key HsBootFile (ms_mod_name s) of
1826 -- [boot-edges] if this is a .hs and there is an equivalent
1827 -- .hs-boot, add a link from the former to the latter. This
1828 -- has the effect of detecting bogus cases where the .hs-boot
1829 -- depends on the .hs, by introducing a cycle. Additionally,
1830 -- it ensures that we will always process the .hs-boot before
1831 -- the .hs, and so the HomePackageTable will always have the
1832 -- most up to date information.
1834 -- Drop hs-boot nodes by using HsSrcFile as the key
1835 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1836 | otherwise = HsBootFile
1838 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1839 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1840 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1841 -- the IsBootInterface parameter True; else False
1844 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1845 type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
1847 msKey :: ModSummary -> NodeKey
1848 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1850 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1851 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1853 nodeMapElts :: NodeMap a -> [a]
1854 nodeMapElts = eltsFM
1856 -- | If there are {-# SOURCE #-} imports between strongly connected
1857 -- components in the topological sort, then those imports can
1858 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1859 -- were necessary, then the edge would be part of a cycle.
1860 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1861 warnUnnecessarySourceImports sccs =
1862 logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
1864 let mods_in_this_cycle = map ms_mod_name ms in
1865 [ warn i | m <- ms, i <- ms_home_srcimps m,
1866 unLoc i `notElem` mods_in_this_cycle ]
1868 warn :: Located ModuleName -> WarnMsg
1871 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1872 <+> quotes (ppr mod))
1874 -----------------------------------------------------------------------------
1875 -- Downsweep (dependency analysis)
1877 -- Chase downwards from the specified root set, returning summaries
1878 -- for all home modules encountered. Only follow source-import
1881 -- We pass in the previous collection of summaries, which is used as a
1882 -- cache to avoid recalculating a module summary if the source is
1885 -- The returned list of [ModSummary] nodes has one node for each home-package
1886 -- module, plus one for any hs-boot files. The imports of these nodes
1887 -- are all there, including the imports of non-home-package modules.
1889 downsweep :: GhcMonad m =>
1891 -> [ModSummary] -- Old summaries
1892 -> [ModuleName] -- Ignore dependencies on these; treat
1893 -- them as if they were package modules
1894 -> Bool -- True <=> allow multiple targets to have
1895 -- the same module name; this is
1896 -- very useful for ghc -M
1898 -- The elts of [ModSummary] all have distinct
1899 -- (Modules, IsBoot) identifiers, unless the Bool is true
1900 -- in which case there can be repeats
1901 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1902 = do -- catch error messages and return them
1903 --handleErrMsg -- should be covered by GhcMonad now
1904 -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1905 rootSummaries <- mapM getRootSummary roots
1906 let root_map = mkRootMap rootSummaries
1907 checkDuplicates root_map
1908 summs <- loop (concatMap msDeps rootSummaries) root_map
1911 roots = hsc_targets hsc_env
1913 old_summary_map :: NodeMap ModSummary
1914 old_summary_map = mkNodeMap old_summaries
1916 getRootSummary :: GhcMonad m => Target -> m ModSummary
1917 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1918 = do exists <- liftIO $ doesFileExist file
1920 then summariseFile hsc_env old_summaries file mb_phase
1921 obj_allowed maybe_buf
1922 else throwOneError $ mkPlainErrMsg noSrcSpan $
1923 text "can't find file:" <+> text file
1924 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1925 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1926 (L rootLoc modl) obj_allowed
1928 case maybe_summary of
1929 Nothing -> packageModErr modl
1932 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1934 -- In a root module, the filename is allowed to diverge from the module
1935 -- name, so we have to check that there aren't multiple root files
1936 -- defining the same module (otherwise the duplicates will be silently
1937 -- ignored, leading to confusing behaviour).
1938 checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m ()
1939 checkDuplicates root_map
1940 | allow_dup_roots = return ()
1941 | null dup_roots = return ()
1942 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1944 dup_roots :: [[ModSummary]] -- Each at least of length 2
1945 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1947 loop :: GhcMonad m =>
1948 [(Located ModuleName,IsBootInterface)]
1949 -- Work list: process these modules
1950 -> NodeMap [ModSummary]
1951 -- Visited set; the range is a list because
1952 -- the roots can have the same module names
1953 -- if allow_dup_roots is True
1955 -- The result includes the worklist, except
1956 -- for those mentioned in the visited set
1957 loop [] done = return (concat (nodeMapElts done))
1958 loop ((wanted_mod, is_boot) : ss) done
1959 | Just summs <- lookupFM done key
1960 = if isSingleton summs then
1963 do { liftIO $ multiRootsErr summs; return [] }
1965 = do mb_s <- summariseModule hsc_env old_summary_map
1966 is_boot wanted_mod True
1969 Nothing -> loop ss done
1970 Just s -> loop (msDeps s ++ ss) (addToFM done key [s])
1972 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1974 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1975 mkRootMap summaries = addListToFM_C (++) emptyFM
1976 [ (msKey s, [s]) | s <- summaries ]
1978 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1979 -- (msDeps s) returns the dependencies of the ModSummary s.
1980 -- A wrinkle is that for a {-# SOURCE #-} import we return
1981 -- *both* the hs-boot file
1982 -- *and* the source file
1983 -- as "dependencies". That ensures that the list of all relevant
1984 -- modules always contains B.hs if it contains B.hs-boot.
1985 -- Remember, this pass isn't doing the topological sort. It's
1986 -- just gathering the list of all relevant ModSummaries
1988 concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
1989 ++ [ (m,False) | m <- ms_home_imps s ]
1991 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
1992 home_imps imps = [ ideclName i | L _ i <- imps, isNothing (ideclPkgQual i) ]
1994 ms_home_allimps :: ModSummary -> [ModuleName]
1995 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
1997 ms_home_srcimps :: ModSummary -> [Located ModuleName]
1998 ms_home_srcimps = home_imps . ms_srcimps
2000 ms_home_imps :: ModSummary -> [Located ModuleName]
2001 ms_home_imps = home_imps . ms_imps
2003 -----------------------------------------------------------------------------
2004 -- Summarising modules
2006 -- We have two types of summarisation:
2008 -- * Summarise a file. This is used for the root module(s) passed to
2009 -- cmLoadModules. The file is read, and used to determine the root
2010 -- module name. The module name may differ from the filename.
2012 -- * Summarise a module. We are given a module name, and must provide
2013 -- a summary. The finder is used to locate the file in which the module
2019 -> [ModSummary] -- old summaries
2020 -> FilePath -- source file name
2021 -> Maybe Phase -- start phase
2022 -> Bool -- object code allowed?
2023 -> Maybe (StringBuffer,ClockTime)
2026 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
2027 -- we can use a cached summary if one is available and the
2028 -- source file hasn't changed, But we have to look up the summary
2029 -- by source file, rather than module name as we do in summarise.
2030 | Just old_summary <- findSummaryBySourceFile old_summaries file
2032 let location = ms_location old_summary
2034 -- return the cached summary if the source didn't change
2035 src_timestamp <- case maybe_buf of
2036 Just (_,t) -> return t
2037 Nothing -> liftIO $ getModificationTime file
2038 -- The file exists; we checked in getRootSummary above.
2039 -- If it gets removed subsequently, then this
2040 -- getModificationTime may fail, but that's the right
2043 if ms_hs_date old_summary == src_timestamp
2044 then do -- update the object-file timestamp
2046 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2047 || obj_allowed -- bug #1205
2048 then liftIO $ getObjTimestamp location False
2050 return old_summary{ ms_obj_date = obj_timestamp }
2058 let dflags = hsc_dflags hsc_env
2060 (dflags', hspp_fn, buf)
2061 <- preprocessFile hsc_env file mb_phase maybe_buf
2063 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
2065 -- Make a ModLocation for this file
2066 location <- liftIO $ mkHomeModLocation dflags mod_name file
2068 -- Tell the Finder cache where it is, so that subsequent calls
2069 -- to findModule will find it, even if it's not on any search path
2070 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
2072 src_timestamp <- case maybe_buf of
2073 Just (_,t) -> return t
2074 Nothing -> liftIO $ getModificationTime file
2075 -- getMofificationTime may fail
2077 -- when the user asks to load a source file by name, we only
2078 -- use an object file if -fobject-code is on. See #1205.
2080 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2081 || obj_allowed -- bug #1205
2082 then liftIO $ modificationTimeIfExists (ml_obj_file location)
2085 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
2086 ms_location = location,
2087 ms_hspp_file = hspp_fn,
2088 ms_hspp_opts = dflags',
2089 ms_hspp_buf = Just buf,
2090 ms_srcimps = srcimps, ms_imps = the_imps,
2091 ms_hs_date = src_timestamp,
2092 ms_obj_date = obj_timestamp })
2094 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
2095 findSummaryBySourceFile summaries file
2096 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
2097 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
2101 -- Summarise a module, and pick up source and timestamp.
2105 -> NodeMap ModSummary -- Map of old summaries
2106 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
2107 -> Located ModuleName -- Imported module to be summarised
2108 -> Bool -- object code allowed?
2109 -> Maybe (StringBuffer, ClockTime)
2110 -> [ModuleName] -- Modules to exclude
2111 -> m (Maybe ModSummary) -- Its new summary
2113 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
2114 obj_allowed maybe_buf excl_mods
2115 | wanted_mod `elem` excl_mods
2118 | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
2119 = do -- Find its new timestamp; all the
2120 -- ModSummaries in the old map have valid ml_hs_files
2121 let location = ms_location old_summary
2122 src_fn = expectJust "summariseModule" (ml_hs_file location)
2124 -- check the modification time on the source file, and
2125 -- return the cached summary if it hasn't changed. If the
2126 -- file has disappeared, we need to call the Finder again.
2128 Just (_,t) -> check_timestamp old_summary location src_fn t
2130 m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
2132 Right t -> check_timestamp old_summary location src_fn t
2133 Left e | isDoesNotExistError e -> find_it
2134 | otherwise -> liftIO $ ioError e
2136 | otherwise = find_it
2138 dflags = hsc_dflags hsc_env
2140 hsc_src = if is_boot then HsBootFile else HsSrcFile
2142 check_timestamp old_summary location src_fn src_timestamp
2143 | ms_hs_date old_summary == src_timestamp = do
2144 -- update the object-file timestamp
2145 obj_timestamp <- liftIO $
2146 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2147 || obj_allowed -- bug #1205
2148 then getObjTimestamp location is_boot
2150 return (Just old_summary{ ms_obj_date = obj_timestamp })
2152 -- source changed: re-summarise.
2153 new_summary location (ms_mod old_summary) src_fn src_timestamp
2156 -- Don't use the Finder's cache this time. If the module was
2157 -- previously a package module, it may have now appeared on the
2158 -- search path, so we want to consider it to be a home module. If
2159 -- the module was previously a home module, it may have moved.
2160 liftIO $ uncacheModule hsc_env wanted_mod
2161 found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
2164 | isJust (ml_hs_file location) ->
2166 just_found location mod
2168 -- Drop external-pkg
2169 ASSERT(modulePackageId mod /= thisPackage dflags)
2172 err -> liftIO $ noModError dflags loc wanted_mod err
2175 just_found location mod = do
2176 -- Adjust location to point to the hs-boot source file,
2177 -- hi file, object file, when is_boot says so
2178 let location' | is_boot = addBootSuffixLocn location
2179 | otherwise = location
2180 src_fn = expectJust "summarise2" (ml_hs_file location')
2182 -- Check that it exists
2183 -- It might have been deleted since the Finder last found it
2184 maybe_t <- liftIO $ modificationTimeIfExists src_fn
2186 Nothing -> noHsFileErr loc src_fn
2187 Just t -> new_summary location' mod src_fn t
2190 new_summary location mod src_fn src_timestamp
2192 -- Preprocess the source file and get its imports
2193 -- The dflags' contains the OPTIONS pragmas
2194 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2195 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
2197 when (mod_name /= wanted_mod) $
2198 throwOneError $ mkPlainErrMsg mod_loc $
2199 text "File name does not match module name:"
2200 $$ text "Saw:" <+> quotes (ppr mod_name)
2201 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2203 -- Find the object timestamp, and return the summary
2204 obj_timestamp <- liftIO $
2205 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2206 || obj_allowed -- bug #1205
2207 then getObjTimestamp location is_boot
2210 return (Just (ModSummary { ms_mod = mod,
2211 ms_hsc_src = hsc_src,
2212 ms_location = location,
2213 ms_hspp_file = hspp_fn,
2214 ms_hspp_opts = dflags',
2215 ms_hspp_buf = Just buf,
2216 ms_srcimps = srcimps,
2218 ms_hs_date = src_timestamp,
2219 ms_obj_date = obj_timestamp }))
2222 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
2223 getObjTimestamp location is_boot
2224 = if is_boot then return Nothing
2225 else modificationTimeIfExists (ml_obj_file location)
2228 preprocessFile :: GhcMonad m =>
2231 -> Maybe Phase -- ^ Starting phase
2232 -> Maybe (StringBuffer,ClockTime)
2233 -> m (DynFlags, FilePath, StringBuffer)
2234 preprocessFile hsc_env src_fn mb_phase Nothing
2236 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2237 buf <- liftIO $ hGetStringBuffer hspp_fn
2238 return (dflags', hspp_fn, buf)
2240 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2242 let dflags = hsc_dflags hsc_env
2243 -- case we bypass the preprocessing stage?
2245 local_opts = getOptions dflags buf src_fn
2247 (dflags', leftovers, warns)
2248 <- parseDynamicNoPackageFlags dflags local_opts
2249 checkProcessArgsResult leftovers
2250 handleFlagWarnings dflags' warns
2254 | Just (Unlit _) <- mb_phase = True
2255 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2256 -- note: local_opts is only required if there's no Unlit phase
2257 | dopt Opt_Cpp dflags' = True
2258 | dopt Opt_Pp dflags' = True
2261 when needs_preprocessing $
2262 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
2264 return (dflags', src_fn, buf)
2267 -----------------------------------------------------------------------------
2269 -----------------------------------------------------------------------------
2271 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
2272 -- ToDo: we don't have a proper line number for this error
2273 noModError dflags loc wanted_mod err
2274 = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
2276 noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
2277 noHsFileErr loc path
2278 = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
2280 packageModErr :: GhcMonad m => ModuleName -> m a
2282 = throwOneError $ mkPlainErrMsg noSrcSpan $
2283 text "module" <+> quotes (ppr mod) <+> text "is a package module"
2285 multiRootsErr :: [ModSummary] -> IO ()
2286 multiRootsErr [] = panic "multiRootsErr"
2287 multiRootsErr summs@(summ1:_)
2288 = throwOneError $ mkPlainErrMsg noSrcSpan $
2289 text "module" <+> quotes (ppr mod) <+>
2290 text "is defined in multiple files:" <+>
2291 sep (map text files)
2294 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2296 cyclicModuleErr :: [ModSummary] -> SDoc
2298 = hang (ptext (sLit "Module imports form a cycle for modules:"))
2299 2 (vcat (map show_one ms))
2301 show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
2302 nest 2 $ ptext (sLit "imports:") <+>
2303 (pp_imps HsBootFile (ms_srcimps ms)
2304 $$ pp_imps HsSrcFile (ms_imps ms))]
2305 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
2306 pp_imps src mods = fsep (map (show_mod src) mods)
2309 -- | Inform GHC that the working directory has changed. GHC will flush
2310 -- its cache of module locations, since it may no longer be valid.
2311 -- Note: if you change the working directory, you should also unload
2312 -- the current program (set targets to empty, followed by load).
2313 workingDirectoryChanged :: GhcMonad m => m ()
2314 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
2316 -- -----------------------------------------------------------------------------
2317 -- inspecting the session
2319 -- | Get the module dependency graph.
2320 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
2321 getModuleGraph = liftM hsc_mod_graph getSession
2323 -- | Return @True@ <==> module is loaded.
2324 isLoaded :: GhcMonad m => ModuleName -> m Bool
2325 isLoaded m = withSession $ \hsc_env ->
2326 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
2328 -- | Return the bindings for the current interactive session.
2329 getBindings :: GhcMonad m => m [TyThing]
2330 getBindings = withSession $ \hsc_env ->
2331 -- we have to implement the shadowing behaviour of ic_tmp_ids here
2332 -- (see InteractiveContext) and the quickest way is to use an OccEnv.
2334 tmp_ids = ic_tmp_ids (hsc_IC hsc_env)
2335 filtered = foldr f (const []) tmp_ids emptyUniqSet
2337 | uniq `elementOfUniqSet` set = rest set
2338 | otherwise = AnId id : rest (addOneToUniqSet set uniq)
2339 where uniq = getUnique (nameOccName (idName id))
2343 getPrintUnqual :: GhcMonad m => m PrintUnqualified
2344 getPrintUnqual = withSession $ \hsc_env ->
2345 return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
2347 -- | Container for information about a 'Module'.
2348 data ModuleInfo = ModuleInfo {
2349 minf_type_env :: TypeEnv,
2350 minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
2351 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
2352 minf_instances :: [Instance]
2354 ,minf_modBreaks :: ModBreaks
2356 -- ToDo: this should really contain the ModIface too
2358 -- We don't want HomeModInfo here, because a ModuleInfo applies
2359 -- to package modules too.
2361 -- | Request information about a loaded 'Module'
2362 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
2363 getModuleInfo mdl = withSession $ \hsc_env -> do
2364 let mg = hsc_mod_graph hsc_env
2365 if mdl `elem` map ms_mod mg
2366 then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
2368 {- if isHomeModule (hsc_dflags hsc_env) mdl
2370 else -} liftIO $ getPackageModuleInfo hsc_env mdl
2371 -- getPackageModuleInfo will attempt to find the interface, so
2372 -- we don't want to call it for a home module, just in case there
2373 -- was a problem loading the module and the interface doesn't
2374 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
2376 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
2378 getPackageModuleInfo hsc_env mdl = do
2379 (_msgs, mb_avails) <- getModuleExports hsc_env mdl
2381 Nothing -> return Nothing
2383 eps <- readIORef (hsc_EPS hsc_env)
2385 names = availsToNameSet avails
2387 tys = [ ty | name <- concatMap availNames avails,
2388 Just ty <- [lookupTypeEnv pte name] ]
2390 return (Just (ModuleInfo {
2391 minf_type_env = mkTypeEnv tys,
2392 minf_exports = names,
2393 minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
2394 minf_instances = error "getModuleInfo: instances for package module unimplemented",
2395 minf_modBreaks = emptyModBreaks
2398 getPackageModuleInfo _hsc_env _mdl = do
2399 -- bogusly different for non-GHCI (ToDo)
2403 getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
2404 getHomeModuleInfo hsc_env mdl =
2405 case lookupUFM (hsc_HPT hsc_env) mdl of
2406 Nothing -> return Nothing
2408 let details = hm_details hmi
2409 return (Just (ModuleInfo {
2410 minf_type_env = md_types details,
2411 minf_exports = availsToNameSet (md_exports details),
2412 minf_rdr_env = mi_globals $! hm_iface hmi,
2413 minf_instances = md_insts details
2415 ,minf_modBreaks = getModBreaks hmi
2419 -- | The list of top-level entities defined in a module
2420 modInfoTyThings :: ModuleInfo -> [TyThing]
2421 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
2423 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
2424 modInfoTopLevelScope minf
2425 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
2427 modInfoExports :: ModuleInfo -> [Name]
2428 modInfoExports minf = nameSetToList $! minf_exports minf
2430 -- | Returns the instances defined by the specified module.
2431 -- Warning: currently unimplemented for package modules.
2432 modInfoInstances :: ModuleInfo -> [Instance]
2433 modInfoInstances = minf_instances
2435 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
2436 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
2438 mkPrintUnqualifiedForModule :: GhcMonad m =>
2440 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
2441 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
2442 return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
2444 modInfoLookupName :: GhcMonad m =>
2446 -> m (Maybe TyThing) -- XXX: returns a Maybe X
2447 modInfoLookupName minf name = withSession $ \hsc_env -> do
2448 case lookupTypeEnv (minf_type_env minf) name of
2449 Just tyThing -> return (Just tyThing)
2451 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2452 return $! lookupType (hsc_dflags hsc_env)
2453 (hsc_HPT hsc_env) (eps_PTE eps) name
2456 modInfoModBreaks :: ModuleInfo -> ModBreaks
2457 modInfoModBreaks = minf_modBreaks
2460 isDictonaryId :: Id -> Bool
2462 = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
2464 -- | Looks up a global name: that is, any top-level name in any
2465 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
2466 -- the interactive context, and therefore does not require a preceding
2468 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
2469 lookupGlobalName name = withSession $ \hsc_env -> do
2470 liftIO $ lookupTypeHscEnv hsc_env name
2472 findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
2473 findGlobalAnns deserialize target = withSession $ \hsc_env -> do
2474 ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
2475 return (findAnns deserialize ann_env target)
2478 -- | get the GlobalRdrEnv for a session
2479 getGRE :: GhcMonad m => m GlobalRdrEnv
2480 getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
2483 -- -----------------------------------------------------------------------------
2485 -- | Return all /external/ modules available in the package database.
2486 -- Modules from the current session (i.e., from the 'HomePackageTable') are
2488 packageDbModules :: GhcMonad m =>
2489 Bool -- ^ Only consider exposed packages.
2491 packageDbModules only_exposed = do
2492 dflags <- getSessionDynFlags
2493 let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags))
2495 [ mkModule pid modname | p <- pkgs
2496 , not only_exposed || exposed p
2497 , pid <- [mkPackageId (package p)]
2498 , modname <- exposedModules p ]
2500 -- -----------------------------------------------------------------------------
2501 -- Misc exported utils
2503 dataConType :: DataCon -> Type
2504 dataConType dc = idType (dataConWrapId dc)
2506 -- | print a 'NamedThing', adding parentheses if the name is an operator.
2507 pprParenSymName :: NamedThing a => a -> SDoc
2508 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
2510 -- ----------------------------------------------------------------------------
2515 -- - Data and Typeable instances for HsSyn.
2517 -- ToDo: check for small transformations that happen to the syntax in
2518 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
2520 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
2521 -- to get from TyCons, Ids etc. to TH syntax (reify).
2523 -- :browse will use either lm_toplev or inspect lm_interface, depending
2524 -- on whether the module is interpreted or not.
2528 -- Extract the filename, stringbuffer content and dynflags associed to a module
2530 -- XXX: Explain pre-conditions
2531 getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
2532 getModuleSourceAndFlags mod = do
2533 m <- getModSummary (moduleName mod)
2534 case ml_hs_file $ ms_location m of
2535 Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
2536 Just sourceFile -> do
2537 source <- liftIO $ hGetStringBuffer sourceFile
2538 return (sourceFile, source, ms_hspp_opts m)
2541 -- | Return module source as token stream, including comments.
2543 -- The module must be in the module graph and its source must be available.
2544 -- Throws a 'HscTypes.SourceError' on parse error.
2545 getTokenStream :: GhcMonad m => Module -> m [Located Token]
2546 getTokenStream mod = do
2547 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2548 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2549 case lexTokenStream source startLoc flags of
2550 POk _ ts -> return ts
2551 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2553 -- | Give even more information on the source than 'getTokenStream'
2554 -- This function allows reconstructing the source completely with
2555 -- 'showRichTokenStream'.
2556 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
2557 getRichTokenStream mod = do
2558 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2559 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2560 case lexTokenStream source startLoc flags of
2561 POk _ ts -> return $ addSourceToTokens startLoc source ts
2562 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2564 -- | Given a source location and a StringBuffer corresponding to this
2565 -- location, return a rich token stream with the source associated to the
2567 addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
2568 -> [(Located Token, String)]
2569 addSourceToTokens _ _ [] = []
2570 addSourceToTokens loc buf (t@(L span _) : ts)
2571 | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
2572 | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
2574 (newLoc, newBuf, str) = go "" loc buf
2575 start = srcSpanStart span
2576 end = srcSpanEnd span
2577 go acc loc buf | loc < start = go acc nLoc nBuf
2578 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
2579 | otherwise = (loc, buf, reverse acc)
2580 where (ch, nBuf) = nextChar buf
2581 nLoc = advanceSrcLoc loc ch
2584 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
2585 -- return source code almost identical to the original code (except for
2586 -- insignificant whitespace.)
2587 showRichTokenStream :: [(Located Token, String)] -> String
2588 showRichTokenStream ts = go startLoc ts ""
2589 where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
2590 startLoc = mkSrcLoc sourceFile 0 0
2592 go loc ((L span _, str):ts)
2593 | not (isGoodSrcSpan span) = go loc ts
2594 | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
2597 | otherwise = ((replicate (tokLine - locLine) '\n') ++)
2598 . ((replicate tokCol ' ') ++)
2601 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
2602 (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
2603 tokEnd = srcSpanEnd span
2605 -- -----------------------------------------------------------------------------
2606 -- Interactive evaluation
2608 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
2609 -- filesystem and package database to find the corresponding 'Module',
2610 -- using the algorithm that is used for an @import@ declaration.
2611 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2612 findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX
2614 dflags = hsc_dflags hsc_env
2615 hpt = hsc_HPT hsc_env
2616 this_pkg = thisPackage dflags
2618 case lookupUFM hpt mod_name of
2619 Just mod_info -> return (mi_module (hm_iface mod_info))
2620 _not_a_home_module -> do
2621 res <- findImportedModule hsc_env mod_name maybe_pkg
2623 Found _ m | modulePackageId m /= this_pkg -> return m
2624 | otherwise -> ghcError (CmdLineError (showSDoc $
2625 text "module" <+> quotes (ppr (moduleName m)) <+>
2626 text "is not loaded"))
2627 err -> let msg = cannotFindModule dflags mod_name err in
2628 ghcError (CmdLineError (showSDoc msg))
2631 getHistorySpan :: GhcMonad m => History -> m SrcSpan
2632 getHistorySpan h = withSession $ \hsc_env ->
2633 return$ InteractiveEval.getHistorySpan hsc_env h
2635 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
2636 obtainTermFromVal bound force ty a =
2637 withSession $ \hsc_env ->
2638 liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
2640 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
2641 obtainTermFromId bound force id =
2642 withSession $ \hsc_env ->
2643 liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
projects / ghc-hetmet.git / blob