1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow, 2005
7 -- -----------------------------------------------------------------------------
13 defaultCleanupHandler,
17 -- * Flags and settings
18 DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
25 Target(..), TargetId(..), Phase,
32 -- * Extending the program scope
33 extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
34 setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
35 extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
36 setGlobalTypeScope, -- :: Session -> [Id] -> IO ()
38 -- * Loading\/compiling the program
40 load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
41 workingDirectoryChanged,
42 checkModule, CheckedModule(..),
43 TypecheckedSource, ParsedSource, RenamedSource,
45 -- * Inspecting the module structure of the program
46 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
51 -- * Inspecting modules
56 modInfoPrintUnqualified,
59 modInfoIsExportedName,
64 PrintUnqualified, alwaysQualify,
66 -- * Interactive evaluation
67 getBindings, getPrintUnqual,
70 setContext, getContext,
85 -- * Abstract syntax elements
91 Module, mkModule, pprModule, moduleName, modulePackageId,
92 ModuleName, mkModuleName, moduleNameString,
96 nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
102 isImplicitId, isDeadBinder,
103 isExportedId, isLocalId, isGlobalId,
105 isPrimOpId, isFCallId, isClassOpId_maybe,
106 isDataConWorkId, idDataCon,
107 isBottomingId, isDictonaryId,
108 recordSelectorFieldLabel,
110 -- ** Type constructors
112 tyConTyVars, tyConDataCons, tyConArity,
113 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
114 synTyConDefn, synTyConRhs,
120 -- ** Data constructors
122 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
123 dataConIsInfix, isVanillaDataCon,
125 StrictnessMark(..), isMarkedStrict,
129 classMethods, classSCTheta, classTvsFds,
134 instanceDFunId, pprInstance, pprInstanceHdr,
136 -- ** Types and Kinds
137 Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
140 ThetaType, pprThetaArrow,
146 module HsSyn, -- ToDo: remove extraneous bits
150 defaultFixity, maxPrecedence,
154 -- ** Source locations
158 GhcException(..), showGhcException,
168 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
169 * we need to expose DynFlags, so should parseDynamicFlags really be
170 part of this interface?
171 * what StaticFlags should we expose, if any?
174 #include "HsVersions.h"
177 import qualified Linker
178 import Linker ( HValue, extendLinkEnv )
179 import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
180 tcRnLookupName, getModuleExports )
181 import RdrName ( plusGlobalRdrEnv, Provenance(..),
182 ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
184 import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
185 import Name ( nameOccName )
186 import Type ( tidyType )
187 import VarEnv ( emptyTidyEnv )
188 import GHC.Exts ( unsafeCoerce# )
191 import Packages ( initPackages )
192 import NameSet ( NameSet, nameSetToList, elemNameSet )
193 import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
194 globalRdrEnvElts, extendGlobalRdrEnv,
197 import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
198 pprThetaArrow, pprParendType, splitForAllTys,
200 import Id ( Id, idType, isImplicitId, isDeadBinder,
201 isExportedId, isLocalId, isGlobalId,
202 isRecordSelector, recordSelectorFieldLabel,
203 isPrimOpId, isFCallId, isClassOpId_maybe,
204 isDataConWorkId, idDataCon,
207 import TysPrim ( alphaTyVars )
208 import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
209 isPrimTyCon, isFunTyCon, tyConArity,
210 tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
211 import Class ( Class, classSCTheta, classTvsFds, classMethods )
212 import FunDeps ( pprFundeps )
213 import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
214 dataConFieldLabels, dataConStrictMarks,
215 dataConIsInfix, isVanillaDataCon )
216 import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
218 import OccName ( parenSymOcc )
219 import NameEnv ( nameEnvElts )
220 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
222 import DriverPipeline
223 import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
224 import HeaderInfo ( getImports, getOptions )
226 import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
229 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
233 import PackageConfig ( PackageId )
237 import Bag ( unitBag )
238 import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
239 mkPlainErrMsg, printBagOfErrors )
240 import qualified ErrUtils
242 import StringBuffer ( StringBuffer, hGetStringBuffer )
245 import TcType ( tcSplitSigmaTy, isDictTy )
246 import Maybes ( expectJust, mapCatMaybes )
248 import Control.Concurrent
249 import System.Directory ( getModificationTime, doesFileExist )
250 import Data.Maybe ( isJust, isNothing )
251 import Data.List ( partition, nub )
252 import qualified Data.List as List
253 import Control.Monad ( unless, when )
254 import System.Exit ( exitWith, ExitCode(..) )
255 import System.Time ( ClockTime )
256 import Control.Exception as Exception hiding (handle)
259 import System.IO.Error ( isDoesNotExistError )
260 import Prelude hiding (init)
262 #if __GLASGOW_HASKELL__ < 600
263 import System.IO as System.IO.Error ( try )
265 import System.IO.Error ( try )
268 -- -----------------------------------------------------------------------------
269 -- Exception handlers
271 -- | Install some default exception handlers and run the inner computation.
272 -- Unless you want to handle exceptions yourself, you should wrap this around
273 -- the top level of your program. The default handlers output the error
274 -- message(s) to stderr and exit cleanly.
275 defaultErrorHandler :: DynFlags -> IO a -> IO a
276 defaultErrorHandler dflags inner =
277 -- top-level exception handler: any unrecognised exception is a compiler bug.
278 handle (\exception -> do
281 -- an IO exception probably isn't our fault, so don't panic
283 fatalErrorMsg dflags (text (show exception))
284 AsyncException StackOverflow ->
285 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
287 fatalErrorMsg dflags (text (show (Panic (show exception))))
288 exitWith (ExitFailure 1)
291 -- program errors: messages with locations attached. Sometimes it is
292 -- convenient to just throw these as exceptions.
293 handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
294 exitWith (ExitFailure 1)) $
296 -- error messages propagated as exceptions
297 handleDyn (\dyn -> do
300 PhaseFailed _ code -> exitWith code
301 Interrupted -> exitWith (ExitFailure 1)
302 _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
303 exitWith (ExitFailure 1)
307 -- | Install a default cleanup handler to remove temporary files
308 -- deposited by a GHC run. This is seperate from
309 -- 'defaultErrorHandler', because you might want to override the error
310 -- handling, but still get the ordinary cleanup behaviour.
311 defaultCleanupHandler :: DynFlags -> IO a -> IO a
312 defaultCleanupHandler dflags inner =
313 -- make sure we clean up after ourselves
314 later (unless (dopt Opt_KeepTmpFiles dflags) $
315 do cleanTempFiles dflags
318 -- exceptions will be blocked while we clean the temporary files,
319 -- so there shouldn't be any difficulty if we receive further
324 -- | Initialises GHC. This must be done /once/ only. Takes the
325 -- TopDir path without the '-B' prefix.
327 init :: Maybe String -> IO ()
330 main_thread <- myThreadId
331 putMVar interruptTargetThread [main_thread]
332 installSignalHandlers
334 dflags0 <- initSysTools mbMinusB defaultDynFlags
335 writeIORef v_initDynFlags dflags0
337 -- | Initialises GHC. This must be done /once/ only. Takes the
338 -- command-line arguments. All command-line arguments which aren't
339 -- understood by GHC will be returned.
341 initFromArgs :: [String] -> IO [String]
345 where -- Grab the -B option if there is one
346 (minusB_args, argv1) = partition (prefixMatch "-B") args
347 mbMinusB | null minusB_args
350 = Just (drop 2 (last minusB_args))
352 GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
353 -- stores the DynFlags between the call to init and subsequent
354 -- calls to newSession.
356 -- | Starts a new session. A session consists of a set of loaded
357 -- modules, a set of options (DynFlags), and an interactive context.
358 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
360 newSession :: GhcMode -> IO Session
362 dflags0 <- readIORef v_initDynFlags
363 dflags <- initDynFlags dflags0
364 env <- newHscEnv dflags{ ghcMode=mode }
368 -- tmp: this breaks the abstraction, but required because DriverMkDepend
369 -- needs to call the Finder. ToDo: untangle this.
370 sessionHscEnv :: Session -> IO HscEnv
371 sessionHscEnv (Session ref) = readIORef ref
373 withSession :: Session -> (HscEnv -> IO a) -> IO a
374 withSession (Session ref) f = do h <- readIORef ref; f h
376 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
377 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
379 -- -----------------------------------------------------------------------------
382 -- | Grabs the DynFlags from the Session
383 getSessionDynFlags :: Session -> IO DynFlags
384 getSessionDynFlags s = withSession s (return . hsc_dflags)
386 -- | Updates the DynFlags in a Session
387 setSessionDynFlags :: Session -> DynFlags -> IO ()
388 setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
390 -- | If there is no -o option, guess the name of target executable
391 -- by using top-level source file name as a base.
392 guessOutputFile :: Session -> IO ()
393 guessOutputFile s = modifySession s $ \env ->
394 let dflags = hsc_dflags env
395 mod_graph = hsc_mod_graph env
396 mainModuleSrcPath, guessedName :: Maybe String
397 mainModuleSrcPath = do
398 let isMain = (== mainModIs dflags) . ms_mod
399 [ms] <- return (filter isMain mod_graph)
400 ml_hs_file (ms_location ms)
401 guessedName = fmap basenameOf mainModuleSrcPath
403 case outputFile dflags of
405 Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
407 -- -----------------------------------------------------------------------------
410 -- ToDo: think about relative vs. absolute file paths. And what
411 -- happens when the current directory changes.
413 -- | Sets the targets for this session. Each target may be a module name
414 -- or a filename. The targets correspond to the set of root modules for
415 -- the program\/library. Unloading the current program is achieved by
416 -- setting the current set of targets to be empty, followed by load.
417 setTargets :: Session -> [Target] -> IO ()
418 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
420 -- | returns the current set of targets
421 getTargets :: Session -> IO [Target]
422 getTargets s = withSession s (return . hsc_targets)
424 -- | Add another target
425 addTarget :: Session -> Target -> IO ()
427 = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
430 removeTarget :: Session -> TargetId -> IO ()
431 removeTarget s target_id
432 = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
434 filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
436 -- Attempts to guess what Target a string refers to. This function implements
437 -- the --make/GHCi command-line syntax for filenames:
439 -- - if the string looks like a Haskell source filename, then interpret
441 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
443 -- - otherwise interpret the string as a module name
445 guessTarget :: String -> Maybe Phase -> IO Target
446 guessTarget file (Just phase)
447 = return (Target (TargetFile file (Just phase)) Nothing)
448 guessTarget file Nothing
449 | isHaskellSrcFilename file
450 = return (Target (TargetFile file Nothing) Nothing)
452 = do exists <- doesFileExist hs_file
454 then return (Target (TargetFile hs_file Nothing) Nothing)
456 exists <- doesFileExist lhs_file
458 then return (Target (TargetFile lhs_file Nothing) Nothing)
460 return (Target (TargetModule (mkModuleName file)) Nothing)
462 hs_file = file `joinFileExt` "hs"
463 lhs_file = file `joinFileExt` "lhs"
465 -- -----------------------------------------------------------------------------
466 -- Extending the program scope
468 extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
469 extendGlobalRdrScope session rdrElts
470 = modifySession session $ \hscEnv ->
471 let global_rdr = hsc_global_rdr_env hscEnv
472 in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
474 setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
475 setGlobalRdrScope session rdrElts
476 = modifySession session $ \hscEnv ->
477 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
479 extendGlobalTypeScope :: Session -> [Id] -> IO ()
480 extendGlobalTypeScope session ids
481 = modifySession session $ \hscEnv ->
482 let global_type = hsc_global_type_env hscEnv
483 in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
485 setGlobalTypeScope :: Session -> [Id] -> IO ()
486 setGlobalTypeScope session ids
487 = modifySession session $ \hscEnv ->
488 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
490 -- -----------------------------------------------------------------------------
491 -- Loading the program
493 -- Perform a dependency analysis starting from the current targets
494 -- and update the session with the new module graph.
495 depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
496 depanal (Session ref) excluded_mods allow_dup_roots = do
497 hsc_env <- readIORef ref
499 dflags = hsc_dflags hsc_env
500 gmode = ghcMode (hsc_dflags hsc_env)
501 targets = hsc_targets hsc_env
502 old_graph = hsc_mod_graph hsc_env
504 showPass dflags "Chasing dependencies"
505 when (gmode == BatchCompile) $
506 debugTraceMsg dflags 2 (hcat [
507 text "Chasing modules from: ",
508 hcat (punctuate comma (map pprTarget targets))])
510 r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
512 Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
517 -- | The result of load.
519 = LoadOk Errors -- ^ all specified targets were loaded successfully.
520 | LoadFailed Errors -- ^ not all modules were loaded.
522 type Errors = [String]
524 data ErrMsg = ErrMsg {
525 errMsgSeverity :: Severity, -- warning, error, etc.
526 errMsgSpans :: [SrcSpan],
527 errMsgShortDoc :: Doc,
528 errMsgExtraInfo :: Doc
534 | LoadUpTo ModuleName
535 | LoadDependenciesOf ModuleName
537 -- | Try to load the program. If a Module is supplied, then just
538 -- attempt to load up to this target. If no Module is supplied,
539 -- then try to load all targets.
540 load :: Session -> LoadHowMuch -> IO SuccessFlag
541 load s@(Session ref) how_much
543 -- Dependency analysis first. Note that this fixes the module graph:
544 -- even if we don't get a fully successful upsweep, the full module
545 -- graph is still retained in the Session. We can tell which modules
546 -- were successfully loaded by inspecting the Session's HPT.
547 mb_graph <- depanal s [] False
549 Just mod_graph -> load2 s how_much mod_graph
550 Nothing -> return Failed
552 load2 s@(Session ref) how_much mod_graph = do
554 hsc_env <- readIORef ref
556 let hpt1 = hsc_HPT hsc_env
557 let dflags = hsc_dflags hsc_env
558 let ghci_mode = ghcMode dflags -- this never changes
560 -- The "bad" boot modules are the ones for which we have
561 -- B.hs-boot in the module graph, but no B.hs
562 -- The downsweep should have ensured this does not happen
564 let all_home_mods = [ms_mod_name s
565 | s <- mod_graph, not (isBootSummary s)]
567 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
568 not (ms_mod_name s `elem` all_home_mods)]
570 ASSERT( null bad_boot_mods ) return ()
572 -- mg2_with_srcimps drops the hi-boot nodes, returning a
573 -- graph with cycles. Among other things, it is used for
574 -- backing out partially complete cycles following a failed
575 -- upsweep, and for removing from hpt all the modules
576 -- not in strict downwards closure, during calls to compile.
577 let mg2_with_srcimps :: [SCC ModSummary]
578 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
580 -- check the stability property for each module.
581 stable_mods@(stable_obj,stable_bco)
582 | BatchCompile <- ghci_mode = ([],[])
583 | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
585 -- prune bits of the HPT which are definitely redundant now,
587 pruned_hpt = pruneHomePackageTable hpt1
588 (flattenSCCs mg2_with_srcimps)
593 debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
594 text "Stable BCO:" <+> ppr stable_bco)
596 -- Unload any modules which are going to be re-linked this time around.
597 let stable_linkables = [ linkable
598 | m <- stable_obj++stable_bco,
599 Just hmi <- [lookupUFM pruned_hpt m],
600 Just linkable <- [hm_linkable hmi] ]
601 unload hsc_env stable_linkables
603 -- We could at this point detect cycles which aren't broken by
604 -- a source-import, and complain immediately, but it seems better
605 -- to let upsweep_mods do this, so at least some useful work gets
606 -- done before the upsweep is abandoned.
607 --hPutStrLn stderr "after tsort:\n"
608 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
610 -- Now do the upsweep, calling compile for each module in
611 -- turn. Final result is version 3 of everything.
613 -- Topologically sort the module graph, this time including hi-boot
614 -- nodes, and possibly just including the portion of the graph
615 -- reachable from the module specified in the 2nd argument to load.
616 -- This graph should be cycle-free.
617 -- If we're restricting the upsweep to a portion of the graph, we
618 -- also want to retain everything that is still stable.
619 let full_mg :: [SCC ModSummary]
620 full_mg = topSortModuleGraph False mod_graph Nothing
622 maybe_top_mod = case how_much of
624 LoadDependenciesOf m -> Just m
627 partial_mg0 :: [SCC ModSummary]
628 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
630 -- LoadDependenciesOf m: we want the upsweep to stop just
631 -- short of the specified module (unless the specified module
634 | LoadDependenciesOf mod <- how_much
635 = ASSERT( case last partial_mg0 of
636 AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
637 List.init partial_mg0
643 | AcyclicSCC ms <- full_mg,
644 ms_mod_name ms `elem` stable_obj++stable_bco,
645 ms_mod_name ms `notElem` [ ms_mod_name ms' |
646 AcyclicSCC ms' <- partial_mg ] ]
648 mg = stable_mg ++ partial_mg
650 -- clean up between compilations
651 let cleanup = cleanTempFilesExcept dflags
652 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
654 (upsweep_ok, hsc_env1, modsUpswept)
655 <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
656 pruned_hpt stable_mods cleanup mg
658 -- Make modsDone be the summaries for each home module now
659 -- available; this should equal the domain of hpt3.
660 -- Get in in a roughly top .. bottom order (hence reverse).
662 let modsDone = reverse modsUpswept
664 -- Try and do linking in some form, depending on whether the
665 -- upsweep was completely or only partially successful.
667 if succeeded upsweep_ok
670 -- Easy; just relink it all.
671 do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
673 -- Clean up after ourselves
674 cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
676 -- Issue a warning for the confusing case where the user
677 -- said '-o foo' but we're not going to do any linking.
678 -- We attempt linking if either (a) one of the modules is
679 -- called Main, or (b) the user said -no-hs-main, indicating
680 -- that main() is going to come from somewhere else.
682 let ofile = outputFile dflags
683 let no_hs_main = dopt Opt_NoHsMain dflags
685 main_mod = mainModIs dflags
686 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
687 do_linking = a_root_is_Main || no_hs_main
689 when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
690 debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
691 "but no output will be generated\n" ++
692 "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
694 -- link everything together
695 linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
697 loadFinish Succeeded linkresult ref hsc_env1
700 -- Tricky. We need to back out the effects of compiling any
701 -- half-done cycles, both so as to clean up the top level envs
702 -- and to avoid telling the interactive linker to link them.
703 do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
706 = map ms_mod modsDone
707 let mods_to_zap_names
708 = findPartiallyCompletedCycles modsDone_names
711 = filter ((`notElem` mods_to_zap_names).ms_mod)
714 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
717 -- Clean up after ourselves
718 cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
720 -- there should be no Nothings where linkables should be, now
721 ASSERT(all (isJust.hm_linkable)
722 (eltsUFM (hsc_HPT hsc_env))) do
724 -- Link everything together
725 linkresult <- link ghci_mode dflags False hpt4
727 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
728 loadFinish Failed linkresult ref hsc_env4
730 -- Finish up after a load.
732 -- If the link failed, unload everything and return.
733 loadFinish all_ok Failed ref hsc_env
734 = do unload hsc_env []
735 writeIORef ref $! discardProg hsc_env
738 -- Empty the interactive context and set the module context to the topmost
739 -- newly loaded module, or the Prelude if none were loaded.
740 loadFinish all_ok Succeeded ref hsc_env
741 = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
745 -- Forget the current program, but retain the persistent info in HscEnv
746 discardProg :: HscEnv -> HscEnv
748 = hsc_env { hsc_mod_graph = emptyMG,
749 hsc_IC = emptyInteractiveContext,
750 hsc_HPT = emptyHomePackageTable }
752 -- used to fish out the preprocess output files for the purposes of
753 -- cleaning up. The preprocessed file *might* be the same as the
754 -- source file, but that doesn't do any harm.
755 ppFilesFromSummaries summaries = map ms_hspp_file summaries
757 -- -----------------------------------------------------------------------------
761 CheckedModule { parsedSource :: ParsedSource,
762 renamedSource :: Maybe RenamedSource,
763 typecheckedSource :: Maybe TypecheckedSource,
764 checkedModuleInfo :: Maybe ModuleInfo
766 -- ToDo: improvements that could be made here:
767 -- if the module succeeded renaming but not typechecking,
768 -- we can still get back the GlobalRdrEnv and exports, so
769 -- perhaps the ModuleInfo should be split up into separate
770 -- fields within CheckedModule.
772 type ParsedSource = Located (HsModule RdrName)
773 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
774 type TypecheckedSource = LHsBinds Id
777 -- - things that aren't in the output of the typechecker right now:
781 -- - type/data/newtype declarations
782 -- - class declarations
784 -- - extra things in the typechecker's output:
785 -- - default methods are turned into top-level decls.
786 -- - dictionary bindings
789 -- | This is the way to get access to parsed and typechecked source code
790 -- for a module. 'checkModule' loads all the dependencies of the specified
791 -- module in the Session, and then attempts to typecheck the module. If
792 -- successful, it returns the abstract syntax for the module.
793 checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
794 checkModule session@(Session ref) mod = do
795 -- load up the dependencies first
796 r <- load session (LoadDependenciesOf mod)
797 if (failed r) then return Nothing else do
799 -- now parse & typecheck the module
800 hsc_env <- readIORef ref
801 let mg = hsc_mod_graph hsc_env
802 case [ ms | ms <- mg, ms_mod_name ms == mod ] of
805 mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
807 Nothing -> return Nothing
808 Just (HscChecked parsed renamed Nothing) ->
809 return (Just (CheckedModule {
810 parsedSource = parsed,
811 renamedSource = renamed,
812 typecheckedSource = Nothing,
813 checkedModuleInfo = Nothing }))
814 Just (HscChecked parsed renamed
815 (Just (tc_binds, rdr_env, details))) -> do
816 let minf = ModuleInfo {
817 minf_type_env = md_types details,
818 minf_exports = md_exports details,
819 minf_rdr_env = Just rdr_env,
820 minf_instances = md_insts details
822 return (Just (CheckedModule {
823 parsedSource = parsed,
824 renamedSource = renamed,
825 typecheckedSource = Just tc_binds,
826 checkedModuleInfo = Just minf }))
828 -- ---------------------------------------------------------------------------
831 unload :: HscEnv -> [Linkable] -> IO ()
832 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
833 = case ghcMode (hsc_dflags hsc_env) of
834 BatchCompile -> return ()
835 JustTypecheck -> return ()
837 Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
839 Interactive -> panic "unload: no interpreter"
841 other -> panic "unload: strange mode"
843 -- -----------------------------------------------------------------------------
847 Stability tells us which modules definitely do not need to be recompiled.
848 There are two main reasons for having stability:
850 - avoid doing a complete upsweep of the module graph in GHCi when
851 modules near the bottom of the tree have not changed.
853 - to tell GHCi when it can load object code: we can only load object code
854 for a module when we also load object code fo all of the imports of the
855 module. So we need to know that we will definitely not be recompiling
856 any of these modules, and we can use the object code.
858 NB. stability is of no importance to BatchCompile at all, only Interactive.
859 (ToDo: what about JustTypecheck?)
861 The stability check is as follows. Both stableObject and
862 stableBCO are used during the upsweep phase later.
865 stable m = stableObject m || stableBCO m
868 all stableObject (imports m)
869 && old linkable does not exist, or is == on-disk .o
870 && date(on-disk .o) > date(.hs)
873 all stable (imports m)
874 && date(BCO) > date(.hs)
877 These properties embody the following ideas:
879 - if a module is stable:
880 - if it has been compiled in a previous pass (present in HPT)
881 then it does not need to be compiled or re-linked.
882 - if it has not been compiled in a previous pass,
883 then we only need to read its .hi file from disk and
884 link it to produce a ModDetails.
886 - if a modules is not stable, we will definitely be at least
887 re-linking, and possibly re-compiling it during the upsweep.
888 All non-stable modules can (and should) therefore be unlinked
891 - Note that objects are only considered stable if they only depend
892 on other objects. We can't link object code against byte code.
896 :: HomePackageTable -- HPT from last compilation
897 -> [SCC ModSummary] -- current module graph (cyclic)
898 -> [ModuleName] -- all home modules
899 -> ([ModuleName], -- stableObject
900 [ModuleName]) -- stableBCO
902 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
904 checkSCC (stable_obj, stable_bco) scc0
905 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
906 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
907 | otherwise = (stable_obj, stable_bco)
909 scc = flattenSCC scc0
910 scc_mods = map ms_mod_name scc
911 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
913 scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
914 -- all imports outside the current SCC, but in the home pkg
916 stable_obj_imps = map (`elem` stable_obj) scc_allimps
917 stable_bco_imps = map (`elem` stable_bco) scc_allimps
924 and (zipWith (||) stable_obj_imps stable_bco_imps)
928 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
932 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
933 Just hmi | Just l <- hm_linkable hmi
934 -> isObjectLinkable l && t == linkableTime l
936 -- why '>=' rather than '>' above? If the filesystem stores
937 -- times to the nearset second, we may occasionally find that
938 -- the object & source have the same modification time,
939 -- especially if the source was automatically generated
940 -- and compiled. Using >= is slightly unsafe, but it matches
944 = case lookupUFM hpt (ms_mod_name ms) of
945 Just hmi | Just l <- hm_linkable hmi ->
946 not (isObjectLinkable l) &&
947 linkableTime l >= ms_hs_date ms
950 ms_allimps :: ModSummary -> [ModuleName]
951 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
953 -- -----------------------------------------------------------------------------
954 -- Prune the HomePackageTable
956 -- Before doing an upsweep, we can throw away:
958 -- - For non-stable modules:
959 -- - all ModDetails, all linked code
960 -- - all unlinked code that is out of date with respect to
963 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
964 -- space at the end of the upsweep, because the topmost ModDetails of the
965 -- old HPT holds on to the entire type environment from the previous
968 pruneHomePackageTable
971 -> ([ModuleName],[ModuleName])
974 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
977 | is_stable modl = hmi'
978 | otherwise = hmi'{ hm_details = emptyModDetails }
980 modl = moduleName (mi_module (hm_iface hmi))
981 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
982 = hmi{ hm_linkable = Nothing }
985 where ms = expectJust "prune" (lookupUFM ms_map modl)
987 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
989 is_stable m = m `elem` stable_obj || m `elem` stable_bco
991 -- -----------------------------------------------------------------------------
993 -- Return (names of) all those in modsDone who are part of a cycle
994 -- as defined by theGraph.
995 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
996 findPartiallyCompletedCycles modsDone theGraph
1000 chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting.
1001 chew ((CyclicSCC vs):rest)
1002 = let names_in_this_cycle = nub (map ms_mod vs)
1004 = nub ([done | done <- modsDone,
1005 done `elem` names_in_this_cycle])
1006 chewed_rest = chew rest
1008 if notNull mods_in_this_cycle
1009 && length mods_in_this_cycle < length names_in_this_cycle
1010 then mods_in_this_cycle ++ chewed_rest
1013 -- -----------------------------------------------------------------------------
1016 -- This is where we compile each module in the module graph, in a pass
1017 -- from the bottom to the top of the graph.
1019 -- There better had not be any cyclic groups here -- we check for them.
1022 :: HscEnv -- Includes initially-empty HPT
1023 -> HomePackageTable -- HPT from last time round (pruned)
1024 -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
1025 -> IO () -- How to clean up unwanted tmp files
1026 -> [SCC ModSummary] -- Mods to do (the worklist)
1028 HscEnv, -- With an updated HPT
1029 [ModSummary]) -- Mods which succeeded
1031 upsweep hsc_env old_hpt stable_mods cleanup mods
1032 = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
1034 upsweep' hsc_env old_hpt stable_mods cleanup
1036 = return (Succeeded, hsc_env, [])
1038 upsweep' hsc_env old_hpt stable_mods cleanup
1039 (CyclicSCC ms:_) _ _
1040 = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1041 return (Failed, hsc_env, [])
1043 upsweep' hsc_env old_hpt stable_mods cleanup
1044 (AcyclicSCC mod:mods) mod_index nmods
1045 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1046 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1047 -- (moduleEnvElts (hsc_HPT hsc_env)))
1049 mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
1052 cleanup -- Remove unwanted tmp files between compilations
1055 Nothing -> return (Failed, hsc_env, [])
1057 { let this_mod = ms_mod_name mod
1059 -- Add new info to hsc_env
1060 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1061 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1063 -- Space-saving: delete the old HPT entry
1064 -- for mod BUT if mod is a hs-boot
1065 -- node, don't delete it. For the
1066 -- interface, the HPT entry is probaby for the
1067 -- main Haskell source file. Deleting it
1068 -- would force .. (what?? --SDM)
1069 old_hpt1 | isBootSummary mod = old_hpt
1070 | otherwise = delFromUFM old_hpt this_mod
1072 ; (restOK, hsc_env2, modOKs)
1073 <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
1074 mods (mod_index+1) nmods
1075 ; return (restOK, hsc_env2, mod:modOKs)
1079 -- Compile a single module. Always produce a Linkable for it if
1080 -- successful. If no compilation happened, return the old Linkable.
1081 upsweep_mod :: HscEnv
1083 -> ([ModuleName],[ModuleName])
1085 -> Int -- index of module
1086 -> Int -- total number of modules
1087 -> IO (Maybe HomeModInfo) -- Nothing => Failed
1089 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1092 this_mod_name = ms_mod_name summary
1093 this_mod = ms_mod summary
1094 mb_obj_date = ms_obj_date summary
1095 obj_fn = ml_obj_file (ms_location summary)
1096 hs_date = ms_hs_date summary
1098 compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
1099 compile_it = upsweep_compile hsc_env old_hpt this_mod_name
1100 summary mod_index nmods
1102 case ghcMode (hsc_dflags hsc_env) of
1105 -- Batch-compilating is easy: just check whether we have
1106 -- an up-to-date object file. If we do, then the compiler
1107 -- needs to do a recompilation check.
1108 _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1110 findObjectLinkable this_mod obj_fn obj_date
1111 compile_it (Just linkable)
1118 _ | is_stable_obj, isJust old_hmi ->
1120 -- object is stable, and we have an entry in the
1121 -- old HPT: nothing to do
1123 | is_stable_obj, isNothing old_hmi -> do
1125 findObjectLinkable this_mod obj_fn
1126 (expectJust "upseep1" mb_obj_date)
1127 compile_it (Just linkable)
1128 -- object is stable, but we need to load the interface
1129 -- off disk to make a HMI.
1132 ASSERT(isJust old_hmi) -- must be in the old_hpt
1134 -- BCO is stable: nothing to do
1136 | Just hmi <- old_hmi,
1137 Just l <- hm_linkable hmi, not (isObjectLinkable l),
1138 linkableTime l >= ms_hs_date summary ->
1140 -- we have an old BCO that is up to date with respect
1141 -- to the source: do a recompilation check as normal.
1145 -- no existing code at all: we must recompile.
1147 is_stable_obj = this_mod_name `elem` stable_obj
1148 is_stable_bco = this_mod_name `elem` stable_bco
1150 old_hmi = lookupUFM old_hpt this_mod_name
1152 -- Run hsc to compile a module
1153 upsweep_compile hsc_env old_hpt this_mod summary
1155 mb_old_linkable = do
1157 -- The old interface is ok if it's in the old HPT
1158 -- a) we're compiling a source file, and the old HPT
1159 -- entry is for a source file
1160 -- b) we're compiling a hs-boot file
1161 -- Case (b) allows an hs-boot file to get the interface of its
1162 -- real source file on the second iteration of the compilation
1163 -- manager, but that does no harm. Otherwise the hs-boot file
1164 -- will always be recompiled
1167 = case lookupUFM old_hpt this_mod of
1169 Just hm_info | isBootSummary summary -> Just iface
1170 | not (mi_boot iface) -> Just iface
1171 | otherwise -> Nothing
1173 iface = hm_iface hm_info
1175 compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
1179 -- Compilation failed. Compile may still have updated the PCS, tho.
1180 CompErrs -> return Nothing
1182 -- Compilation "succeeded", and may or may not have returned a new
1183 -- linkable (depending on whether compilation was actually performed
1185 CompOK new_details new_iface new_linkable
1186 -> do let new_info = HomeModInfo { hm_iface = new_iface,
1187 hm_details = new_details,
1188 hm_linkable = new_linkable }
1189 return (Just new_info)
1192 -- Filter modules in the HPT
1193 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1194 retainInTopLevelEnvs keep_these hpt
1195 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1197 , let mb_mod_info = lookupUFM hpt mod
1198 , isJust mb_mod_info ]
1200 -- ---------------------------------------------------------------------------
1201 -- Topological sort of the module graph
1204 :: Bool -- Drop hi-boot nodes? (see below)
1208 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1209 -- The resulting list of strongly-connected-components is in topologically
1210 -- sorted order, starting with the module(s) at the bottom of the
1211 -- dependency graph (ie compile them first) and ending with the ones at
1214 -- Drop hi-boot nodes (first boolean arg)?
1216 -- False: treat the hi-boot summaries as nodes of the graph,
1217 -- so the graph must be acyclic
1219 -- True: eliminate the hi-boot nodes, and instead pretend
1220 -- the a source-import of Foo is an import of Foo
1221 -- The resulting graph has no hi-boot nodes, but can by cyclic
1223 topSortModuleGraph drop_hs_boot_nodes summaries Nothing
1224 = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
1225 topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
1226 = stronglyConnComp (map vertex_fn (reachable graph root))
1228 -- restrict the graph to just those modules reachable from
1229 -- the specified module. We do this by building a graph with
1230 -- the full set of nodes, and determining the reachable set from
1231 -- the specified node.
1232 (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
1233 (graph, vertex_fn, key_fn) = graphFromEdges' nodes
1235 | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1236 | otherwise = throwDyn (ProgramError "module does not exist")
1238 moduleGraphNodes :: Bool -> [ModSummary]
1239 -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
1240 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1242 -- Drop hs-boot nodes by using HsSrcFile as the key
1243 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1244 | otherwise = HsBootFile
1246 -- We use integers as the keys for the SCC algorithm
1247 nodes :: [(ModSummary, Int, [Int])]
1248 nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)),
1249 out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1250 out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
1252 , not (isBootSummary s && drop_hs_boot_nodes) ]
1253 -- Drop the hi-boot ones if told to do so
1255 key_map :: NodeMap Int
1256 key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
1260 lookup_key :: HscSource -> ModuleName -> Maybe Int
1261 lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1263 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1264 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1265 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1266 -- the IsBootInterface parameter True; else False
1269 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1270 type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
1272 msKey :: ModSummary -> NodeKey
1273 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1275 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1276 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1278 nodeMapElts :: NodeMap a -> [a]
1279 nodeMapElts = eltsFM
1281 ms_mod_name :: ModSummary -> ModuleName
1282 ms_mod_name = moduleName . ms_mod
1284 -----------------------------------------------------------------------------
1285 -- Downsweep (dependency analysis)
1287 -- Chase downwards from the specified root set, returning summaries
1288 -- for all home modules encountered. Only follow source-import
1291 -- We pass in the previous collection of summaries, which is used as a
1292 -- cache to avoid recalculating a module summary if the source is
1295 -- The returned list of [ModSummary] nodes has one node for each home-package
1296 -- module, plus one for any hs-boot files. The imports of these nodes
1297 -- are all there, including the imports of non-home-package modules.
1300 -> [ModSummary] -- Old summaries
1301 -> [ModuleName] -- Ignore dependencies on these; treat
1302 -- them as if they were package modules
1303 -> Bool -- True <=> allow multiple targets to have
1304 -- the same module name; this is
1305 -- very useful for ghc -M
1306 -> IO (Maybe [ModSummary])
1307 -- The elts of [ModSummary] all have distinct
1308 -- (Modules, IsBoot) identifiers, unless the Bool is true
1309 -- in which case there can be repeats
1310 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1311 = -- catch error messages and return them
1312 handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1313 rootSummaries <- mapM getRootSummary roots
1314 let root_map = mkRootMap rootSummaries
1315 checkDuplicates root_map
1316 summs <- loop (concatMap msDeps rootSummaries) root_map
1319 roots = hsc_targets hsc_env
1321 old_summary_map :: NodeMap ModSummary
1322 old_summary_map = mkNodeMap old_summaries
1324 getRootSummary :: Target -> IO ModSummary
1325 getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1326 = do exists <- doesFileExist file
1328 then summariseFile hsc_env old_summaries file mb_phase maybe_buf
1329 else throwDyn $ mkPlainErrMsg noSrcSpan $
1330 text "can't find file:" <+> text file
1331 getRootSummary (Target (TargetModule modl) maybe_buf)
1332 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1333 (L rootLoc modl) maybe_buf excl_mods
1334 case maybe_summary of
1335 Nothing -> packageModErr modl
1338 rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
1340 -- In a root module, the filename is allowed to diverge from the module
1341 -- name, so we have to check that there aren't multiple root files
1342 -- defining the same module (otherwise the duplicates will be silently
1343 -- ignored, leading to confusing behaviour).
1344 checkDuplicates :: NodeMap [ModSummary] -> IO ()
1345 checkDuplicates root_map
1346 | allow_dup_roots = return ()
1347 | null dup_roots = return ()
1348 | otherwise = multiRootsErr (head dup_roots)
1350 dup_roots :: [[ModSummary]] -- Each at least of length 2
1351 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1353 loop :: [(Located ModuleName,IsBootInterface)]
1354 -- Work list: process these modules
1355 -> NodeMap [ModSummary]
1356 -- Visited set; the range is a list because
1357 -- the roots can have the same module names
1358 -- if allow_dup_roots is True
1360 -- The result includes the worklist, except
1361 -- for those mentioned in the visited set
1362 loop [] done = return (concat (nodeMapElts done))
1363 loop ((wanted_mod, is_boot) : ss) done
1364 | Just summs <- lookupFM done key
1365 = if isSingleton summs then
1368 do { multiRootsErr summs; return [] }
1369 | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
1370 is_boot wanted_mod Nothing excl_mods
1372 Nothing -> loop ss done
1373 Just s -> loop (msDeps s ++ ss)
1374 (addToFM done key [s]) }
1376 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1378 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1379 mkRootMap summaries = addListToFM_C (++) emptyFM
1380 [ (msKey s, [s]) | s <- summaries ]
1382 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1383 -- (msDeps s) returns the dependencies of the ModSummary s.
1384 -- A wrinkle is that for a {-# SOURCE #-} import we return
1385 -- *both* the hs-boot file
1386 -- *and* the source file
1387 -- as "dependencies". That ensures that the list of all relevant
1388 -- modules always contains B.hs if it contains B.hs-boot.
1389 -- Remember, this pass isn't doing the topological sort. It's
1390 -- just gathering the list of all relevant ModSummaries
1392 concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1393 ++ [ (m,False) | m <- ms_imps s ]
1395 -----------------------------------------------------------------------------
1396 -- Summarising modules
1398 -- We have two types of summarisation:
1400 -- * Summarise a file. This is used for the root module(s) passed to
1401 -- cmLoadModules. The file is read, and used to determine the root
1402 -- module name. The module name may differ from the filename.
1404 -- * Summarise a module. We are given a module name, and must provide
1405 -- a summary. The finder is used to locate the file in which the module
1410 -> [ModSummary] -- old summaries
1411 -> FilePath -- source file name
1412 -> Maybe Phase -- start phase
1413 -> Maybe (StringBuffer,ClockTime)
1416 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1417 -- we can use a cached summary if one is available and the
1418 -- source file hasn't changed, But we have to look up the summary
1419 -- by source file, rather than module name as we do in summarise.
1420 | Just old_summary <- findSummaryBySourceFile old_summaries file
1422 let location = ms_location old_summary
1424 -- return the cached summary if the source didn't change
1425 src_timestamp <- case maybe_buf of
1426 Just (_,t) -> return t
1427 Nothing -> getModificationTime file
1428 -- The file exists; we checked in getRootSummary above.
1429 -- If it gets removed subsequently, then this
1430 -- getModificationTime may fail, but that's the right
1433 if ms_hs_date old_summary == src_timestamp
1434 then do -- update the object-file timestamp
1435 obj_timestamp <- getObjTimestamp location False
1436 return old_summary{ ms_obj_date = obj_timestamp }
1444 let dflags = hsc_dflags hsc_env
1446 (dflags', hspp_fn, buf)
1447 <- preprocessFile dflags file mb_phase maybe_buf
1449 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
1451 -- Make a ModLocation for this file
1452 location <- mkHomeModLocation dflags mod_name file
1454 -- Tell the Finder cache where it is, so that subsequent calls
1455 -- to findModule will find it, even if it's not on any search path
1456 mod <- addHomeModuleToFinder hsc_env mod_name location
1458 src_timestamp <- case maybe_buf of
1459 Just (_,t) -> return t
1460 Nothing -> getModificationTime file
1461 -- getMofificationTime may fail
1463 obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1465 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1466 ms_location = location,
1467 ms_hspp_file = hspp_fn,
1468 ms_hspp_opts = dflags',
1469 ms_hspp_buf = Just buf,
1470 ms_srcimps = srcimps, ms_imps = the_imps,
1471 ms_hs_date = src_timestamp,
1472 ms_obj_date = obj_timestamp })
1474 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1475 findSummaryBySourceFile summaries file
1476 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1477 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1481 -- Summarise a module, and pick up source and timestamp.
1484 -> NodeMap ModSummary -- Map of old summaries
1485 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
1486 -> Located ModuleName -- Imported module to be summarised
1487 -> Maybe (StringBuffer, ClockTime)
1488 -> [ModuleName] -- Modules to exclude
1489 -> IO (Maybe ModSummary) -- Its new summary
1491 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
1492 | wanted_mod `elem` excl_mods
1495 | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1496 = do -- Find its new timestamp; all the
1497 -- ModSummaries in the old map have valid ml_hs_files
1498 let location = ms_location old_summary
1499 src_fn = expectJust "summariseModule" (ml_hs_file location)
1501 -- check the modification time on the source file, and
1502 -- return the cached summary if it hasn't changed. If the
1503 -- file has disappeared, we need to call the Finder again.
1505 Just (_,t) -> check_timestamp old_summary location src_fn t
1507 m <- System.IO.Error.try (getModificationTime src_fn)
1509 Right t -> check_timestamp old_summary location src_fn t
1510 Left e | isDoesNotExistError e -> find_it
1511 | otherwise -> ioError e
1513 | otherwise = find_it
1515 dflags = hsc_dflags hsc_env
1517 hsc_src = if is_boot then HsBootFile else HsSrcFile
1519 check_timestamp old_summary location src_fn src_timestamp
1520 | ms_hs_date old_summary == src_timestamp = do
1521 -- update the object-file timestamp
1522 obj_timestamp <- getObjTimestamp location is_boot
1523 return (Just old_summary{ ms_obj_date = obj_timestamp })
1525 -- source changed: re-summarise.
1526 new_summary location (ms_mod old_summary) src_fn src_timestamp
1529 -- Don't use the Finder's cache this time. If the module was
1530 -- previously a package module, it may have now appeared on the
1531 -- search path, so we want to consider it to be a home module. If
1532 -- the module was previously a home module, it may have moved.
1533 uncacheModule hsc_env wanted_mod
1534 found <- findImportedModule hsc_env wanted_mod Nothing
1537 | isJust (ml_hs_file location) ->
1539 just_found location mod
1541 -- Drop external-pkg
1542 ASSERT(modulePackageId mod /= thisPackage dflags)
1546 err -> noModError dflags loc wanted_mod err
1549 just_found location mod = do
1550 -- Adjust location to point to the hs-boot source file,
1551 -- hi file, object file, when is_boot says so
1552 let location' | is_boot = addBootSuffixLocn location
1553 | otherwise = location
1554 src_fn = expectJust "summarise2" (ml_hs_file location')
1556 -- Check that it exists
1557 -- It might have been deleted since the Finder last found it
1558 maybe_t <- modificationTimeIfExists src_fn
1560 Nothing -> noHsFileErr loc src_fn
1561 Just t -> new_summary location' mod src_fn t
1564 new_summary location mod src_fn src_timestamp
1566 -- Preprocess the source file and get its imports
1567 -- The dflags' contains the OPTIONS pragmas
1568 (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1569 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
1571 when (mod_name /= wanted_mod) $
1572 throwDyn $ mkPlainErrMsg mod_loc $
1573 text "file name does not match module name"
1574 <+> quotes (ppr mod_name)
1576 -- Find the object timestamp, and return the summary
1577 obj_timestamp <- getObjTimestamp location is_boot
1579 return (Just ( ModSummary { ms_mod = mod,
1580 ms_hsc_src = hsc_src,
1581 ms_location = location,
1582 ms_hspp_file = hspp_fn,
1583 ms_hspp_opts = dflags',
1584 ms_hspp_buf = Just buf,
1585 ms_srcimps = srcimps,
1587 ms_hs_date = src_timestamp,
1588 ms_obj_date = obj_timestamp }))
1591 getObjTimestamp location is_boot
1592 = if is_boot then return Nothing
1593 else modificationTimeIfExists (ml_obj_file location)
1596 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1597 -> IO (DynFlags, FilePath, StringBuffer)
1598 preprocessFile dflags src_fn mb_phase Nothing
1600 (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1601 buf <- hGetStringBuffer hspp_fn
1602 return (dflags', hspp_fn, buf)
1604 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1606 -- case we bypass the preprocessing stage?
1608 local_opts = getOptions buf src_fn
1610 (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
1614 | Just (Unlit _) <- mb_phase = True
1615 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
1616 -- note: local_opts is only required if there's no Unlit phase
1617 | dopt Opt_Cpp dflags' = True
1618 | dopt Opt_Pp dflags' = True
1621 when needs_preprocessing $
1622 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1624 return (dflags', src_fn, buf)
1627 -----------------------------------------------------------------------------
1629 -----------------------------------------------------------------------------
1631 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1632 -- ToDo: we don't have a proper line number for this error
1633 noModError dflags loc wanted_mod err
1634 = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1636 noHsFileErr loc path
1637 = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1640 = throwDyn $ mkPlainErrMsg noSrcSpan $
1641 text "module" <+> quotes (ppr mod) <+> text "is a package module"
1643 multiRootsErr :: [ModSummary] -> IO ()
1644 multiRootsErr summs@(summ1:_)
1645 = throwDyn $ mkPlainErrMsg noSrcSpan $
1646 text "module" <+> quotes (ppr mod) <+>
1647 text "is defined in multiple files:" <+>
1648 sep (map text files)
1651 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1653 cyclicModuleErr :: [ModSummary] -> SDoc
1655 = hang (ptext SLIT("Module imports form a cycle for modules:"))
1656 2 (vcat (map show_one ms))
1658 show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1659 nest 2 $ ptext SLIT("imports:") <+>
1660 (pp_imps HsBootFile (ms_srcimps ms)
1661 $$ pp_imps HsSrcFile (ms_imps ms))]
1662 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1663 pp_imps src mods = fsep (map (show_mod src) mods)
1666 -- | Inform GHC that the working directory has changed. GHC will flush
1667 -- its cache of module locations, since it may no longer be valid.
1668 -- Note: if you change the working directory, you should also unload
1669 -- the current program (set targets to empty, followed by load).
1670 workingDirectoryChanged :: Session -> IO ()
1671 workingDirectoryChanged s = withSession s $ flushFinderCaches
1673 -- -----------------------------------------------------------------------------
1674 -- inspecting the session
1676 -- | Get the module dependency graph.
1677 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1678 getModuleGraph s = withSession s (return . hsc_mod_graph)
1680 isLoaded :: Session -> ModuleName -> IO Bool
1681 isLoaded s m = withSession s $ \hsc_env ->
1682 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1684 getBindings :: Session -> IO [TyThing]
1685 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1687 getPrintUnqual :: Session -> IO PrintUnqualified
1688 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1690 -- | Container for information about a 'Module'.
1691 data ModuleInfo = ModuleInfo {
1692 minf_type_env :: TypeEnv,
1693 minf_exports :: NameSet,
1694 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
1695 minf_instances :: [Instance]
1696 -- ToDo: this should really contain the ModIface too
1698 -- We don't want HomeModInfo here, because a ModuleInfo applies
1699 -- to package modules too.
1701 -- | Request information about a loaded 'Module'
1702 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1703 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1704 let mg = hsc_mod_graph hsc_env
1705 if mdl `elem` map ms_mod mg
1706 then getHomeModuleInfo hsc_env (moduleName mdl)
1708 {- if isHomeModule (hsc_dflags hsc_env) mdl
1710 else -} getPackageModuleInfo hsc_env mdl
1711 -- getPackageModuleInfo will attempt to find the interface, so
1712 -- we don't want to call it for a home module, just in case there
1713 -- was a problem loading the module and the interface doesn't
1714 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
1716 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1717 getPackageModuleInfo hsc_env mdl = do
1719 (_msgs, mb_names) <- getModuleExports hsc_env mdl
1721 Nothing -> return Nothing
1723 eps <- readIORef (hsc_EPS hsc_env)
1726 n_list = nameSetToList names
1727 tys = [ ty | name <- n_list,
1728 Just ty <- [lookupTypeEnv pte name] ]
1730 return (Just (ModuleInfo {
1731 minf_type_env = mkTypeEnv tys,
1732 minf_exports = names,
1733 minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
1734 minf_instances = error "getModuleInfo: instances for package module unimplemented"
1737 -- bogusly different for non-GHCI (ToDo)
1741 getHomeModuleInfo hsc_env mdl =
1742 case lookupUFM (hsc_HPT hsc_env) mdl of
1743 Nothing -> return Nothing
1745 let details = hm_details hmi
1746 return (Just (ModuleInfo {
1747 minf_type_env = md_types details,
1748 minf_exports = md_exports details,
1749 minf_rdr_env = mi_globals $! hm_iface hmi,
1750 minf_instances = md_insts details
1753 -- | The list of top-level entities defined in a module
1754 modInfoTyThings :: ModuleInfo -> [TyThing]
1755 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1757 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1758 modInfoTopLevelScope minf
1759 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1761 modInfoExports :: ModuleInfo -> [Name]
1762 modInfoExports minf = nameSetToList $! minf_exports minf
1764 -- | Returns the instances defined by the specified module.
1765 -- Warning: currently unimplemented for package modules.
1766 modInfoInstances :: ModuleInfo -> [Instance]
1767 modInfoInstances = minf_instances
1769 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1770 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1772 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1773 modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
1775 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1776 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1777 case lookupTypeEnv (minf_type_env minf) name of
1778 Just tyThing -> return (Just tyThing)
1780 eps <- readIORef (hsc_EPS hsc_env)
1781 return $! lookupType (hsc_dflags hsc_env)
1782 (hsc_HPT hsc_env) (eps_PTE eps) name
1784 isDictonaryId :: Id -> Bool
1786 = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1788 -- | Looks up a global name: that is, any top-level name in any
1789 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
1790 -- the interactive context, and therefore does not require a preceding
1792 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1793 lookupGlobalName s name = withSession s $ \hsc_env -> do
1794 eps <- readIORef (hsc_EPS hsc_env)
1795 return $! lookupType (hsc_dflags hsc_env)
1796 (hsc_HPT hsc_env) (eps_PTE eps) name
1798 -- -----------------------------------------------------------------------------
1799 -- Misc exported utils
1801 dataConType :: DataCon -> Type
1802 dataConType dc = idType (dataConWrapId dc)
1804 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1805 pprParenSymName :: NamedThing a => a -> SDoc
1806 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1808 -- ----------------------------------------------------------------------------
1813 -- - Data and Typeable instances for HsSyn.
1815 -- ToDo: check for small transformations that happen to the syntax in
1816 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1818 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
1819 -- to get from TyCons, Ids etc. to TH syntax (reify).
1821 -- :browse will use either lm_toplev or inspect lm_interface, depending
1822 -- on whether the module is interpreted or not.
1824 -- This is for reconstructing refactored source code
1825 -- Calls the lexer repeatedly.
1826 -- ToDo: add comment tokens to token stream
1827 getTokenStream :: Session -> Module -> IO [Located Token]
1830 -- -----------------------------------------------------------------------------
1831 -- Interactive evaluation
1833 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
1834 -- filesystem and package database to find the corresponding 'Module',
1835 -- using the algorithm that is used for an @import@ declaration.
1836 findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
1837 findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
1838 findModule' hsc_env mod_name maybe_pkg
1840 findModule' hsc_env mod_name maybe_pkg =
1842 dflags = hsc_dflags hsc_env
1843 hpt = hsc_HPT hsc_env
1844 this_pkg = thisPackage dflags
1846 case lookupUFM hpt mod_name of
1847 Just mod_info -> return (mi_module (hm_iface mod_info))
1848 _not_a_home_module -> do
1849 res <- findImportedModule hsc_env mod_name Nothing
1851 Found _ m | modulePackageId m /= this_pkg -> return m
1852 -- not allowed to be a home module
1853 err -> let msg = cannotFindModule dflags mod_name err in
1854 throwDyn (CmdLineError (showSDoc msg))
1858 -- | Set the interactive evaluation context.
1860 -- Setting the context doesn't throw away any bindings; the bindings
1861 -- we've built up in the InteractiveContext simply move to the new
1862 -- module. They always shadow anything in scope in the current context.
1863 setContext :: Session
1864 -> [Module] -- entire top level scope of these modules
1865 -> [Module] -- exports only of these modules
1867 setContext (Session ref) toplev_mods export_mods = do
1868 hsc_env <- readIORef ref
1869 let old_ic = hsc_IC hsc_env
1870 hpt = hsc_HPT hsc_env
1872 export_env <- mkExportEnv hsc_env export_mods
1873 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
1874 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1875 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
1876 ic_exports = export_mods,
1877 ic_rn_gbl_env = all_env }}
1880 -- Make a GlobalRdrEnv based on the exports of the modules only.
1881 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1882 mkExportEnv hsc_env mods = do
1883 stuff <- mapM (getModuleExports hsc_env) mods
1885 (_msgs, mb_name_sets) = unzip stuff
1886 gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod)
1887 | (Just name_set, mod) <- zip mb_name_sets mods ]
1889 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1891 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
1892 nameSetToGlobalRdrEnv names mod =
1893 mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1894 | name <- nameSetToList names ]
1896 vanillaProv :: ModuleName -> Provenance
1897 -- We're building a GlobalRdrEnv as if the user imported
1898 -- all the specified modules into the global interactive module
1899 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
1901 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1903 is_dloc = srcLocSpan interactiveSrcLoc }
1905 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1906 mkTopLevEnv hpt modl
1907 = case lookupUFM hpt (moduleName modl) of
1908 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
1909 showSDoc (ppr modl)))
1911 case mi_globals (hm_iface details) of
1913 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1914 ++ showSDoc (ppr modl)))
1915 Just env -> return env
1917 -- | Get the interactive evaluation context, consisting of a pair of the
1918 -- set of modules from which we take the full top-level scope, and the set
1919 -- of modules from which we take just the exports respectively.
1920 getContext :: Session -> IO ([Module],[Module])
1921 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1922 return (ic_toplev_scope ic, ic_exports ic))
1924 -- | Returns 'True' if the specified module is interpreted, and hence has
1925 -- its full top-level scope available.
1926 moduleIsInterpreted :: Session -> Module -> IO Bool
1927 moduleIsInterpreted s modl = withSession s $ \h ->
1928 if modulePackageId modl /= thisPackage (hsc_dflags h)
1930 else case lookupUFM (hsc_HPT h) (moduleName modl) of
1931 Just details -> return (isJust (mi_globals (hm_iface details)))
1932 _not_a_home_module -> return False
1934 -- | Looks up an identifier in the current interactive context (for :info)
1935 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
1936 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
1938 -- | Returns all names in scope in the current interactive context
1939 getNamesInScope :: Session -> IO [Name]
1940 getNamesInScope s = withSession s $ \hsc_env -> do
1941 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
1943 getRdrNamesInScope :: Session -> IO [RdrName]
1944 getRdrNamesInScope s = withSession s $ \hsc_env -> do
1945 let env = ic_rn_gbl_env (hsc_IC hsc_env)
1946 return (concat (map greToRdrNames (globalRdrEnvElts env)))
1948 -- ToDo: move to RdrName
1949 greToRdrNames :: GlobalRdrElt -> [RdrName]
1950 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
1952 LocalDef -> [unqual]
1953 Imported specs -> concat (map do_spec (map is_decl specs))
1955 occ = nameOccName name
1958 | is_qual decl_spec = [qual]
1959 | otherwise = [unqual,qual]
1960 where qual = Qual (is_as decl_spec) occ
1962 -- | Parses a string as an identifier, and returns the list of 'Name's that
1963 -- the identifier can refer to in the current interactive context.
1964 parseName :: Session -> String -> IO [Name]
1965 parseName s str = withSession s $ \hsc_env -> do
1966 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
1967 case maybe_rdr_name of
1968 Nothing -> return []
1969 Just (L _ rdr_name) -> do
1970 mb_names <- tcRnLookupRdrName hsc_env rdr_name
1972 Nothing -> return []
1973 Just ns -> return ns
1974 -- ToDo: should return error messages
1976 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
1977 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1978 lookupName :: Session -> Name -> IO (Maybe TyThing)
1979 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
1981 -- -----------------------------------------------------------------------------
1982 -- Getting the type of an expression
1984 -- | Get the type of an expression
1985 exprType :: Session -> String -> IO (Maybe Type)
1986 exprType s expr = withSession s $ \hsc_env -> do
1987 maybe_stuff <- hscTcExpr hsc_env expr
1989 Nothing -> return Nothing
1990 Just ty -> return (Just tidy_ty)
1992 tidy_ty = tidyType emptyTidyEnv ty
1994 -- -----------------------------------------------------------------------------
1995 -- Getting the kind of a type
1997 -- | Get the kind of a type
1998 typeKind :: Session -> String -> IO (Maybe Kind)
1999 typeKind s str = withSession s $ \hsc_env -> do
2000 maybe_stuff <- hscKcType hsc_env str
2002 Nothing -> return Nothing
2003 Just kind -> return (Just kind)
2005 -----------------------------------------------------------------------------
2006 -- cmCompileExpr: compile an expression and deliver an HValue
2008 compileExpr :: Session -> String -> IO (Maybe HValue)
2009 compileExpr s expr = withSession s $ \hsc_env -> do
2010 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
2012 Nothing -> return Nothing
2013 Just (new_ic, names, hval) -> do
2015 hvals <- (unsafeCoerce# hval) :: IO [HValue]
2017 case (names,hvals) of
2018 ([n],[hv]) -> return (Just hv)
2019 _ -> panic "compileExpr"
2021 -- -----------------------------------------------------------------------------
2022 -- running a statement interactively
2025 = RunOk [Name] -- ^ names bound by this evaluation
2026 | RunFailed -- ^ statement failed compilation
2027 | RunException Exception -- ^ statement raised an exception
2029 -- | Run a statement in the current interactive context. Statemenet
2030 -- may bind multple values.
2031 runStmt :: Session -> String -> IO RunResult
2032 runStmt (Session ref) expr
2034 hsc_env <- readIORef ref
2036 -- Turn off -fwarn-unused-bindings when running a statement, to hide
2037 -- warnings about the implicit bindings we introduce.
2038 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
2039 hsc_env' = hsc_env{ hsc_dflags = dflags' }
2041 maybe_stuff <- hscStmt hsc_env' expr
2044 Nothing -> return RunFailed
2045 Just (new_hsc_env, names, hval) -> do
2047 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
2048 either_hvals <- sandboxIO thing_to_run
2050 case either_hvals of
2052 -- on error, keep the *old* interactive context,
2053 -- so that 'it' is not bound to something
2054 -- that doesn't exist.
2055 return (RunException e)
2058 -- Get the newly bound things, and bind them.
2059 -- Don't need to delete any shadowed bindings;
2060 -- the new ones override the old ones.
2061 extendLinkEnv (zip names hvals)
2063 writeIORef ref new_hsc_env
2064 return (RunOk names)
2066 -- When running a computation, we redirect ^C exceptions to the running
2067 -- thread. ToDo: we might want a way to continue even if the target
2068 -- thread doesn't die when it receives the exception... "this thread
2069 -- is not responding".
2070 sandboxIO :: IO a -> IO (Either Exception a)
2071 sandboxIO thing = do
2073 ts <- takeMVar interruptTargetThread
2074 child <- forkIO (do res <- Exception.try thing; putMVar m res)
2075 putMVar interruptTargetThread (child:ts)
2076 takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
2079 -- This version of sandboxIO runs the expression in a completely new
2080 -- RTS main thread. It is disabled for now because ^C exceptions
2081 -- won't be delivered to the new thread, instead they'll be delivered
2082 -- to the (blocked) GHCi main thread.
2084 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
2086 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
2087 sandboxIO thing = do
2088 st_thing <- newStablePtr (Exception.try thing)
2089 alloca $ \ p_st_result -> do
2090 stat <- rts_evalStableIO st_thing p_st_result
2091 freeStablePtr st_thing
2093 then do st_result <- peek p_st_result
2094 result <- deRefStablePtr st_result
2095 freeStablePtr st_result
2096 return (Right result)
2098 return (Left (fromIntegral stat))
2100 foreign import "rts_evalStableIO" {- safe -}
2101 rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
2102 -- more informative than the C type!
2105 -----------------------------------------------------------------------------
2106 -- show a module and it's source/object filenames
2108 showModule :: Session -> ModSummary -> IO String
2109 showModule s mod_summary = withSession s $ \hsc_env -> do
2110 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
2111 Nothing -> panic "missing linkable"
2112 Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
2114 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))