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,
57 -- * Parsing Haddock comments
60 -- * Inspecting the module structure of the program
61 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
66 -- * Inspecting modules
73 modInfoIsExportedName,
76 mkPrintUnqualifiedForModule,
79 PrintUnqualified, alwaysQualify,
81 -- * Interactive evaluation
82 getBindings, getPrintUnqual,
85 setContext, getContext,
95 runStmt, SingleStep(..),
97 Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
98 resumeHistory, resumeHistoryIx),
99 History(historyBreakInfo, historyEnclosingDecl),
100 GHC.getHistorySpan, getHistoryModule,
103 InteractiveEval.back,
104 InteractiveEval.forward,
107 InteractiveEval.compileExpr, HValue, dynCompileExpr,
109 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
111 ModBreaks(..), BreakIndex,
112 BreakInfo(breakInfo_number, breakInfo_module),
113 BreakArray, setBreakOn, setBreakOff, getBreak,
116 -- * Abstract syntax elements
122 Module, mkModule, pprModule, moduleName, modulePackageId,
123 ModuleName, mkModuleName, moduleNameString,
127 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
129 RdrName(Qual,Unqual),
133 isImplicitId, isDeadBinder,
134 isExportedId, isLocalId, isGlobalId,
136 isPrimOpId, isFCallId, isClassOpId_maybe,
137 isDataConWorkId, idDataCon,
138 isBottomingId, isDictonaryId,
139 recordSelectorFieldLabel,
141 -- ** Type constructors
143 tyConTyVars, tyConDataCons, tyConArity,
144 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
146 synTyConDefn, synTyConType, synTyConResKind,
152 -- ** Data constructors
154 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
155 dataConIsInfix, isVanillaDataCon,
157 StrictnessMark(..), isMarkedStrict,
161 classMethods, classSCTheta, classTvsFds,
166 instanceDFunId, pprInstance, pprInstanceHdr,
168 -- ** Types and Kinds
169 Type, splitForAllTys, funResultTy,
170 pprParendType, pprTypeApp,
173 ThetaType, pprThetaArrow,
179 module HsSyn, -- ToDo: remove extraneous bits
183 defaultFixity, maxPrecedence,
187 -- ** Source locations
189 mkSrcLoc, isGoodSrcLoc, noSrcLoc,
190 srcLocFile, srcLocLine, srcLocCol,
192 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
193 srcSpanStart, srcSpanEnd,
195 srcSpanStartLine, srcSpanEndLine,
196 srcSpanStartCol, srcSpanEndCol,
199 GhcException(..), showGhcException,
201 -- * Token stream manipulations
203 getTokenStream, getRichTokenStream,
204 showRichTokenStream, addSourceToTokens,
214 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
215 * what StaticFlags should we expose, if any?
218 #include "HsVersions.h"
221 import qualified Linker
222 import Linker ( HValue )
226 import InteractiveEval
231 import TcRnTypes hiding (LIE)
232 import TcRnMonad ( initIfaceCheck )
236 import qualified HsSyn -- hack as we want to reexport the whole module
237 import HsSyn hiding ((<.>))
238 import Type hiding (typeKind)
239 import TcType hiding (typeKind)
242 import TysPrim ( alphaTyVars )
247 import Name hiding ( varName )
248 import OccName ( parenSymOcc )
249 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
251 import FamInstEnv ( emptyFamInstEnv )
255 import DriverPipeline
256 import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
262 import StaticFlagParser
263 import qualified StaticFlags
264 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
273 import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
277 import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
280 import Maybes ( expectJust, mapCatMaybes )
282 import HaddockLex ( tokenise )
286 import Control.Concurrent
287 import System.Directory ( getModificationTime, doesFileExist,
288 getCurrentDirectory )
291 import qualified Data.List as List
293 import System.Exit ( exitWith, ExitCode(..) )
294 import System.Time ( ClockTime, getClockTime )
297 import System.FilePath
299 import System.IO.Error ( try, isDoesNotExistError )
300 #if __GLASGOW_HASKELL__ >= 609
301 import Data.Typeable (cast)
303 import Prelude hiding (init)
306 -- -----------------------------------------------------------------------------
307 -- Exception handlers
309 -- | Install some default exception handlers and run the inner computation.
310 -- Unless you want to handle exceptions yourself, you should wrap this around
311 -- the top level of your program. The default handlers output the error
312 -- message(s) to stderr and exit cleanly.
313 defaultErrorHandler :: DynFlags -> IO a -> IO a
314 defaultErrorHandler dflags inner =
315 -- top-level exception handler: any unrecognised exception is a compiler bug.
316 #if __GLASGOW_HASKELL__ < 609
317 handle (\exception -> do
320 -- an IO exception probably isn't our fault, so don't panic
322 fatalErrorMsg dflags (text (show exception))
323 AsyncException StackOverflow ->
324 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
325 ExitException _ -> throw exception
327 fatalErrorMsg dflags (text (show (Panic (show exception))))
328 exitWith (ExitFailure 1)
331 handle (\(SomeException exception) -> do
333 case cast exception of
334 -- an IO exception probably isn't our fault, so don't panic
335 Just (ioe :: IOException) ->
336 fatalErrorMsg dflags (text (show ioe))
337 _ -> case cast exception of
338 Just StackOverflow ->
339 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
340 _ -> case cast exception of
341 Just (ex :: ExitCode) -> throw ex
344 (text (show (Panic (show exception))))
345 exitWith (ExitFailure 1)
349 -- program errors: messages with locations attached. Sometimes it is
350 -- convenient to just throw these as exceptions.
352 (\em -> do printBagOfErrors dflags (unitBag em)
353 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 dflags
475 -- -----------------------------------------------------------------------------
478 -- | Grabs the DynFlags from the Session
479 getSessionDynFlags :: GhcMonad m => m DynFlags
480 getSessionDynFlags = withSession (return . hsc_dflags)
482 -- | Updates the DynFlags in a Session. This also reads
483 -- the package database (unless it has already been read),
484 -- and prepares the compilers knowledge about packages. It
485 -- can be called again to load new packages: just add new
486 -- package flags to (packageFlags dflags).
488 -- Returns a list of new packages that may need to be linked in using
489 -- the dynamic linker (see 'linkPackages') as a result of new package
490 -- flags. If you are not doing linking or doing static linking, you
491 -- can ignore the list of packages returned.
493 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
494 setSessionDynFlags dflags = do
495 (dflags', preload) <- liftIO $ initPackages dflags
496 modifySession (\h -> h{ hsc_dflags = dflags' })
499 -- | If there is no -o option, guess the name of target executable
500 -- by using top-level source file name as a base.
501 guessOutputFile :: GhcMonad m => m ()
502 guessOutputFile = modifySession $ \env ->
503 let dflags = hsc_dflags env
504 mod_graph = hsc_mod_graph env
505 mainModuleSrcPath :: Maybe String
506 mainModuleSrcPath = do
507 let isMain = (== mainModIs dflags) . ms_mod
508 [ms] <- return (filter isMain mod_graph)
509 ml_hs_file (ms_location ms)
510 name = fmap dropExtension mainModuleSrcPath
512 #if defined(mingw32_HOST_OS)
513 -- we must add the .exe extention unconditionally here, otherwise
514 -- when name has an extension of its own, the .exe extension will
515 -- not be added by DriverPipeline.exeFileName. See #2248
516 name_exe = fmap (<.> "exe") name
521 case outputFile dflags of
523 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
525 -- -----------------------------------------------------------------------------
528 -- ToDo: think about relative vs. absolute file paths. And what
529 -- happens when the current directory changes.
531 -- | Sets the targets for this session. Each target may be a module name
532 -- or a filename. The targets correspond to the set of root modules for
533 -- the program\/library. Unloading the current program is achieved by
534 -- setting the current set of targets to be empty, followed by 'load'.
535 setTargets :: GhcMonad m => [Target] -> m ()
536 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
538 -- | Returns the current set of targets
539 getTargets :: GhcMonad m => m [Target]
540 getTargets = withSession (return . hsc_targets)
542 -- | Add another target.
543 addTarget :: GhcMonad m => Target -> m ()
545 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
548 removeTarget :: GhcMonad m => TargetId -> m ()
549 removeTarget target_id
550 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
552 filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
554 -- | Attempts to guess what Target a string refers to. This function
555 -- implements the @--make@/GHCi command-line syntax for filenames:
557 -- - if the string looks like a Haskell source filename, then interpret it
560 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
563 -- - otherwise interpret the string as a module name
565 guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
566 guessTarget str (Just phase)
567 = return (Target (TargetFile str (Just phase)) True Nothing)
568 guessTarget str Nothing
569 | isHaskellSrcFilename file
570 = return (target (TargetFile file Nothing))
572 = do exists <- liftIO $ doesFileExist hs_file
574 then return (target (TargetFile hs_file Nothing))
576 exists <- liftIO $ doesFileExist lhs_file
578 then return (target (TargetFile lhs_file Nothing))
580 if looksLikeModuleName file
581 then return (target (TargetModule (mkModuleName file)))
584 (ProgramError (showSDoc $
585 text "target" <+> quotes (text file) <+>
586 text "is not a module name or a source file"))
589 | '*':rest <- str = (rest, False)
590 | otherwise = (str, True)
592 hs_file = file <.> "hs"
593 lhs_file = file <.> "lhs"
595 target tid = Target tid obj_allowed Nothing
597 -- -----------------------------------------------------------------------------
598 -- Extending the program scope
600 extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
601 extendGlobalRdrScope rdrElts
602 = modifySession $ \hscEnv ->
603 let global_rdr = hsc_global_rdr_env hscEnv
604 in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
606 setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
607 setGlobalRdrScope rdrElts
608 = modifySession $ \hscEnv ->
609 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
611 extendGlobalTypeScope :: GhcMonad m => [Id] -> m ()
612 extendGlobalTypeScope ids
613 = modifySession $ \hscEnv ->
614 let global_type = hsc_global_type_env hscEnv
615 in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
617 setGlobalTypeScope :: GhcMonad m => [Id] -> m ()
618 setGlobalTypeScope ids
619 = modifySession $ \hscEnv ->
620 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
622 -- -----------------------------------------------------------------------------
623 -- Parsing Haddock comments
625 parseHaddockComment :: String -> Either String (HsDoc RdrName)
626 parseHaddockComment string =
627 case parseHaddockParagraphs (tokenise string) of
631 -- -----------------------------------------------------------------------------
632 -- Loading the program
634 -- | Perform a dependency analysis starting from the current targets
635 -- and update the session with the new module graph.
636 depanal :: GhcMonad m =>
637 [ModuleName] -- ^ excluded modules
638 -> Bool -- ^ allow duplicate roots
640 depanal excluded_mods allow_dup_roots = do
641 hsc_env <- getSession
643 dflags = hsc_dflags hsc_env
644 targets = hsc_targets hsc_env
645 old_graph = hsc_mod_graph hsc_env
647 liftIO $ showPass dflags "Chasing dependencies"
648 liftIO $ debugTraceMsg dflags 2 (hcat [
649 text "Chasing modules from: ",
650 hcat (punctuate comma (map pprTarget targets))])
652 mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
653 modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
658 | LoadUpTo ModuleName
659 | LoadDependenciesOf ModuleName
661 -- | Try to load the program. Calls 'loadWithLogger' with the default
662 -- compiler that just immediately logs all warnings and errors.
663 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
665 loadWithLogger defaultWarnErrLogger how_much
667 -- | A function called to log warnings and errors.
668 type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
670 defaultWarnErrLogger :: WarnErrLogger
671 defaultWarnErrLogger Nothing = printWarnings
672 defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
674 -- | Try to load the program. If a Module is supplied, then just
675 -- attempt to load up to this target. If no Module is supplied,
676 -- then try to load all targets.
678 -- The first argument is a function that is called after compiling each
679 -- module to print wanrings and errors.
681 loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
682 loadWithLogger logger how_much = do
683 -- Dependency analysis first. Note that this fixes the module graph:
684 -- even if we don't get a fully successful upsweep, the full module
685 -- graph is still retained in the Session. We can tell which modules
686 -- were successfully loaded by inspecting the Session's HPT.
687 mod_graph <- depanal [] False
688 load2 how_much mod_graph logger
690 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger
692 load2 how_much mod_graph logger = do
694 hsc_env <- getSession
696 let hpt1 = hsc_HPT hsc_env
697 let dflags = hsc_dflags hsc_env
699 -- The "bad" boot modules are the ones for which we have
700 -- B.hs-boot in the module graph, but no B.hs
701 -- The downsweep should have ensured this does not happen
703 let all_home_mods = [ms_mod_name s
704 | s <- mod_graph, not (isBootSummary s)]
705 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
706 not (ms_mod_name s `elem` all_home_mods)]
707 ASSERT( null bad_boot_mods ) return ()
709 -- check that the module given in HowMuch actually exists, otherwise
710 -- topSortModuleGraph will bomb later.
711 let checkHowMuch (LoadUpTo m) = checkMod m
712 checkHowMuch (LoadDependenciesOf m) = checkMod m
716 | m `elem` all_home_mods = and_then
718 liftIO $ errorMsg dflags (text "no such module:" <+>
722 checkHowMuch how_much $ do
724 -- mg2_with_srcimps drops the hi-boot nodes, returning a
725 -- graph with cycles. Among other things, it is used for
726 -- backing out partially complete cycles following a failed
727 -- upsweep, and for removing from hpt all the modules
728 -- not in strict downwards closure, during calls to compile.
729 let mg2_with_srcimps :: [SCC ModSummary]
730 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
732 -- If we can determine that any of the {-# SOURCE #-} imports
733 -- are definitely unnecessary, then emit a warning.
734 warnUnnecessarySourceImports dflags mg2_with_srcimps
737 -- check the stability property for each module.
738 stable_mods@(stable_obj,stable_bco)
739 = checkStability hpt1 mg2_with_srcimps all_home_mods
741 -- prune bits of the HPT which are definitely redundant now,
743 pruned_hpt = pruneHomePackageTable hpt1
744 (flattenSCCs mg2_with_srcimps)
747 liftIO $ evaluate pruned_hpt
749 -- before we unload anything, make sure we don't leave an old
750 -- interactive context around pointing to dead bindings. Also,
751 -- write the pruned HPT to allow the old HPT to be GC'd.
752 modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
753 hsc_HPT = pruned_hpt }
755 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
756 text "Stable BCO:" <+> ppr stable_bco)
758 -- Unload any modules which are going to be re-linked this time around.
759 let stable_linkables = [ linkable
760 | m <- stable_obj++stable_bco,
761 Just hmi <- [lookupUFM pruned_hpt m],
762 Just linkable <- [hm_linkable hmi] ]
763 liftIO $ unload hsc_env stable_linkables
765 -- We could at this point detect cycles which aren't broken by
766 -- a source-import, and complain immediately, but it seems better
767 -- to let upsweep_mods do this, so at least some useful work gets
768 -- done before the upsweep is abandoned.
769 --hPutStrLn stderr "after tsort:\n"
770 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
772 -- Now do the upsweep, calling compile for each module in
773 -- turn. Final result is version 3 of everything.
775 -- Topologically sort the module graph, this time including hi-boot
776 -- nodes, and possibly just including the portion of the graph
777 -- reachable from the module specified in the 2nd argument to load.
778 -- This graph should be cycle-free.
779 -- If we're restricting the upsweep to a portion of the graph, we
780 -- also want to retain everything that is still stable.
781 let full_mg :: [SCC ModSummary]
782 full_mg = topSortModuleGraph False mod_graph Nothing
784 maybe_top_mod = case how_much of
786 LoadDependenciesOf m -> Just m
789 partial_mg0 :: [SCC ModSummary]
790 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
792 -- LoadDependenciesOf m: we want the upsweep to stop just
793 -- short of the specified module (unless the specified module
796 | LoadDependenciesOf _mod <- how_much
797 = ASSERT( case last partial_mg0 of
798 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
799 List.init partial_mg0
805 | AcyclicSCC ms <- full_mg,
806 ms_mod_name ms `elem` stable_obj++stable_bco,
807 ms_mod_name ms `notElem` [ ms_mod_name ms' |
808 AcyclicSCC ms' <- partial_mg ] ]
810 mg = stable_mg ++ partial_mg
812 -- clean up between compilations
813 let cleanup = cleanTempFilesExcept dflags
814 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
816 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
818 (upsweep_ok, hsc_env1, modsUpswept)
820 (hsc_env { hsc_HPT = emptyHomePackageTable })
821 pruned_hpt stable_mods cleanup mg
823 -- Make modsDone be the summaries for each home module now
824 -- available; this should equal the domain of hpt3.
825 -- Get in in a roughly top .. bottom order (hence reverse).
827 let modsDone = reverse modsUpswept
829 -- Try and do linking in some form, depending on whether the
830 -- upsweep was completely or only partially successful.
832 if succeeded upsweep_ok
835 -- Easy; just relink it all.
836 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
838 -- Clean up after ourselves
839 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
841 -- Issue a warning for the confusing case where the user
842 -- said '-o foo' but we're not going to do any linking.
843 -- We attempt linking if either (a) one of the modules is
844 -- called Main, or (b) the user said -no-hs-main, indicating
845 -- that main() is going to come from somewhere else.
847 let ofile = outputFile dflags
848 let no_hs_main = dopt Opt_NoHsMain dflags
850 main_mod = mainModIs dflags
851 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
852 do_linking = a_root_is_Main || no_hs_main
854 when (ghcLink dflags == LinkBinary
855 && isJust ofile && not do_linking) $
856 liftIO $ debugTraceMsg dflags 1 $
857 text ("Warning: output was redirected with -o, " ++
858 "but no output will be generated\n" ++
859 "because there is no " ++
860 moduleNameString (moduleName main_mod) ++ " module.")
862 -- link everything together
863 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
865 loadFinish Succeeded linkresult hsc_env1
868 -- Tricky. We need to back out the effects of compiling any
869 -- half-done cycles, both so as to clean up the top level envs
870 -- and to avoid telling the interactive linker to link them.
871 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
874 = map ms_mod modsDone
875 let mods_to_zap_names
876 = findPartiallyCompletedCycles modsDone_names
879 = filter ((`notElem` mods_to_zap_names).ms_mod)
882 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
885 -- Clean up after ourselves
886 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
888 -- there should be no Nothings where linkables should be, now
889 ASSERT(all (isJust.hm_linkable)
890 (eltsUFM (hsc_HPT hsc_env))) do
892 -- Link everything together
893 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
895 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
896 loadFinish Failed linkresult hsc_env4
898 -- Finish up after a load.
900 -- If the link failed, unload everything and return.
901 loadFinish :: GhcMonad m =>
902 SuccessFlag -> SuccessFlag -> HscEnv
904 loadFinish _all_ok Failed hsc_env
905 = do liftIO $ unload hsc_env []
906 modifySession $ \_ -> discardProg hsc_env
909 -- Empty the interactive context and set the module context to the topmost
910 -- newly loaded module, or the Prelude if none were loaded.
911 loadFinish all_ok Succeeded hsc_env
912 = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
916 -- Forget the current program, but retain the persistent info in HscEnv
917 discardProg :: HscEnv -> HscEnv
919 = hsc_env { hsc_mod_graph = emptyMG,
920 hsc_IC = emptyInteractiveContext,
921 hsc_HPT = emptyHomePackageTable }
923 -- used to fish out the preprocess output files for the purposes of
924 -- cleaning up. The preprocessed file *might* be the same as the
925 -- source file, but that doesn't do any harm.
926 ppFilesFromSummaries :: [ModSummary] -> [FilePath]
927 ppFilesFromSummaries summaries = map ms_hspp_file summaries
929 -- -----------------------------------------------------------------------------
931 class ParsedMod m where
932 modSummary :: m -> ModSummary
933 parsedSource :: m -> ParsedSource
935 class ParsedMod m => TypecheckedMod m where
936 renamedSource :: m -> Maybe RenamedSource
937 typecheckedSource :: m -> TypecheckedSource
938 moduleInfo :: m -> ModuleInfo
939 tm_internals :: m -> (TcGblEnv, ModDetails)
940 -- ToDo: improvements that could be made here:
941 -- if the module succeeded renaming but not typechecking,
942 -- we can still get back the GlobalRdrEnv and exports, so
943 -- perhaps the ModuleInfo should be split up into separate
946 class TypecheckedMod m => DesugaredMod m where
947 coreModule :: m -> ModGuts
949 -- | The result of successful parsing.
951 ParsedModule { pm_mod_summary :: ModSummary
952 , pm_parsed_source :: ParsedSource }
954 instance ParsedMod ParsedModule where
955 modSummary m = pm_mod_summary m
956 parsedSource m = pm_parsed_source m
958 -- | The result of successful typechecking. It also contains the parser
960 data TypecheckedModule =
961 TypecheckedModule { tm_parsed_module :: ParsedModule
962 , tm_renamed_source :: Maybe RenamedSource
963 , tm_typechecked_source :: TypecheckedSource
964 , tm_checked_module_info :: ModuleInfo
965 , tm_internals_ :: (TcGblEnv, ModDetails)
968 instance ParsedMod TypecheckedModule where
969 modSummary m = modSummary (tm_parsed_module m)
970 parsedSource m = parsedSource (tm_parsed_module m)
972 instance TypecheckedMod TypecheckedModule where
973 renamedSource m = tm_renamed_source m
974 typecheckedSource m = tm_typechecked_source m
975 moduleInfo m = tm_checked_module_info m
976 tm_internals m = tm_internals_ m
978 -- | The result of successful desugaring (i.e., translation to core). Also
979 -- contains all the information of a typechecked module.
980 data DesugaredModule =
981 DesugaredModule { dm_typechecked_module :: TypecheckedModule
982 , dm_core_module :: ModGuts
985 instance ParsedMod DesugaredModule where
986 modSummary m = modSummary (dm_typechecked_module m)
987 parsedSource m = parsedSource (dm_typechecked_module m)
989 instance TypecheckedMod DesugaredModule where
990 renamedSource m = renamedSource (dm_typechecked_module m)
991 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
992 moduleInfo m = moduleInfo (dm_typechecked_module m)
993 tm_internals m = tm_internals_ (dm_typechecked_module m)
995 instance DesugaredMod DesugaredModule where
996 coreModule m = dm_core_module m
998 type ParsedSource = Located (HsModule RdrName)
999 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
1000 Maybe (HsDoc Name), HaddockModInfo Name)
1001 type TypecheckedSource = LHsBinds Id
1004 -- - things that aren't in the output of the typechecker right now:
1005 -- - the export list
1007 -- - type signatures
1008 -- - type/data/newtype declarations
1009 -- - class declarations
1011 -- - extra things in the typechecker's output:
1012 -- - default methods are turned into top-level decls.
1013 -- - dictionary bindings
1015 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
1016 getModSummary mod = do
1017 mg <- liftM hsc_mod_graph getSession
1018 case [ ms | ms <- mg, ms_mod_name ms == mod ] of
1019 [] -> throw $ mkApiErr (text "Module not part of module graph")
1022 -- | Parse a module.
1024 -- Throws a 'SourceError' on parse error.
1025 parseModule :: GhcMonad m => ModuleName -> m ParsedModule
1026 parseModule mod = do
1027 ms <- getModSummary mod
1028 hsc_env0 <- getSession
1029 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1030 rdr_module <- parseFile hsc_env ms
1031 return (ParsedModule ms rdr_module)
1033 -- | Typecheck and rename a parsed module.
1035 -- Throws a 'SourceError' if either fails.
1036 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
1037 typecheckModule pmod = do
1038 let ms = modSummary pmod
1039 hsc_env0 <- getSession
1040 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1041 (tc_gbl_env, rn_info)
1042 <- typecheckRenameModule hsc_env ms (parsedSource pmod)
1043 details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env
1046 tm_internals_ = (tc_gbl_env, details),
1047 tm_parsed_module = pmod,
1048 tm_renamed_source = rn_info,
1049 tm_typechecked_source = tcg_binds tc_gbl_env,
1050 tm_checked_module_info =
1052 minf_type_env = md_types details,
1053 minf_exports = availsToNameSet $ md_exports details,
1054 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
1055 minf_instances = md_insts details
1057 ,minf_modBreaks = emptyModBreaks
1061 -- | Desugar a typechecked module.
1062 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
1063 desugarModule tcm = do
1064 let ms = modSummary tcm
1065 hsc_env0 <- getSession
1066 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1067 let (tcg, _) = tm_internals tcm
1068 guts <- deSugarModule hsc_env ms tcg
1071 dm_typechecked_module = tcm,
1072 dm_core_module = guts
1075 -- | Load a module. Input doesn't need to be desugared.
1077 -- XXX: Describe usage.
1078 loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
1080 let ms = modSummary tcm
1081 let mod = ms_mod_name ms
1082 hsc_env0 <- getSession
1083 let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms }
1084 let (tcg, details) = tm_internals tcm
1085 (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details
1086 let mod_info = HomeModInfo {
1088 hm_details = details,
1089 hm_linkable = Nothing }
1090 let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
1091 modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new }
1094 -- | This is the way to get access to the Core bindings corresponding
1095 -- to a module. 'compileToCore' parses, typechecks, and
1096 -- desugars the module, then returns the resulting Core module (consisting of
1097 -- the module name, type declarations, and function declarations) if
1099 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1100 compileToCoreModule = compileCore False
1102 -- | Like compileToCoreModule, but invokes the simplifier, so
1103 -- as to return simplified and tidied Core.
1104 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1105 compileToCoreSimplified = compileCore True
1107 -- | Provided for backwards-compatibility: compileToCore returns just the Core
1108 -- bindings, but for most purposes, you probably want to call
1109 -- compileToCoreModule.
1110 compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
1111 compileToCore fn = do
1112 mod <- compileToCoreModule session fn
1113 return $ cm_binds mod
1115 -- | Takes a CoreModule and compiles the bindings therein
1116 -- to object code. The first argument is a bool flag indicating
1117 -- whether to run the simplifier.
1118 -- The resulting .o, .hi, and executable files, if any, are stored in the
1119 -- current directory, and named according to the module name.
1120 -- Returns True iff compilation succeeded.
1121 -- This has only so far been tested with a single self-contained module.
1122 compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
1123 compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
1124 hscEnv <- getSession
1125 dflags <- getSessionDynFlags
1126 currentTime <- liftIO $ getClockTime
1127 cwd <- liftIO $ getCurrentDirectory
1128 modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
1129 ((moduleNameSlashes . moduleName) mName)
1131 let modSummary = ModSummary { ms_mod = mName,
1132 ms_hsc_src = ExtCoreFile,
1133 ms_location = modLocation,
1134 -- By setting the object file timestamp to Nothing,
1135 -- we always force recompilation, which is what we
1136 -- want. (Thus it doesn't matter what the timestamp
1137 -- for the (nonexistent) source file is.)
1138 ms_hs_date = currentTime,
1139 ms_obj_date = Nothing,
1140 -- Only handling the single-module case for now, so no imports.
1145 ms_hspp_opts = dflags,
1146 ms_hspp_buf = Nothing
1149 ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv,
1150 compModSummary=modSummary,
1151 compOldIface=Nothing}) $
1152 let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
1153 | otherwise = return mod_guts
1154 in maybe_simplify (mkModGuts cm)
1160 -- Makes a "vanilla" ModGuts.
1161 mkModGuts :: CoreModule -> ModGuts
1162 mkModGuts coreModule = ModGuts {
1163 mg_module = cm_module coreModule,
1166 mg_deps = noDependencies,
1167 mg_dir_imps = emptyModuleEnv,
1168 mg_used_names = emptyNameSet,
1169 mg_rdr_env = emptyGlobalRdrEnv,
1170 mg_fix_env = emptyFixityEnv,
1171 mg_types = emptyTypeEnv,
1175 mg_binds = cm_binds coreModule,
1176 mg_foreign = NoStubs,
1177 mg_warns = NoWarnings,
1178 mg_hpc_info = emptyHpcInfo False,
1179 mg_modBreaks = emptyModBreaks,
1180 mg_vect_info = noVectInfo,
1181 mg_inst_env = emptyInstEnv,
1182 mg_fam_inst_env = emptyFamInstEnv
1185 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1186 compileCore simplify fn = do
1187 -- First, set the target to the desired filename
1188 target <- guessTarget fn Nothing
1191 -- Then find dependencies
1192 modGraph <- depanal [] True
1193 case find ((== fn) . msHsFilePath) modGraph of
1194 Just modSummary -> do
1195 -- Now we have the module name;
1196 -- parse, typecheck and desugar the module
1197 let mod = ms_mod_name modSummary
1198 mod_guts <- coreModule `fmap`
1199 (desugarModule =<< typecheckModule =<< parseModule mod)
1200 liftM gutsToCoreModule $
1203 -- If simplify is true: simplify (hscSimplify), then tidy
1205 hsc_env <- getSession
1206 simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts)
1208 compHscEnv = hsc_env,
1209 compModSummary = modSummary,
1210 compOldIface = Nothing})
1211 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1212 return $ Left tidy_guts
1214 return $ Right mod_guts
1216 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1217 module dependency graph"
1218 where -- two versions, based on whether we simplify (thus run tidyProgram,
1219 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1220 -- we just have a ModGuts.
1221 gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
1222 gutsToCoreModule (Left (cg, md)) = CoreModule {
1223 cm_module = cg_module cg, cm_types = md_types md,
1224 cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
1226 gutsToCoreModule (Right mg) = CoreModule {
1227 cm_module = mg_module mg, cm_types = mg_types mg,
1228 cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
1231 -- ---------------------------------------------------------------------------
1234 unload :: HscEnv -> [Linkable] -> IO ()
1235 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
1236 = case ghcLink (hsc_dflags hsc_env) of
1238 LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
1240 LinkInMemory -> panic "unload: no interpreter"
1241 -- urgh. avoid warnings:
1242 hsc_env stable_linkables
1246 -- -----------------------------------------------------------------------------
1250 Stability tells us which modules definitely do not need to be recompiled.
1251 There are two main reasons for having stability:
1253 - avoid doing a complete upsweep of the module graph in GHCi when
1254 modules near the bottom of the tree have not changed.
1256 - to tell GHCi when it can load object code: we can only load object code
1257 for a module when we also load object code fo all of the imports of the
1258 module. So we need to know that we will definitely not be recompiling
1259 any of these modules, and we can use the object code.
1261 The stability check is as follows. Both stableObject and
1262 stableBCO are used during the upsweep phase later.
1265 stable m = stableObject m || stableBCO m
1268 all stableObject (imports m)
1269 && old linkable does not exist, or is == on-disk .o
1270 && date(on-disk .o) > date(.hs)
1273 all stable (imports m)
1274 && date(BCO) > date(.hs)
1277 These properties embody the following ideas:
1279 - if a module is stable, then:
1281 - if it has been compiled in a previous pass (present in HPT)
1282 then it does not need to be compiled or re-linked.
1284 - if it has not been compiled in a previous pass,
1285 then we only need to read its .hi file from disk and
1286 link it to produce a 'ModDetails'.
1288 - if a modules is not stable, we will definitely be at least
1289 re-linking, and possibly re-compiling it during the 'upsweep'.
1290 All non-stable modules can (and should) therefore be unlinked
1291 before the 'upsweep'.
1293 - Note that objects are only considered stable if they only depend
1294 on other objects. We can't link object code against byte code.
1298 :: HomePackageTable -- HPT from last compilation
1299 -> [SCC ModSummary] -- current module graph (cyclic)
1300 -> [ModuleName] -- all home modules
1301 -> ([ModuleName], -- stableObject
1302 [ModuleName]) -- stableBCO
1304 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
1306 checkSCC (stable_obj, stable_bco) scc0
1307 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
1308 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
1309 | otherwise = (stable_obj, stable_bco)
1311 scc = flattenSCC scc0
1312 scc_mods = map ms_mod_name scc
1313 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
1315 scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
1316 -- all imports outside the current SCC, but in the home pkg
1318 stable_obj_imps = map (`elem` stable_obj) scc_allimps
1319 stable_bco_imps = map (`elem` stable_bco) scc_allimps
1323 && all object_ok scc
1326 and (zipWith (||) stable_obj_imps stable_bco_imps)
1330 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
1334 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
1335 Just hmi | Just l <- hm_linkable hmi
1336 -> isObjectLinkable l && t == linkableTime l
1338 -- why '>=' rather than '>' above? If the filesystem stores
1339 -- times to the nearset second, we may occasionally find that
1340 -- the object & source have the same modification time,
1341 -- especially if the source was automatically generated
1342 -- and compiled. Using >= is slightly unsafe, but it matches
1343 -- make's behaviour.
1346 = case lookupUFM hpt (ms_mod_name ms) of
1347 Just hmi | Just l <- hm_linkable hmi ->
1348 not (isObjectLinkable l) &&
1349 linkableTime l >= ms_hs_date ms
1352 ms_allimps :: ModSummary -> [ModuleName]
1353 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
1355 -- -----------------------------------------------------------------------------
1357 -- | Prune the HomePackageTable
1359 -- Before doing an upsweep, we can throw away:
1361 -- - For non-stable modules:
1362 -- - all ModDetails, all linked code
1363 -- - all unlinked code that is out of date with respect to
1366 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
1367 -- space at the end of the upsweep, because the topmost ModDetails of the
1368 -- old HPT holds on to the entire type environment from the previous
1371 pruneHomePackageTable
1374 -> ([ModuleName],[ModuleName])
1377 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
1380 | is_stable modl = hmi'
1381 | otherwise = hmi'{ hm_details = emptyModDetails }
1383 modl = moduleName (mi_module (hm_iface hmi))
1384 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1385 = hmi{ hm_linkable = Nothing }
1388 where ms = expectJust "prune" (lookupUFM ms_map modl)
1390 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1392 is_stable m = m `elem` stable_obj || m `elem` stable_bco
1394 -- -----------------------------------------------------------------------------
1396 -- Return (names of) all those in modsDone who are part of a cycle
1397 -- as defined by theGraph.
1398 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1399 findPartiallyCompletedCycles modsDone theGraph
1403 chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
1404 chew ((CyclicSCC vs):rest)
1405 = let names_in_this_cycle = nub (map ms_mod vs)
1407 = nub ([done | done <- modsDone,
1408 done `elem` names_in_this_cycle])
1409 chewed_rest = chew rest
1411 if notNull mods_in_this_cycle
1412 && length mods_in_this_cycle < length names_in_this_cycle
1413 then mods_in_this_cycle ++ chewed_rest
1416 -- -----------------------------------------------------------------------------
1420 -- This is where we compile each module in the module graph, in a pass
1421 -- from the bottom to the top of the graph.
1423 -- There better had not be any cyclic groups here -- we check for them.
1427 WarnErrLogger -- ^ Called to print warnings and errors.
1428 -> HscEnv -- ^ Includes initially-empty HPT
1429 -> HomePackageTable -- ^ HPT from last time round (pruned)
1430 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1431 -> IO () -- ^ How to clean up unwanted tmp files
1432 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1434 HscEnv, -- With an updated HPT
1435 [ModSummary]) -- Mods which succeeded
1437 upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do
1438 (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
1439 return (res, hsc_env, reverse done)
1442 upsweep' hsc_env _old_hpt done
1444 = return (Succeeded, hsc_env, done)
1446 upsweep' hsc_env _old_hpt done
1447 (CyclicSCC ms:_) _ _
1448 = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1449 return (Failed, hsc_env, done)
1451 upsweep' hsc_env old_hpt done
1452 (AcyclicSCC mod:mods) mod_index nmods
1453 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1454 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1455 -- (moduleEnvElts (hsc_HPT hsc_env)))
1458 <- handleSourceError
1459 (\err -> do logger (Just err); return Nothing) $ do
1460 mod_info <- upsweep_mod hsc_env old_hpt stable_mods
1462 logger Nothing -- log warnings
1463 return (Just mod_info)
1465 liftIO cleanup -- Remove unwanted tmp files between compilations
1468 Nothing -> return (Failed, hsc_env, done)
1470 let this_mod = ms_mod_name mod
1472 -- Add new info to hsc_env
1473 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1474 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1476 -- Space-saving: delete the old HPT entry
1477 -- for mod BUT if mod is a hs-boot
1478 -- node, don't delete it. For the
1479 -- interface, the HPT entry is probaby for the
1480 -- main Haskell source file. Deleting it
1481 -- would force the real module to be recompiled
1483 old_hpt1 | isBootSummary mod = old_hpt
1484 | otherwise = delFromUFM old_hpt this_mod
1488 -- fixup our HomePackageTable after we've finished compiling
1489 -- a mutually-recursive loop. See reTypecheckLoop, below.
1490 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
1492 upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
1494 -- | Compile a single module. Always produce a Linkable for it if
1495 -- successful. If no compilation happened, return the old Linkable.
1496 upsweep_mod :: GhcMonad m =>
1499 -> ([ModuleName],[ModuleName])
1501 -> Int -- index of module
1502 -> Int -- total number of modules
1505 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1507 this_mod_name = ms_mod_name summary
1508 this_mod = ms_mod summary
1509 mb_obj_date = ms_obj_date summary
1510 obj_fn = ml_obj_file (ms_location summary)
1511 hs_date = ms_hs_date summary
1513 is_stable_obj = this_mod_name `elem` stable_obj
1514 is_stable_bco = this_mod_name `elem` stable_bco
1516 old_hmi = lookupUFM old_hpt this_mod_name
1518 -- We're using the dflags for this module now, obtained by
1519 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1520 dflags = ms_hspp_opts summary
1521 prevailing_target = hscTarget (hsc_dflags hsc_env)
1522 local_target = hscTarget dflags
1524 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
1525 -- we don't do anything dodgy: these should only work to change
1526 -- from -fvia-C to -fasm and vice-versa, otherwise we could
1527 -- end up trying to link object code to byte code.
1528 target = if prevailing_target /= local_target
1529 && (not (isObjectTarget prevailing_target)
1530 || not (isObjectTarget local_target))
1531 then prevailing_target
1534 -- store the corrected hscTarget into the summary
1535 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1537 -- The old interface is ok if
1538 -- a) we're compiling a source file, and the old HPT
1539 -- entry is for a source file
1540 -- b) we're compiling a hs-boot file
1541 -- Case (b) allows an hs-boot file to get the interface of its
1542 -- real source file on the second iteration of the compilation
1543 -- manager, but that does no harm. Otherwise the hs-boot file
1544 -- will always be recompiled
1549 Just hm_info | isBootSummary summary -> Just iface
1550 | not (mi_boot iface) -> Just iface
1551 | otherwise -> Nothing
1553 iface = hm_iface hm_info
1555 compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo
1556 compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
1558 compile_it_discard_iface :: GhcMonad m =>
1559 Maybe Linkable -> m HomeModInfo
1560 compile_it_discard_iface
1561 = compile hsc_env summary' mod_index nmods Nothing
1567 -- Regardless of whether we're generating object code or
1568 -- byte code, we can always use an existing object file
1569 -- if it is *stable* (see checkStability).
1570 | is_stable_obj, isJust old_hmi ->
1571 let Just hmi = old_hmi in
1573 -- object is stable, and we have an entry in the
1574 -- old HPT: nothing to do
1576 | is_stable_obj, isNothing old_hmi -> do
1577 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1578 (expectJust "upsweep1" mb_obj_date)
1579 compile_it (Just linkable)
1580 -- object is stable, but we need to load the interface
1581 -- off disk to make a HMI.
1585 ASSERT(isJust old_hmi) -- must be in the old_hpt
1586 let Just hmi = old_hmi in
1588 -- BCO is stable: nothing to do
1590 | Just hmi <- old_hmi,
1591 Just l <- hm_linkable hmi, not (isObjectLinkable l),
1592 linkableTime l >= ms_hs_date summary ->
1594 -- we have an old BCO that is up to date with respect
1595 -- to the source: do a recompilation check as normal.
1599 -- no existing code at all: we must recompile.
1601 -- When generating object code, if there's an up-to-date
1602 -- object file on the disk, then we can use it.
1603 -- However, if the object file is new (compared to any
1604 -- linkable we had from a previous compilation), then we
1605 -- must discard any in-memory interface, because this
1606 -- means the user has compiled the source file
1607 -- separately and generated a new interface, that we must
1608 -- read from the disk.
1610 obj | isObjectTarget obj,
1611 Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1614 | Just l <- hm_linkable hmi,
1615 isObjectLinkable l && linkableTime l == obj_date
1616 -> compile_it (Just l)
1618 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1619 compile_it_discard_iface (Just linkable)
1626 -- Filter modules in the HPT
1627 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1628 retainInTopLevelEnvs keep_these hpt
1629 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1631 , let mb_mod_info = lookupUFM hpt mod
1632 , isJust mb_mod_info ]
1634 -- ---------------------------------------------------------------------------
1635 -- Typecheck module loops
1638 See bug #930. This code fixes a long-standing bug in --make. The
1639 problem is that when compiling the modules *inside* a loop, a data
1640 type that is only defined at the top of the loop looks opaque; but
1641 after the loop is done, the structure of the data type becomes
1644 The difficulty is then that two different bits of code have
1645 different notions of what the data type looks like.
1647 The idea is that after we compile a module which also has an .hs-boot
1648 file, we re-generate the ModDetails for each of the modules that
1649 depends on the .hs-boot file, so that everyone points to the proper
1650 TyCons, Ids etc. defined by the real module, not the boot module.
1651 Fortunately re-generating a ModDetails from a ModIface is easy: the
1652 function TcIface.typecheckIface does exactly that.
1654 Picking the modules to re-typecheck is slightly tricky. Starting from
1655 the module graph consisting of the modules that have already been
1656 compiled, we reverse the edges (so they point from the imported module
1657 to the importing module), and depth-first-search from the .hs-boot
1658 node. This gives us all the modules that depend transitively on the
1659 .hs-boot module, and those are exactly the modules that we need to
1662 Following this fix, GHC can compile itself with --make -O2.
1665 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1666 reTypecheckLoop hsc_env ms graph
1667 | not (isBootSummary ms) &&
1668 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
1670 let mss = reachableBackwards (ms_mod_name ms) graph
1671 non_boot = filter (not.isBootSummary) mss
1672 debugTraceMsg (hsc_dflags hsc_env) 2 $
1673 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
1674 typecheckLoop hsc_env (map ms_mod_name non_boot)
1678 this_mod = ms_mod ms
1680 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
1681 typecheckLoop hsc_env mods = do
1683 fixIO $ \new_hpt -> do
1684 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1685 mds <- initIfaceCheck new_hsc_env $
1686 mapM (typecheckIface . hm_iface) hmis
1687 let new_hpt = addListToUFM old_hpt
1688 (zip mods [ hmi{ hm_details = details }
1689 | (hmi,details) <- zip hmis mds ])
1691 return hsc_env{ hsc_HPT = new_hpt }
1693 old_hpt = hsc_HPT hsc_env
1694 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
1696 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1697 reachableBackwards mod summaries
1698 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
1699 where -- the rest just sets up the graph:
1700 (graph, lookup_node) = moduleGraphNodes False summaries
1701 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1703 -- ---------------------------------------------------------------------------
1704 -- Topological sort of the module graph
1706 type SummaryNode = (ModSummary, Int, [Int])
1709 :: Bool -- Drop hi-boot nodes? (see below)
1713 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1714 -- The resulting list of strongly-connected-components is in topologically
1715 -- sorted order, starting with the module(s) at the bottom of the
1716 -- dependency graph (ie compile them first) and ending with the ones at
1719 -- Drop hi-boot nodes (first boolean arg)?
1721 -- False: treat the hi-boot summaries as nodes of the graph,
1722 -- so the graph must be acyclic
1724 -- True: eliminate the hi-boot nodes, and instead pretend
1725 -- the a source-import of Foo is an import of Foo
1726 -- The resulting graph has no hi-boot nodes, but can be cyclic
1728 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
1729 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1731 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
1733 initial_graph = case mb_root_mod of
1736 -- restrict the graph to just those modules reachable from
1737 -- the specified module. We do this by building a graph with
1738 -- the full set of nodes, and determining the reachable set from
1739 -- the specified node.
1740 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
1741 | otherwise = ghcError (ProgramError "module does not exist")
1742 in graphFromEdgedVertices (seq root (reachableG graph root))
1744 summaryNodeKey :: SummaryNode -> Int
1745 summaryNodeKey (_, k, _) = k
1747 summaryNodeSummary :: SummaryNode -> ModSummary
1748 summaryNodeSummary (s, _, _) = s
1750 moduleGraphNodes :: Bool -> [ModSummary]
1751 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1752 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
1754 numbered_summaries = zip summaries [1..]
1756 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1757 lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
1759 lookup_key :: HscSource -> ModuleName -> Maybe Int
1760 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1762 node_map :: NodeMap SummaryNode
1763 node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
1764 | node@(s, _, _) <- nodes ]
1766 -- We use integers as the keys for the SCC algorithm
1767 nodes :: [SummaryNode]
1768 nodes = [ (s, key, out_keys)
1769 | (s, key) <- numbered_summaries
1770 -- Drop the hi-boot ones if told to do so
1771 , not (isBootSummary s && drop_hs_boot_nodes)
1772 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1773 out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
1774 (-- see [boot-edges] below
1775 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1777 else case lookup_key HsBootFile (ms_mod_name s) of
1781 -- [boot-edges] if this is a .hs and there is an equivalent
1782 -- .hs-boot, add a link from the former to the latter. This
1783 -- has the effect of detecting bogus cases where the .hs-boot
1784 -- depends on the .hs, by introducing a cycle. Additionally,
1785 -- it ensures that we will always process the .hs-boot before
1786 -- the .hs, and so the HomePackageTable will always have the
1787 -- most up to date information.
1789 -- Drop hs-boot nodes by using HsSrcFile as the key
1790 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1791 | otherwise = HsBootFile
1793 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1794 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1795 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1796 -- the IsBootInterface parameter True; else False
1799 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1800 type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
1802 msKey :: ModSummary -> NodeKey
1803 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1805 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1806 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1808 nodeMapElts :: NodeMap a -> [a]
1809 nodeMapElts = eltsFM
1811 -- | If there are {-# SOURCE #-} imports between strongly connected
1812 -- components in the topological sort, then those imports can
1813 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1814 -- were necessary, then the edge would be part of a cycle.
1815 warnUnnecessarySourceImports :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m ()
1816 warnUnnecessarySourceImports dflags sccs =
1817 liftIO $ printBagOfWarnings dflags (listToBag (concatMap (check.flattenSCC) sccs))
1819 let mods_in_this_cycle = map ms_mod_name ms in
1820 [ warn i | m <- ms, i <- ms_srcimps m,
1821 unLoc i `notElem` mods_in_this_cycle ]
1823 warn :: Located ModuleName -> WarnMsg
1826 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1827 <+> quotes (ppr mod))
1829 -----------------------------------------------------------------------------
1830 -- Downsweep (dependency analysis)
1832 -- Chase downwards from the specified root set, returning summaries
1833 -- for all home modules encountered. Only follow source-import
1836 -- We pass in the previous collection of summaries, which is used as a
1837 -- cache to avoid recalculating a module summary if the source is
1840 -- The returned list of [ModSummary] nodes has one node for each home-package
1841 -- module, plus one for any hs-boot files. The imports of these nodes
1842 -- are all there, including the imports of non-home-package modules.
1844 downsweep :: GhcMonad m =>
1846 -> [ModSummary] -- Old summaries
1847 -> [ModuleName] -- Ignore dependencies on these; treat
1848 -- them as if they were package modules
1849 -> Bool -- True <=> allow multiple targets to have
1850 -- the same module name; this is
1851 -- very useful for ghc -M
1853 -- The elts of [ModSummary] all have distinct
1854 -- (Modules, IsBoot) identifiers, unless the Bool is true
1855 -- in which case there can be repeats
1856 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1857 = do -- catch error messages and return them
1858 --handleErrMsg -- should be covered by GhcMonad now
1859 -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1860 rootSummaries <- mapM getRootSummary roots
1861 let root_map = mkRootMap rootSummaries
1862 checkDuplicates root_map
1863 summs <- loop (concatMap msDeps rootSummaries) root_map
1866 roots = hsc_targets hsc_env
1868 old_summary_map :: NodeMap ModSummary
1869 old_summary_map = mkNodeMap old_summaries
1871 getRootSummary :: GhcMonad m => Target -> m ModSummary
1872 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1873 = do exists <- liftIO $ doesFileExist file
1875 then summariseFile hsc_env old_summaries file mb_phase
1876 obj_allowed maybe_buf
1877 else throwErrMsg $ mkPlainErrMsg noSrcSpan $
1878 text "can't find file:" <+> text file
1879 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1880 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1881 (L rootLoc modl) obj_allowed
1883 case maybe_summary of
1884 Nothing -> packageModErr modl
1887 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1889 -- In a root module, the filename is allowed to diverge from the module
1890 -- name, so we have to check that there aren't multiple root files
1891 -- defining the same module (otherwise the duplicates will be silently
1892 -- ignored, leading to confusing behaviour).
1893 checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m ()
1894 checkDuplicates root_map
1895 | allow_dup_roots = return ()
1896 | null dup_roots = return ()
1897 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1899 dup_roots :: [[ModSummary]] -- Each at least of length 2
1900 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1902 loop :: GhcMonad m =>
1903 [(Located ModuleName,IsBootInterface)]
1904 -- Work list: process these modules
1905 -> NodeMap [ModSummary]
1906 -- Visited set; the range is a list because
1907 -- the roots can have the same module names
1908 -- if allow_dup_roots is True
1910 -- The result includes the worklist, except
1911 -- for those mentioned in the visited set
1912 loop [] done = return (concat (nodeMapElts done))
1913 loop ((wanted_mod, is_boot) : ss) done
1914 | Just summs <- lookupFM done key
1915 = if isSingleton summs then
1918 do { liftIO $ multiRootsErr summs; return [] }
1920 = do mb_s <- summariseModule hsc_env old_summary_map
1921 is_boot wanted_mod True
1924 Nothing -> loop ss done
1925 Just s -> loop (msDeps s ++ ss) (addToFM done key [s])
1927 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1929 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1930 mkRootMap summaries = addListToFM_C (++) emptyFM
1931 [ (msKey s, [s]) | s <- summaries ]
1933 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1934 -- (msDeps s) returns the dependencies of the ModSummary s.
1935 -- A wrinkle is that for a {-# SOURCE #-} import we return
1936 -- *both* the hs-boot file
1937 -- *and* the source file
1938 -- as "dependencies". That ensures that the list of all relevant
1939 -- modules always contains B.hs if it contains B.hs-boot.
1940 -- Remember, this pass isn't doing the topological sort. It's
1941 -- just gathering the list of all relevant ModSummaries
1943 concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1944 ++ [ (m,False) | m <- ms_imps s ]
1946 -----------------------------------------------------------------------------
1947 -- Summarising modules
1949 -- We have two types of summarisation:
1951 -- * Summarise a file. This is used for the root module(s) passed to
1952 -- cmLoadModules. The file is read, and used to determine the root
1953 -- module name. The module name may differ from the filename.
1955 -- * Summarise a module. We are given a module name, and must provide
1956 -- a summary. The finder is used to locate the file in which the module
1962 -> [ModSummary] -- old summaries
1963 -> FilePath -- source file name
1964 -> Maybe Phase -- start phase
1965 -> Bool -- object code allowed?
1966 -> Maybe (StringBuffer,ClockTime)
1969 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1970 -- we can use a cached summary if one is available and the
1971 -- source file hasn't changed, But we have to look up the summary
1972 -- by source file, rather than module name as we do in summarise.
1973 | Just old_summary <- findSummaryBySourceFile old_summaries file
1975 let location = ms_location old_summary
1977 -- return the cached summary if the source didn't change
1978 src_timestamp <- case maybe_buf of
1979 Just (_,t) -> return t
1980 Nothing -> liftIO $ getModificationTime file
1981 -- The file exists; we checked in getRootSummary above.
1982 -- If it gets removed subsequently, then this
1983 -- getModificationTime may fail, but that's the right
1986 if ms_hs_date old_summary == src_timestamp
1987 then do -- update the object-file timestamp
1989 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1990 || obj_allowed -- bug #1205
1991 then liftIO $ getObjTimestamp location False
1993 return old_summary{ ms_obj_date = obj_timestamp }
2001 let dflags = hsc_dflags hsc_env
2003 (dflags', hspp_fn, buf)
2004 <- preprocessFile hsc_env file mb_phase maybe_buf
2006 (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file
2008 -- Make a ModLocation for this file
2009 location <- liftIO $ mkHomeModLocation dflags mod_name file
2011 -- Tell the Finder cache where it is, so that subsequent calls
2012 -- to findModule will find it, even if it's not on any search path
2013 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
2015 src_timestamp <- case maybe_buf of
2016 Just (_,t) -> return t
2017 Nothing -> liftIO $ getModificationTime file
2018 -- getMofificationTime may fail
2020 -- when the user asks to load a source file by name, we only
2021 -- use an object file if -fobject-code is on. See #1205.
2023 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2024 || obj_allowed -- bug #1205
2025 then liftIO $ modificationTimeIfExists (ml_obj_file location)
2028 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
2029 ms_location = location,
2030 ms_hspp_file = hspp_fn,
2031 ms_hspp_opts = dflags',
2032 ms_hspp_buf = Just buf,
2033 ms_srcimps = srcimps, ms_imps = the_imps,
2034 ms_hs_date = src_timestamp,
2035 ms_obj_date = obj_timestamp })
2037 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
2038 findSummaryBySourceFile summaries file
2039 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
2040 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
2044 -- Summarise a module, and pick up source and timestamp.
2048 -> NodeMap ModSummary -- Map of old summaries
2049 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
2050 -> Located ModuleName -- Imported module to be summarised
2051 -> Bool -- object code allowed?
2052 -> Maybe (StringBuffer, ClockTime)
2053 -> [ModuleName] -- Modules to exclude
2054 -> m (Maybe ModSummary) -- Its new summary
2056 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
2057 obj_allowed maybe_buf excl_mods
2058 | wanted_mod `elem` excl_mods
2061 | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
2062 = do -- Find its new timestamp; all the
2063 -- ModSummaries in the old map have valid ml_hs_files
2064 let location = ms_location old_summary
2065 src_fn = expectJust "summariseModule" (ml_hs_file location)
2067 -- check the modification time on the source file, and
2068 -- return the cached summary if it hasn't changed. If the
2069 -- file has disappeared, we need to call the Finder again.
2071 Just (_,t) -> check_timestamp old_summary location src_fn t
2073 m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
2075 Right t -> check_timestamp old_summary location src_fn t
2076 Left e | isDoesNotExistError e -> find_it
2077 | otherwise -> liftIO $ ioError e
2079 | otherwise = find_it
2081 dflags = hsc_dflags hsc_env
2083 hsc_src = if is_boot then HsBootFile else HsSrcFile
2085 check_timestamp old_summary location src_fn src_timestamp
2086 | ms_hs_date old_summary == src_timestamp = do
2087 -- update the object-file timestamp
2088 obj_timestamp <- liftIO $
2089 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2090 || obj_allowed -- bug #1205
2091 then getObjTimestamp location is_boot
2093 return (Just old_summary{ ms_obj_date = obj_timestamp })
2095 -- source changed: re-summarise.
2096 new_summary location (ms_mod old_summary) src_fn src_timestamp
2099 -- Don't use the Finder's cache this time. If the module was
2100 -- previously a package module, it may have now appeared on the
2101 -- search path, so we want to consider it to be a home module. If
2102 -- the module was previously a home module, it may have moved.
2103 liftIO $ uncacheModule hsc_env wanted_mod
2104 found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
2107 | isJust (ml_hs_file location) ->
2109 just_found location mod
2111 -- Drop external-pkg
2112 ASSERT(modulePackageId mod /= thisPackage dflags)
2115 err -> liftIO $ noModError dflags loc wanted_mod err
2118 just_found location mod = do
2119 -- Adjust location to point to the hs-boot source file,
2120 -- hi file, object file, when is_boot says so
2121 let location' | is_boot = addBootSuffixLocn location
2122 | otherwise = location
2123 src_fn = expectJust "summarise2" (ml_hs_file location')
2125 -- Check that it exists
2126 -- It might have been deleted since the Finder last found it
2127 maybe_t <- liftIO $ modificationTimeIfExists src_fn
2129 Nothing -> noHsFileErr loc src_fn
2130 Just t -> new_summary location' mod src_fn t
2133 new_summary location mod src_fn src_timestamp
2135 -- Preprocess the source file and get its imports
2136 -- The dflags' contains the OPTIONS pragmas
2137 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2138 (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn
2140 when (mod_name /= wanted_mod) $
2141 throwErrMsg $ mkPlainErrMsg mod_loc $
2142 text "File name does not match module name:"
2143 $$ text "Saw:" <+> quotes (ppr mod_name)
2144 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2146 -- Find the object timestamp, and return the summary
2147 obj_timestamp <- liftIO $
2148 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2149 || obj_allowed -- bug #1205
2150 then getObjTimestamp location is_boot
2153 return (Just (ModSummary { ms_mod = mod,
2154 ms_hsc_src = hsc_src,
2155 ms_location = location,
2156 ms_hspp_file = hspp_fn,
2157 ms_hspp_opts = dflags',
2158 ms_hspp_buf = Just buf,
2159 ms_srcimps = srcimps,
2161 ms_hs_date = src_timestamp,
2162 ms_obj_date = obj_timestamp }))
2165 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
2166 getObjTimestamp location is_boot
2167 = if is_boot then return Nothing
2168 else modificationTimeIfExists (ml_obj_file location)
2171 preprocessFile :: GhcMonad m =>
2174 -> Maybe Phase -- ^ Starting phase
2175 -> Maybe (StringBuffer,ClockTime)
2176 -> m (DynFlags, FilePath, StringBuffer)
2177 preprocessFile hsc_env src_fn mb_phase Nothing
2179 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2180 buf <- liftIO $ hGetStringBuffer hspp_fn
2181 return (dflags', hspp_fn, buf)
2183 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2185 let dflags = hsc_dflags hsc_env
2186 -- case we bypass the preprocessing stage?
2188 local_opts = getOptions dflags buf src_fn
2190 (dflags', leftovers, warns)
2191 <- parseDynamicFlags dflags local_opts
2192 liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
2193 liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions
2197 | Just (Unlit _) <- mb_phase = True
2198 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2199 -- note: local_opts is only required if there's no Unlit phase
2200 | dopt Opt_Cpp dflags' = True
2201 | dopt Opt_Pp dflags' = True
2204 when needs_preprocessing $
2205 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
2207 return (dflags', src_fn, buf)
2210 -----------------------------------------------------------------------------
2212 -----------------------------------------------------------------------------
2214 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
2215 -- ToDo: we don't have a proper line number for this error
2216 noModError dflags loc wanted_mod err
2217 = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
2219 noHsFileErr :: SrcSpan -> String -> a
2220 noHsFileErr loc path
2221 = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
2223 packageModErr :: ModuleName -> a
2225 = throwErrMsg $ mkPlainErrMsg noSrcSpan $
2226 text "module" <+> quotes (ppr mod) <+> text "is a package module"
2228 multiRootsErr :: [ModSummary] -> IO ()
2229 multiRootsErr [] = panic "multiRootsErr"
2230 multiRootsErr summs@(summ1:_)
2231 = throwErrMsg $ mkPlainErrMsg noSrcSpan $
2232 text "module" <+> quotes (ppr mod) <+>
2233 text "is defined in multiple files:" <+>
2234 sep (map text files)
2237 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2239 cyclicModuleErr :: [ModSummary] -> SDoc
2241 = hang (ptext (sLit "Module imports form a cycle for modules:"))
2242 2 (vcat (map show_one ms))
2244 show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
2245 nest 2 $ ptext (sLit "imports:") <+>
2246 (pp_imps HsBootFile (ms_srcimps ms)
2247 $$ pp_imps HsSrcFile (ms_imps ms))]
2248 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
2249 pp_imps src mods = fsep (map (show_mod src) mods)
2252 -- | Inform GHC that the working directory has changed. GHC will flush
2253 -- its cache of module locations, since it may no longer be valid.
2254 -- Note: if you change the working directory, you should also unload
2255 -- the current program (set targets to empty, followed by load).
2256 workingDirectoryChanged :: GhcMonad m => m ()
2257 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
2259 -- -----------------------------------------------------------------------------
2260 -- inspecting the session
2262 -- | Get the module dependency graph.
2263 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
2264 getModuleGraph = liftM hsc_mod_graph getSession
2266 -- | Return @True@ <==> module is loaded.
2267 isLoaded :: GhcMonad m => ModuleName -> m Bool
2268 isLoaded m = withSession $ \hsc_env ->
2269 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
2271 -- | Return the bindings for the current interactive session.
2272 getBindings :: GhcMonad m => m [TyThing]
2273 getBindings = withSession $ \hsc_env ->
2274 -- we have to implement the shadowing behaviour of ic_tmp_ids here
2275 -- (see InteractiveContext) and the quickest way is to use an OccEnv.
2277 tmp_ids = ic_tmp_ids (hsc_IC hsc_env)
2278 filtered = foldr f (const []) tmp_ids emptyUniqSet
2280 | uniq `elementOfUniqSet` set = rest set
2281 | otherwise = AnId id : rest (addOneToUniqSet set uniq)
2282 where uniq = getUnique (nameOccName (idName id))
2286 getPrintUnqual :: GhcMonad m => m PrintUnqualified
2287 getPrintUnqual = withSession $ \hsc_env ->
2288 return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
2290 -- | Container for information about a 'Module'.
2291 data ModuleInfo = ModuleInfo {
2292 minf_type_env :: TypeEnv,
2293 minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
2294 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
2295 minf_instances :: [Instance]
2297 ,minf_modBreaks :: ModBreaks
2299 -- ToDo: this should really contain the ModIface too
2301 -- We don't want HomeModInfo here, because a ModuleInfo applies
2302 -- to package modules too.
2304 -- | Request information about a loaded 'Module'
2305 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
2306 getModuleInfo mdl = withSession $ \hsc_env -> do
2307 let mg = hsc_mod_graph hsc_env
2308 if mdl `elem` map ms_mod mg
2309 then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
2311 {- if isHomeModule (hsc_dflags hsc_env) mdl
2313 else -} liftIO $ getPackageModuleInfo hsc_env mdl
2314 -- getPackageModuleInfo will attempt to find the interface, so
2315 -- we don't want to call it for a home module, just in case there
2316 -- was a problem loading the module and the interface doesn't
2317 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
2319 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
2321 getPackageModuleInfo hsc_env mdl = do
2322 (_msgs, mb_avails) <- getModuleExports hsc_env mdl
2324 Nothing -> return Nothing
2326 eps <- readIORef (hsc_EPS hsc_env)
2328 names = availsToNameSet avails
2330 tys = [ ty | name <- concatMap availNames avails,
2331 Just ty <- [lookupTypeEnv pte name] ]
2333 return (Just (ModuleInfo {
2334 minf_type_env = mkTypeEnv tys,
2335 minf_exports = names,
2336 minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
2337 minf_instances = error "getModuleInfo: instances for package module unimplemented",
2338 minf_modBreaks = emptyModBreaks
2341 getPackageModuleInfo _hsc_env _mdl = do
2342 -- bogusly different for non-GHCI (ToDo)
2346 getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
2347 getHomeModuleInfo hsc_env mdl =
2348 case lookupUFM (hsc_HPT hsc_env) mdl of
2349 Nothing -> return Nothing
2351 let details = hm_details hmi
2352 return (Just (ModuleInfo {
2353 minf_type_env = md_types details,
2354 minf_exports = availsToNameSet (md_exports details),
2355 minf_rdr_env = mi_globals $! hm_iface hmi,
2356 minf_instances = md_insts details
2358 ,minf_modBreaks = getModBreaks hmi
2362 -- | The list of top-level entities defined in a module
2363 modInfoTyThings :: ModuleInfo -> [TyThing]
2364 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
2366 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
2367 modInfoTopLevelScope minf
2368 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
2370 modInfoExports :: ModuleInfo -> [Name]
2371 modInfoExports minf = nameSetToList $! minf_exports minf
2373 -- | Returns the instances defined by the specified module.
2374 -- Warning: currently unimplemented for package modules.
2375 modInfoInstances :: ModuleInfo -> [Instance]
2376 modInfoInstances = minf_instances
2378 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
2379 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
2381 mkPrintUnqualifiedForModule :: GhcMonad m =>
2383 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
2384 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
2385 return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
2387 modInfoLookupName :: GhcMonad m =>
2389 -> m (Maybe TyThing) -- XXX: returns a Maybe X
2390 modInfoLookupName minf name = withSession $ \hsc_env -> do
2391 case lookupTypeEnv (minf_type_env minf) name of
2392 Just tyThing -> return (Just tyThing)
2394 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2395 return $! lookupType (hsc_dflags hsc_env)
2396 (hsc_HPT hsc_env) (eps_PTE eps) name
2399 modInfoModBreaks :: ModuleInfo -> ModBreaks
2400 modInfoModBreaks = minf_modBreaks
2403 isDictonaryId :: Id -> Bool
2405 = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
2407 -- | Looks up a global name: that is, any top-level name in any
2408 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
2409 -- the interactive context, and therefore does not require a preceding
2411 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
2412 lookupGlobalName name = withSession $ \hsc_env -> do
2413 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2414 return $! lookupType (hsc_dflags hsc_env)
2415 (hsc_HPT hsc_env) (eps_PTE eps) name
2418 -- | get the GlobalRdrEnv for a session
2419 getGRE :: GhcMonad m => m GlobalRdrEnv
2420 getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
2423 -- -----------------------------------------------------------------------------
2424 -- Misc exported utils
2426 dataConType :: DataCon -> Type
2427 dataConType dc = idType (dataConWrapId dc)
2429 -- | print a 'NamedThing', adding parentheses if the name is an operator.
2430 pprParenSymName :: NamedThing a => a -> SDoc
2431 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
2433 -- ----------------------------------------------------------------------------
2438 -- - Data and Typeable instances for HsSyn.
2440 -- ToDo: check for small transformations that happen to the syntax in
2441 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
2443 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
2444 -- to get from TyCons, Ids etc. to TH syntax (reify).
2446 -- :browse will use either lm_toplev or inspect lm_interface, depending
2447 -- on whether the module is interpreted or not.
2451 -- Extract the filename, stringbuffer content and dynflags associed to a module
2453 -- XXX: Explain pre-conditions
2454 getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
2455 getModuleSourceAndFlags mod = do
2456 m <- getModSummary (moduleName mod)
2457 case ml_hs_file $ ms_location m of
2458 Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
2459 Just sourceFile -> do
2460 source <- liftIO $ hGetStringBuffer sourceFile
2461 return (sourceFile, source, ms_hspp_opts m)
2464 -- | Return module source as token stream, including comments.
2466 -- The module must be in the module graph and its source must be available.
2467 -- Throws a 'HscTypes.SourceError' on parse error.
2468 getTokenStream :: GhcMonad m => Module -> m [Located Token]
2469 getTokenStream mod = do
2470 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2471 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2472 case lexTokenStream source startLoc flags of
2473 POk _ ts -> return ts
2474 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2476 -- | Give even more information on the source than 'getTokenStream'
2477 -- This function allows reconstructing the source completely with
2478 -- 'showRichTokenStream'.
2479 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
2480 getRichTokenStream mod = do
2481 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2482 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2483 case lexTokenStream source startLoc flags of
2484 POk _ ts -> return $ addSourceToTokens startLoc source ts
2485 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2487 -- | Given a source location and a StringBuffer corresponding to this
2488 -- location, return a rich token stream with the source associated to the
2490 addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
2491 -> [(Located Token, String)]
2492 addSourceToTokens _ _ [] = []
2493 addSourceToTokens loc buf (t@(L span _) : ts)
2494 | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
2495 | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
2497 (newLoc, newBuf, str) = go "" loc buf
2498 start = srcSpanStart span
2499 end = srcSpanEnd span
2500 go acc loc buf | loc < start = go acc nLoc nBuf
2501 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
2502 | otherwise = (loc, buf, reverse acc)
2503 where (ch, nBuf) = nextChar buf
2504 nLoc = advanceSrcLoc loc ch
2507 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
2508 -- return source code almost identical to the original code (except for
2509 -- insignificant whitespace.)
2510 showRichTokenStream :: [(Located Token, String)] -> String
2511 showRichTokenStream ts = go startLoc ts ""
2512 where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
2513 startLoc = mkSrcLoc sourceFile 0 0
2515 go loc ((L span _, str):ts)
2516 | not (isGoodSrcSpan span) = go loc ts
2517 | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
2520 | otherwise = ((replicate (tokLine - locLine) '\n') ++)
2521 . ((replicate tokCol ' ') ++)
2524 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
2525 (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
2526 tokEnd = srcSpanEnd span
2528 -- -----------------------------------------------------------------------------
2529 -- Interactive evaluation
2531 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
2532 -- filesystem and package database to find the corresponding 'Module',
2533 -- using the algorithm that is used for an @import@ declaration.
2534 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2535 findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX
2537 dflags = hsc_dflags hsc_env
2538 hpt = hsc_HPT hsc_env
2539 this_pkg = thisPackage dflags
2541 case lookupUFM hpt mod_name of
2542 Just mod_info -> return (mi_module (hm_iface mod_info))
2543 _not_a_home_module -> do
2544 res <- findImportedModule hsc_env mod_name maybe_pkg
2546 Found _ m | modulePackageId m /= this_pkg -> return m
2547 | otherwise -> ghcError (CmdLineError (showSDoc $
2548 text "module" <+> quotes (ppr (moduleName m)) <+>
2549 text "is not loaded"))
2550 err -> let msg = cannotFindModule dflags mod_name err in
2551 ghcError (CmdLineError (showSDoc msg))
2554 getHistorySpan :: GhcMonad m => History -> m SrcSpan
2555 getHistorySpan h = withSession $ \hsc_env ->
2556 return$ InteractiveEval.getHistorySpan hsc_env h
2558 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
2559 obtainTermFromVal bound force ty a =
2560 withSession $ \hsc_env ->
2561 liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
2563 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
2564 obtainTermFromId bound force id =
2565 withSession $ \hsc_env ->
2566 liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
projects / ghc-hetmet.git / blob