1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow, 2005
7 -- -----------------------------------------------------------------------------
13 defaultCleanupHandler,
16 -- * Flags and settings
17 DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
23 Target(..), TargetId(..), Phase,
30 -- * Extending the program scope
31 extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
32 setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
33 extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
34 setGlobalTypeScope, -- :: Session -> [Id] -> IO ()
36 -- * Loading\/compiling the program
38 load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
39 workingDirectoryChanged,
40 checkModule, CheckedModule(..),
41 TypecheckedSource, ParsedSource, RenamedSource,
43 -- * Inspecting the module structure of the program
44 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
49 -- * Inspecting modules
54 modInfoPrintUnqualified,
57 modInfoIsExportedName,
62 PrintUnqualified, alwaysQualify,
64 -- * Interactive evaluation
65 getBindings, getPrintUnqual,
68 setContext, getContext,
79 compileExpr, HValue, dynCompileExpr,
83 -- * Abstract syntax elements
89 Module, mkModule, pprModule, moduleName, modulePackageId,
90 ModuleName, mkModuleName, moduleNameString,
94 nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
100 isImplicitId, isDeadBinder,
101 isExportedId, isLocalId, isGlobalId,
103 isPrimOpId, isFCallId, isClassOpId_maybe,
104 isDataConWorkId, idDataCon,
105 isBottomingId, isDictonaryId,
106 recordSelectorFieldLabel,
108 -- ** Type constructors
110 tyConTyVars, tyConDataCons, tyConArity,
111 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
112 synTyConDefn, synTyConRhs,
118 -- ** Data constructors
120 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
121 dataConIsInfix, isVanillaDataCon,
123 StrictnessMark(..), isMarkedStrict,
127 classMethods, classSCTheta, classTvsFds,
132 instanceDFunId, pprInstance, pprInstanceHdr,
134 -- ** Types and Kinds
135 Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
138 ThetaType, pprThetaArrow,
144 module HsSyn, -- ToDo: remove extraneous bits
148 defaultFixity, maxPrecedence,
152 -- ** Source locations
156 GhcException(..), showGhcException,
166 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
167 * what StaticFlags should we expose, if any?
170 #include "HsVersions.h"
173 import qualified Linker
174 import Data.Dynamic ( Dynamic )
175 import Linker ( HValue, extendLinkEnv )
176 import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
177 tcRnLookupName, getModuleExports )
178 import RdrName ( plusGlobalRdrEnv, Provenance(..),
179 ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
181 import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
182 import Name ( nameOccName )
183 import Type ( tidyType )
184 import VarEnv ( emptyTidyEnv )
185 import GHC.Exts ( unsafeCoerce# )
188 import Packages ( initPackages )
189 import NameSet ( NameSet, nameSetToList, elemNameSet )
190 import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
191 globalRdrEnvElts, extendGlobalRdrEnv,
194 import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
195 pprThetaArrow, pprParendType, splitForAllTys,
197 import Id ( Id, idType, isImplicitId, isDeadBinder,
198 isExportedId, isLocalId, isGlobalId,
199 isRecordSelector, recordSelectorFieldLabel,
200 isPrimOpId, isFCallId, isClassOpId_maybe,
201 isDataConWorkId, idDataCon,
204 import TysPrim ( alphaTyVars )
205 import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
206 isPrimTyCon, isFunTyCon, tyConArity,
207 tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
208 import Class ( Class, classSCTheta, classTvsFds, classMethods )
209 import FunDeps ( pprFundeps )
210 import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
211 dataConFieldLabels, dataConStrictMarks,
212 dataConIsInfix, isVanillaDataCon )
213 import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
215 import OccName ( parenSymOcc )
216 import NameEnv ( nameEnvElts )
217 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
219 import DriverPipeline
220 import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
221 import HeaderInfo ( getImports, getOptions )
223 import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
226 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
230 import PackageConfig ( PackageId, stringToPackageId )
234 import Bag ( unitBag )
235 import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
236 mkPlainErrMsg, printBagOfErrors )
237 import qualified ErrUtils
239 import StringBuffer ( StringBuffer, hGetStringBuffer )
242 import TcType ( tcSplitSigmaTy, isDictTy )
243 import Maybes ( expectJust, mapCatMaybes )
245 import Control.Concurrent
246 import System.Directory ( getModificationTime, doesFileExist )
247 import Data.Maybe ( isJust, isNothing )
248 import Data.List ( partition, nub )
249 import qualified Data.List as List
250 import Control.Monad ( unless, when )
251 import System.Exit ( exitWith, ExitCode(..) )
252 import System.Time ( ClockTime )
253 import Control.Exception as Exception hiding (handle)
256 import System.IO.Error ( isDoesNotExistError )
257 import Prelude hiding (init)
259 #if __GLASGOW_HASKELL__ < 600
260 import System.IO as System.IO.Error ( try )
262 import System.IO.Error ( try )
265 -- -----------------------------------------------------------------------------
266 -- Exception handlers
268 -- | Install some default exception handlers and run the inner computation.
269 -- Unless you want to handle exceptions yourself, you should wrap this around
270 -- the top level of your program. The default handlers output the error
271 -- message(s) to stderr and exit cleanly.
272 defaultErrorHandler :: DynFlags -> IO a -> IO a
273 defaultErrorHandler dflags inner =
274 -- top-level exception handler: any unrecognised exception is a compiler bug.
275 handle (\exception -> do
278 -- an IO exception probably isn't our fault, so don't panic
280 fatalErrorMsg dflags (text (show exception))
281 AsyncException StackOverflow ->
282 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
284 fatalErrorMsg dflags (text (show (Panic (show exception))))
285 exitWith (ExitFailure 1)
288 -- program errors: messages with locations attached. Sometimes it is
289 -- convenient to just throw these as exceptions.
290 handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
291 exitWith (ExitFailure 1)) $
293 -- error messages propagated as exceptions
294 handleDyn (\dyn -> do
297 PhaseFailed _ code -> exitWith code
298 Interrupted -> exitWith (ExitFailure 1)
299 _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
300 exitWith (ExitFailure 1)
304 -- | Install a default cleanup handler to remove temporary files
305 -- deposited by a GHC run. This is seperate from
306 -- 'defaultErrorHandler', because you might want to override the error
307 -- handling, but still get the ordinary cleanup behaviour.
308 defaultCleanupHandler :: DynFlags -> IO a -> IO a
309 defaultCleanupHandler dflags inner =
310 -- make sure we clean up after ourselves
311 later (unless (dopt Opt_KeepTmpFiles dflags) $
312 do cleanTempFiles dflags
315 -- exceptions will be blocked while we clean the temporary files,
316 -- so there shouldn't be any difficulty if we receive further
321 -- | Starts a new session. A session consists of a set of loaded
322 -- modules, a set of options (DynFlags), and an interactive context.
323 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
325 newSession :: GhcMode -> Maybe FilePath -> IO Session
326 newSession mode mb_top_dir = do
328 main_thread <- myThreadId
329 putMVar interruptTargetThread [main_thread]
330 installSignalHandlers
332 dflags0 <- initSysTools mb_top_dir defaultDynFlags
333 dflags <- initDynFlags dflags0
334 env <- newHscEnv dflags{ ghcMode=mode }
338 -- tmp: this breaks the abstraction, but required because DriverMkDepend
339 -- needs to call the Finder. ToDo: untangle this.
340 sessionHscEnv :: Session -> IO HscEnv
341 sessionHscEnv (Session ref) = readIORef ref
343 withSession :: Session -> (HscEnv -> IO a) -> IO a
344 withSession (Session ref) f = do h <- readIORef ref; f h
346 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
347 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
349 -- -----------------------------------------------------------------------------
352 -- | Grabs the DynFlags from the Session
353 getSessionDynFlags :: Session -> IO DynFlags
354 getSessionDynFlags s = withSession s (return . hsc_dflags)
356 -- | Updates the DynFlags in a Session. This also reads
357 -- the package database (unless it has already been read),
358 -- and prepares the compilers knowledge about packages. It
359 -- can be called again to load new packages: just add new
360 -- package flags to (packageFlags dflags).
362 -- Returns a list of new packages that may need to be linked in using
363 -- the dynamic linker (see 'linkPackages') as a result of new package
364 -- flags. If you are not doing linking or doing static linking, you
365 -- can ignore the list of packages returned.
367 setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
368 setSessionDynFlags (Session ref) dflags = do
369 hsc_env <- readIORef ref
370 (dflags', preload) <- initPackages dflags
371 writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
374 -- | If there is no -o option, guess the name of target executable
375 -- by using top-level source file name as a base.
376 guessOutputFile :: Session -> IO ()
377 guessOutputFile s = modifySession s $ \env ->
378 let dflags = hsc_dflags env
379 mod_graph = hsc_mod_graph env
380 mainModuleSrcPath, guessedName :: Maybe String
381 mainModuleSrcPath = do
382 let isMain = (== mainModIs dflags) . ms_mod
383 [ms] <- return (filter isMain mod_graph)
384 ml_hs_file (ms_location ms)
385 guessedName = fmap basenameOf mainModuleSrcPath
387 case outputFile dflags of
389 Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
391 -- -----------------------------------------------------------------------------
394 -- ToDo: think about relative vs. absolute file paths. And what
395 -- happens when the current directory changes.
397 -- | Sets the targets for this session. Each target may be a module name
398 -- or a filename. The targets correspond to the set of root modules for
399 -- the program\/library. Unloading the current program is achieved by
400 -- setting the current set of targets to be empty, followed by load.
401 setTargets :: Session -> [Target] -> IO ()
402 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
404 -- | returns the current set of targets
405 getTargets :: Session -> IO [Target]
406 getTargets s = withSession s (return . hsc_targets)
408 -- | Add another target
409 addTarget :: Session -> Target -> IO ()
411 = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
414 removeTarget :: Session -> TargetId -> IO ()
415 removeTarget s target_id
416 = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
418 filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
420 -- Attempts to guess what Target a string refers to. This function implements
421 -- the --make/GHCi command-line syntax for filenames:
423 -- - if the string looks like a Haskell source filename, then interpret
425 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
427 -- - otherwise interpret the string as a module name
429 guessTarget :: String -> Maybe Phase -> IO Target
430 guessTarget file (Just phase)
431 = return (Target (TargetFile file (Just phase)) Nothing)
432 guessTarget file Nothing
433 | isHaskellSrcFilename file
434 = return (Target (TargetFile file Nothing) Nothing)
436 = do exists <- doesFileExist hs_file
438 then return (Target (TargetFile hs_file Nothing) Nothing)
440 exists <- doesFileExist lhs_file
442 then return (Target (TargetFile lhs_file Nothing) Nothing)
444 return (Target (TargetModule (mkModuleName file)) Nothing)
446 hs_file = file `joinFileExt` "hs"
447 lhs_file = file `joinFileExt` "lhs"
449 -- -----------------------------------------------------------------------------
450 -- Extending the program scope
452 extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
453 extendGlobalRdrScope session rdrElts
454 = modifySession session $ \hscEnv ->
455 let global_rdr = hsc_global_rdr_env hscEnv
456 in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
458 setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
459 setGlobalRdrScope session rdrElts
460 = modifySession session $ \hscEnv ->
461 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
463 extendGlobalTypeScope :: Session -> [Id] -> IO ()
464 extendGlobalTypeScope session ids
465 = modifySession session $ \hscEnv ->
466 let global_type = hsc_global_type_env hscEnv
467 in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
469 setGlobalTypeScope :: Session -> [Id] -> IO ()
470 setGlobalTypeScope session ids
471 = modifySession session $ \hscEnv ->
472 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
474 -- -----------------------------------------------------------------------------
475 -- Loading the program
477 -- Perform a dependency analysis starting from the current targets
478 -- and update the session with the new module graph.
479 depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
480 depanal (Session ref) excluded_mods allow_dup_roots = do
481 hsc_env <- readIORef ref
483 dflags = hsc_dflags hsc_env
484 gmode = ghcMode (hsc_dflags hsc_env)
485 targets = hsc_targets hsc_env
486 old_graph = hsc_mod_graph hsc_env
488 showPass dflags "Chasing dependencies"
489 when (gmode == BatchCompile) $
490 debugTraceMsg dflags 2 (hcat [
491 text "Chasing modules from: ",
492 hcat (punctuate comma (map pprTarget targets))])
494 r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
496 Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
501 -- | The result of load.
503 = LoadOk Errors -- ^ all specified targets were loaded successfully.
504 | LoadFailed Errors -- ^ not all modules were loaded.
506 type Errors = [String]
508 data ErrMsg = ErrMsg {
509 errMsgSeverity :: Severity, -- warning, error, etc.
510 errMsgSpans :: [SrcSpan],
511 errMsgShortDoc :: Doc,
512 errMsgExtraInfo :: Doc
518 | LoadUpTo ModuleName
519 | LoadDependenciesOf ModuleName
521 -- | Try to load the program. If a Module is supplied, then just
522 -- attempt to load up to this target. If no Module is supplied,
523 -- then try to load all targets.
524 load :: Session -> LoadHowMuch -> IO SuccessFlag
525 load s@(Session ref) how_much
527 -- Dependency analysis first. Note that this fixes the module graph:
528 -- even if we don't get a fully successful upsweep, the full module
529 -- graph is still retained in the Session. We can tell which modules
530 -- were successfully loaded by inspecting the Session's HPT.
531 mb_graph <- depanal s [] False
533 Just mod_graph -> load2 s how_much mod_graph
534 Nothing -> return Failed
536 load2 s@(Session ref) how_much mod_graph = do
538 hsc_env <- readIORef ref
540 let hpt1 = hsc_HPT hsc_env
541 let dflags = hsc_dflags hsc_env
542 let ghci_mode = ghcMode dflags -- this never changes
544 -- The "bad" boot modules are the ones for which we have
545 -- B.hs-boot in the module graph, but no B.hs
546 -- The downsweep should have ensured this does not happen
548 let all_home_mods = [ms_mod_name s
549 | s <- mod_graph, not (isBootSummary s)]
551 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
552 not (ms_mod_name s `elem` all_home_mods)]
554 ASSERT( null bad_boot_mods ) return ()
556 -- mg2_with_srcimps drops the hi-boot nodes, returning a
557 -- graph with cycles. Among other things, it is used for
558 -- backing out partially complete cycles following a failed
559 -- upsweep, and for removing from hpt all the modules
560 -- not in strict downwards closure, during calls to compile.
561 let mg2_with_srcimps :: [SCC ModSummary]
562 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
564 -- check the stability property for each module.
565 stable_mods@(stable_obj,stable_bco)
566 | BatchCompile <- ghci_mode = ([],[])
567 | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
569 -- prune bits of the HPT which are definitely redundant now,
571 pruned_hpt = pruneHomePackageTable hpt1
572 (flattenSCCs mg2_with_srcimps)
577 debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
578 text "Stable BCO:" <+> ppr stable_bco)
580 -- Unload any modules which are going to be re-linked this time around.
581 let stable_linkables = [ linkable
582 | m <- stable_obj++stable_bco,
583 Just hmi <- [lookupUFM pruned_hpt m],
584 Just linkable <- [hm_linkable hmi] ]
585 unload hsc_env stable_linkables
587 -- We could at this point detect cycles which aren't broken by
588 -- a source-import, and complain immediately, but it seems better
589 -- to let upsweep_mods do this, so at least some useful work gets
590 -- done before the upsweep is abandoned.
591 --hPutStrLn stderr "after tsort:\n"
592 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
594 -- Now do the upsweep, calling compile for each module in
595 -- turn. Final result is version 3 of everything.
597 -- Topologically sort the module graph, this time including hi-boot
598 -- nodes, and possibly just including the portion of the graph
599 -- reachable from the module specified in the 2nd argument to load.
600 -- This graph should be cycle-free.
601 -- If we're restricting the upsweep to a portion of the graph, we
602 -- also want to retain everything that is still stable.
603 let full_mg :: [SCC ModSummary]
604 full_mg = topSortModuleGraph False mod_graph Nothing
606 maybe_top_mod = case how_much of
608 LoadDependenciesOf m -> Just m
611 partial_mg0 :: [SCC ModSummary]
612 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
614 -- LoadDependenciesOf m: we want the upsweep to stop just
615 -- short of the specified module (unless the specified module
618 | LoadDependenciesOf mod <- how_much
619 = ASSERT( case last partial_mg0 of
620 AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
621 List.init partial_mg0
627 | AcyclicSCC ms <- full_mg,
628 ms_mod_name ms `elem` stable_obj++stable_bco,
629 ms_mod_name ms `notElem` [ ms_mod_name ms' |
630 AcyclicSCC ms' <- partial_mg ] ]
632 mg = stable_mg ++ partial_mg
634 -- clean up between compilations
635 let cleanup = cleanTempFilesExcept dflags
636 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
638 (upsweep_ok, hsc_env1, modsUpswept)
639 <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
640 pruned_hpt stable_mods cleanup mg
642 -- Make modsDone be the summaries for each home module now
643 -- available; this should equal the domain of hpt3.
644 -- Get in in a roughly top .. bottom order (hence reverse).
646 let modsDone = reverse modsUpswept
648 -- Try and do linking in some form, depending on whether the
649 -- upsweep was completely or only partially successful.
651 if succeeded upsweep_ok
654 -- Easy; just relink it all.
655 do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
657 -- Clean up after ourselves
658 cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
660 -- Issue a warning for the confusing case where the user
661 -- said '-o foo' but we're not going to do any linking.
662 -- We attempt linking if either (a) one of the modules is
663 -- called Main, or (b) the user said -no-hs-main, indicating
664 -- that main() is going to come from somewhere else.
666 let ofile = outputFile dflags
667 let no_hs_main = dopt Opt_NoHsMain dflags
669 main_mod = mainModIs dflags
670 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
671 do_linking = a_root_is_Main || no_hs_main
673 when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
674 debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
675 "but no output will be generated\n" ++
676 "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
678 -- link everything together
679 linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
681 loadFinish Succeeded linkresult ref hsc_env1
684 -- Tricky. We need to back out the effects of compiling any
685 -- half-done cycles, both so as to clean up the top level envs
686 -- and to avoid telling the interactive linker to link them.
687 do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
690 = map ms_mod modsDone
691 let mods_to_zap_names
692 = findPartiallyCompletedCycles modsDone_names
695 = filter ((`notElem` mods_to_zap_names).ms_mod)
698 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
701 -- Clean up after ourselves
702 cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
704 -- there should be no Nothings where linkables should be, now
705 ASSERT(all (isJust.hm_linkable)
706 (eltsUFM (hsc_HPT hsc_env))) do
708 -- Link everything together
709 linkresult <- link ghci_mode dflags False hpt4
711 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
712 loadFinish Failed linkresult ref hsc_env4
714 -- Finish up after a load.
716 -- If the link failed, unload everything and return.
717 loadFinish all_ok Failed ref hsc_env
718 = do unload hsc_env []
719 writeIORef ref $! discardProg hsc_env
722 -- Empty the interactive context and set the module context to the topmost
723 -- newly loaded module, or the Prelude if none were loaded.
724 loadFinish all_ok Succeeded ref hsc_env
725 = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
729 -- Forget the current program, but retain the persistent info in HscEnv
730 discardProg :: HscEnv -> HscEnv
732 = hsc_env { hsc_mod_graph = emptyMG,
733 hsc_IC = emptyInteractiveContext,
734 hsc_HPT = emptyHomePackageTable }
736 -- used to fish out the preprocess output files for the purposes of
737 -- cleaning up. The preprocessed file *might* be the same as the
738 -- source file, but that doesn't do any harm.
739 ppFilesFromSummaries summaries = map ms_hspp_file summaries
741 -- -----------------------------------------------------------------------------
745 CheckedModule { parsedSource :: ParsedSource,
746 renamedSource :: Maybe RenamedSource,
747 typecheckedSource :: Maybe TypecheckedSource,
748 checkedModuleInfo :: Maybe ModuleInfo
750 -- ToDo: improvements that could be made here:
751 -- if the module succeeded renaming but not typechecking,
752 -- we can still get back the GlobalRdrEnv and exports, so
753 -- perhaps the ModuleInfo should be split up into separate
754 -- fields within CheckedModule.
756 type ParsedSource = Located (HsModule RdrName)
757 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
758 type TypecheckedSource = LHsBinds Id
761 -- - things that aren't in the output of the typechecker right now:
765 -- - type/data/newtype declarations
766 -- - class declarations
768 -- - extra things in the typechecker's output:
769 -- - default methods are turned into top-level decls.
770 -- - dictionary bindings
773 -- | This is the way to get access to parsed and typechecked source code
774 -- for a module. 'checkModule' loads all the dependencies of the specified
775 -- module in the Session, and then attempts to typecheck the module. If
776 -- successful, it returns the abstract syntax for the module.
777 checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
778 checkModule session@(Session ref) mod = do
779 -- load up the dependencies first
780 r <- load session (LoadDependenciesOf mod)
781 if (failed r) then return Nothing else do
783 -- now parse & typecheck the module
784 hsc_env <- readIORef ref
785 let mg = hsc_mod_graph hsc_env
786 case [ ms | ms <- mg, ms_mod_name ms == mod ] of
789 mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
791 Nothing -> return Nothing
792 Just (HscChecked parsed renamed Nothing) ->
793 return (Just (CheckedModule {
794 parsedSource = parsed,
795 renamedSource = renamed,
796 typecheckedSource = Nothing,
797 checkedModuleInfo = Nothing }))
798 Just (HscChecked parsed renamed
799 (Just (tc_binds, rdr_env, details))) -> do
800 let minf = ModuleInfo {
801 minf_type_env = md_types details,
802 minf_exports = md_exports details,
803 minf_rdr_env = Just rdr_env,
804 minf_instances = md_insts details
806 return (Just (CheckedModule {
807 parsedSource = parsed,
808 renamedSource = renamed,
809 typecheckedSource = Just tc_binds,
810 checkedModuleInfo = Just minf }))
812 -- ---------------------------------------------------------------------------
815 unload :: HscEnv -> [Linkable] -> IO ()
816 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
817 = case ghcMode (hsc_dflags hsc_env) of
818 BatchCompile -> return ()
819 JustTypecheck -> return ()
821 Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
823 Interactive -> panic "unload: no interpreter"
825 other -> panic "unload: strange mode"
827 -- -----------------------------------------------------------------------------
831 Stability tells us which modules definitely do not need to be recompiled.
832 There are two main reasons for having stability:
834 - avoid doing a complete upsweep of the module graph in GHCi when
835 modules near the bottom of the tree have not changed.
837 - to tell GHCi when it can load object code: we can only load object code
838 for a module when we also load object code fo all of the imports of the
839 module. So we need to know that we will definitely not be recompiling
840 any of these modules, and we can use the object code.
842 NB. stability is of no importance to BatchCompile at all, only Interactive.
843 (ToDo: what about JustTypecheck?)
845 The stability check is as follows. Both stableObject and
846 stableBCO are used during the upsweep phase later.
849 stable m = stableObject m || stableBCO m
852 all stableObject (imports m)
853 && old linkable does not exist, or is == on-disk .o
854 && date(on-disk .o) > date(.hs)
857 all stable (imports m)
858 && date(BCO) > date(.hs)
861 These properties embody the following ideas:
863 - if a module is stable:
864 - if it has been compiled in a previous pass (present in HPT)
865 then it does not need to be compiled or re-linked.
866 - if it has not been compiled in a previous pass,
867 then we only need to read its .hi file from disk and
868 link it to produce a ModDetails.
870 - if a modules is not stable, we will definitely be at least
871 re-linking, and possibly re-compiling it during the upsweep.
872 All non-stable modules can (and should) therefore be unlinked
875 - Note that objects are only considered stable if they only depend
876 on other objects. We can't link object code against byte code.
880 :: HomePackageTable -- HPT from last compilation
881 -> [SCC ModSummary] -- current module graph (cyclic)
882 -> [ModuleName] -- all home modules
883 -> ([ModuleName], -- stableObject
884 [ModuleName]) -- stableBCO
886 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
888 checkSCC (stable_obj, stable_bco) scc0
889 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
890 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
891 | otherwise = (stable_obj, stable_bco)
893 scc = flattenSCC scc0
894 scc_mods = map ms_mod_name scc
895 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
897 scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
898 -- all imports outside the current SCC, but in the home pkg
900 stable_obj_imps = map (`elem` stable_obj) scc_allimps
901 stable_bco_imps = map (`elem` stable_bco) scc_allimps
908 and (zipWith (||) stable_obj_imps stable_bco_imps)
912 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
916 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
917 Just hmi | Just l <- hm_linkable hmi
918 -> isObjectLinkable l && t == linkableTime l
920 -- why '>=' rather than '>' above? If the filesystem stores
921 -- times to the nearset second, we may occasionally find that
922 -- the object & source have the same modification time,
923 -- especially if the source was automatically generated
924 -- and compiled. Using >= is slightly unsafe, but it matches
928 = case lookupUFM hpt (ms_mod_name ms) of
929 Just hmi | Just l <- hm_linkable hmi ->
930 not (isObjectLinkable l) &&
931 linkableTime l >= ms_hs_date ms
934 ms_allimps :: ModSummary -> [ModuleName]
935 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
937 -- -----------------------------------------------------------------------------
938 -- Prune the HomePackageTable
940 -- Before doing an upsweep, we can throw away:
942 -- - For non-stable modules:
943 -- - all ModDetails, all linked code
944 -- - all unlinked code that is out of date with respect to
947 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
948 -- space at the end of the upsweep, because the topmost ModDetails of the
949 -- old HPT holds on to the entire type environment from the previous
952 pruneHomePackageTable
955 -> ([ModuleName],[ModuleName])
958 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
961 | is_stable modl = hmi'
962 | otherwise = hmi'{ hm_details = emptyModDetails }
964 modl = moduleName (mi_module (hm_iface hmi))
965 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
966 = hmi{ hm_linkable = Nothing }
969 where ms = expectJust "prune" (lookupUFM ms_map modl)
971 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
973 is_stable m = m `elem` stable_obj || m `elem` stable_bco
975 -- -----------------------------------------------------------------------------
977 -- Return (names of) all those in modsDone who are part of a cycle
978 -- as defined by theGraph.
979 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
980 findPartiallyCompletedCycles modsDone theGraph
984 chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting.
985 chew ((CyclicSCC vs):rest)
986 = let names_in_this_cycle = nub (map ms_mod vs)
988 = nub ([done | done <- modsDone,
989 done `elem` names_in_this_cycle])
990 chewed_rest = chew rest
992 if notNull mods_in_this_cycle
993 && length mods_in_this_cycle < length names_in_this_cycle
994 then mods_in_this_cycle ++ chewed_rest
997 -- -----------------------------------------------------------------------------
1000 -- This is where we compile each module in the module graph, in a pass
1001 -- from the bottom to the top of the graph.
1003 -- There better had not be any cyclic groups here -- we check for them.
1006 :: HscEnv -- Includes initially-empty HPT
1007 -> HomePackageTable -- HPT from last time round (pruned)
1008 -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
1009 -> IO () -- How to clean up unwanted tmp files
1010 -> [SCC ModSummary] -- Mods to do (the worklist)
1012 HscEnv, -- With an updated HPT
1013 [ModSummary]) -- Mods which succeeded
1015 upsweep hsc_env old_hpt stable_mods cleanup mods
1016 = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
1018 upsweep' hsc_env old_hpt stable_mods cleanup
1020 = return (Succeeded, hsc_env, [])
1022 upsweep' hsc_env old_hpt stable_mods cleanup
1023 (CyclicSCC ms:_) _ _
1024 = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1025 return (Failed, hsc_env, [])
1027 upsweep' hsc_env old_hpt stable_mods cleanup
1028 (AcyclicSCC mod:mods) mod_index nmods
1029 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1030 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1031 -- (moduleEnvElts (hsc_HPT hsc_env)))
1033 mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
1036 cleanup -- Remove unwanted tmp files between compilations
1039 Nothing -> return (Failed, hsc_env, [])
1041 { let this_mod = ms_mod_name mod
1043 -- Add new info to hsc_env
1044 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1045 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1047 -- Space-saving: delete the old HPT entry
1048 -- for mod BUT if mod is a hs-boot
1049 -- node, don't delete it. For the
1050 -- interface, the HPT entry is probaby for the
1051 -- main Haskell source file. Deleting it
1052 -- would force .. (what?? --SDM)
1053 old_hpt1 | isBootSummary mod = old_hpt
1054 | otherwise = delFromUFM old_hpt this_mod
1056 ; (restOK, hsc_env2, modOKs)
1057 <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
1058 mods (mod_index+1) nmods
1059 ; return (restOK, hsc_env2, mod:modOKs)
1063 -- Compile a single module. Always produce a Linkable for it if
1064 -- successful. If no compilation happened, return the old Linkable.
1065 upsweep_mod :: HscEnv
1067 -> ([ModuleName],[ModuleName])
1069 -> Int -- index of module
1070 -> Int -- total number of modules
1071 -> IO (Maybe HomeModInfo) -- Nothing => Failed
1073 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1076 this_mod_name = ms_mod_name summary
1077 this_mod = ms_mod summary
1078 mb_obj_date = ms_obj_date summary
1079 obj_fn = ml_obj_file (ms_location summary)
1080 hs_date = ms_hs_date summary
1082 compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
1083 compile_it = upsweep_compile hsc_env old_hpt this_mod_name
1084 summary mod_index nmods
1086 case ghcMode (hsc_dflags hsc_env) of
1089 -- Batch-compilating is easy: just check whether we have
1090 -- an up-to-date object file. If we do, then the compiler
1091 -- needs to do a recompilation check.
1092 _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1094 findObjectLinkable this_mod obj_fn obj_date
1095 compile_it (Just linkable)
1102 _ | is_stable_obj, isJust old_hmi ->
1104 -- object is stable, and we have an entry in the
1105 -- old HPT: nothing to do
1107 | is_stable_obj, isNothing old_hmi -> do
1109 findObjectLinkable this_mod obj_fn
1110 (expectJust "upseep1" mb_obj_date)
1111 compile_it (Just linkable)
1112 -- object is stable, but we need to load the interface
1113 -- off disk to make a HMI.
1116 ASSERT(isJust old_hmi) -- must be in the old_hpt
1118 -- BCO is stable: nothing to do
1120 | Just hmi <- old_hmi,
1121 Just l <- hm_linkable hmi, not (isObjectLinkable l),
1122 linkableTime l >= ms_hs_date summary ->
1124 -- we have an old BCO that is up to date with respect
1125 -- to the source: do a recompilation check as normal.
1129 -- no existing code at all: we must recompile.
1131 is_stable_obj = this_mod_name `elem` stable_obj
1132 is_stable_bco = this_mod_name `elem` stable_bco
1134 old_hmi = lookupUFM old_hpt this_mod_name
1136 -- Run hsc to compile a module
1137 upsweep_compile hsc_env old_hpt this_mod summary
1139 mb_old_linkable = do
1141 -- The old interface is ok if it's in the old HPT
1142 -- a) we're compiling a source file, and the old HPT
1143 -- entry is for a source file
1144 -- b) we're compiling a hs-boot file
1145 -- Case (b) allows an hs-boot file to get the interface of its
1146 -- real source file on the second iteration of the compilation
1147 -- manager, but that does no harm. Otherwise the hs-boot file
1148 -- will always be recompiled
1151 = case lookupUFM old_hpt this_mod of
1153 Just hm_info | isBootSummary summary -> Just iface
1154 | not (mi_boot iface) -> Just iface
1155 | otherwise -> Nothing
1157 iface = hm_iface hm_info
1159 compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
1163 -- Compilation failed. Compile may still have updated the PCS, tho.
1164 CompErrs -> return Nothing
1166 -- Compilation "succeeded", and may or may not have returned a new
1167 -- linkable (depending on whether compilation was actually performed
1169 CompOK new_details new_iface new_linkable
1170 -> do let new_info = HomeModInfo { hm_iface = new_iface,
1171 hm_details = new_details,
1172 hm_linkable = new_linkable }
1173 return (Just new_info)
1176 -- Filter modules in the HPT
1177 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1178 retainInTopLevelEnvs keep_these hpt
1179 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1181 , let mb_mod_info = lookupUFM hpt mod
1182 , isJust mb_mod_info ]
1184 -- ---------------------------------------------------------------------------
1185 -- Topological sort of the module graph
1188 :: Bool -- Drop hi-boot nodes? (see below)
1192 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1193 -- The resulting list of strongly-connected-components is in topologically
1194 -- sorted order, starting with the module(s) at the bottom of the
1195 -- dependency graph (ie compile them first) and ending with the ones at
1198 -- Drop hi-boot nodes (first boolean arg)?
1200 -- False: treat the hi-boot summaries as nodes of the graph,
1201 -- so the graph must be acyclic
1203 -- True: eliminate the hi-boot nodes, and instead pretend
1204 -- the a source-import of Foo is an import of Foo
1205 -- The resulting graph has no hi-boot nodes, but can by cyclic
1207 topSortModuleGraph drop_hs_boot_nodes summaries Nothing
1208 = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
1209 topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
1210 = stronglyConnComp (map vertex_fn (reachable graph root))
1212 -- restrict the graph to just those modules reachable from
1213 -- the specified module. We do this by building a graph with
1214 -- the full set of nodes, and determining the reachable set from
1215 -- the specified node.
1216 (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
1217 (graph, vertex_fn, key_fn) = graphFromEdges' nodes
1219 | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1220 | otherwise = throwDyn (ProgramError "module does not exist")
1222 moduleGraphNodes :: Bool -> [ModSummary]
1223 -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
1224 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1226 -- Drop hs-boot nodes by using HsSrcFile as the key
1227 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1228 | otherwise = HsBootFile
1230 -- We use integers as the keys for the SCC algorithm
1231 nodes :: [(ModSummary, Int, [Int])]
1232 nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)),
1233 out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1234 out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
1236 , not (isBootSummary s && drop_hs_boot_nodes) ]
1237 -- Drop the hi-boot ones if told to do so
1239 key_map :: NodeMap Int
1240 key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
1244 lookup_key :: HscSource -> ModuleName -> Maybe Int
1245 lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1247 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1248 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1249 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1250 -- the IsBootInterface parameter True; else False
1253 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1254 type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
1256 msKey :: ModSummary -> NodeKey
1257 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1259 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1260 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1262 nodeMapElts :: NodeMap a -> [a]
1263 nodeMapElts = eltsFM
1265 ms_mod_name :: ModSummary -> ModuleName
1266 ms_mod_name = moduleName . ms_mod
1268 -----------------------------------------------------------------------------
1269 -- Downsweep (dependency analysis)
1271 -- Chase downwards from the specified root set, returning summaries
1272 -- for all home modules encountered. Only follow source-import
1275 -- We pass in the previous collection of summaries, which is used as a
1276 -- cache to avoid recalculating a module summary if the source is
1279 -- The returned list of [ModSummary] nodes has one node for each home-package
1280 -- module, plus one for any hs-boot files. The imports of these nodes
1281 -- are all there, including the imports of non-home-package modules.
1284 -> [ModSummary] -- Old summaries
1285 -> [ModuleName] -- Ignore dependencies on these; treat
1286 -- them as if they were package modules
1287 -> Bool -- True <=> allow multiple targets to have
1288 -- the same module name; this is
1289 -- very useful for ghc -M
1290 -> IO (Maybe [ModSummary])
1291 -- The elts of [ModSummary] all have distinct
1292 -- (Modules, IsBoot) identifiers, unless the Bool is true
1293 -- in which case there can be repeats
1294 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1295 = -- catch error messages and return them
1296 handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1297 rootSummaries <- mapM getRootSummary roots
1298 let root_map = mkRootMap rootSummaries
1299 checkDuplicates root_map
1300 summs <- loop (concatMap msDeps rootSummaries) root_map
1303 roots = hsc_targets hsc_env
1305 old_summary_map :: NodeMap ModSummary
1306 old_summary_map = mkNodeMap old_summaries
1308 getRootSummary :: Target -> IO ModSummary
1309 getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1310 = do exists <- doesFileExist file
1312 then summariseFile hsc_env old_summaries file mb_phase maybe_buf
1313 else throwDyn $ mkPlainErrMsg noSrcSpan $
1314 text "can't find file:" <+> text file
1315 getRootSummary (Target (TargetModule modl) maybe_buf)
1316 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1317 (L rootLoc modl) maybe_buf excl_mods
1318 case maybe_summary of
1319 Nothing -> packageModErr modl
1322 rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
1324 -- In a root module, the filename is allowed to diverge from the module
1325 -- name, so we have to check that there aren't multiple root files
1326 -- defining the same module (otherwise the duplicates will be silently
1327 -- ignored, leading to confusing behaviour).
1328 checkDuplicates :: NodeMap [ModSummary] -> IO ()
1329 checkDuplicates root_map
1330 | allow_dup_roots = return ()
1331 | null dup_roots = return ()
1332 | otherwise = multiRootsErr (head dup_roots)
1334 dup_roots :: [[ModSummary]] -- Each at least of length 2
1335 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1337 loop :: [(Located ModuleName,IsBootInterface)]
1338 -- Work list: process these modules
1339 -> NodeMap [ModSummary]
1340 -- Visited set; the range is a list because
1341 -- the roots can have the same module names
1342 -- if allow_dup_roots is True
1344 -- The result includes the worklist, except
1345 -- for those mentioned in the visited set
1346 loop [] done = return (concat (nodeMapElts done))
1347 loop ((wanted_mod, is_boot) : ss) done
1348 | Just summs <- lookupFM done key
1349 = if isSingleton summs then
1352 do { multiRootsErr summs; return [] }
1353 | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
1354 is_boot wanted_mod Nothing excl_mods
1356 Nothing -> loop ss done
1357 Just s -> loop (msDeps s ++ ss)
1358 (addToFM done key [s]) }
1360 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1362 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1363 mkRootMap summaries = addListToFM_C (++) emptyFM
1364 [ (msKey s, [s]) | s <- summaries ]
1366 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1367 -- (msDeps s) returns the dependencies of the ModSummary s.
1368 -- A wrinkle is that for a {-# SOURCE #-} import we return
1369 -- *both* the hs-boot file
1370 -- *and* the source file
1371 -- as "dependencies". That ensures that the list of all relevant
1372 -- modules always contains B.hs if it contains B.hs-boot.
1373 -- Remember, this pass isn't doing the topological sort. It's
1374 -- just gathering the list of all relevant ModSummaries
1376 concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1377 ++ [ (m,False) | m <- ms_imps s ]
1379 -----------------------------------------------------------------------------
1380 -- Summarising modules
1382 -- We have two types of summarisation:
1384 -- * Summarise a file. This is used for the root module(s) passed to
1385 -- cmLoadModules. The file is read, and used to determine the root
1386 -- module name. The module name may differ from the filename.
1388 -- * Summarise a module. We are given a module name, and must provide
1389 -- a summary. The finder is used to locate the file in which the module
1394 -> [ModSummary] -- old summaries
1395 -> FilePath -- source file name
1396 -> Maybe Phase -- start phase
1397 -> Maybe (StringBuffer,ClockTime)
1400 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1401 -- we can use a cached summary if one is available and the
1402 -- source file hasn't changed, But we have to look up the summary
1403 -- by source file, rather than module name as we do in summarise.
1404 | Just old_summary <- findSummaryBySourceFile old_summaries file
1406 let location = ms_location old_summary
1408 -- return the cached summary if the source didn't change
1409 src_timestamp <- case maybe_buf of
1410 Just (_,t) -> return t
1411 Nothing -> getModificationTime file
1412 -- The file exists; we checked in getRootSummary above.
1413 -- If it gets removed subsequently, then this
1414 -- getModificationTime may fail, but that's the right
1417 if ms_hs_date old_summary == src_timestamp
1418 then do -- update the object-file timestamp
1419 obj_timestamp <- getObjTimestamp location False
1420 return old_summary{ ms_obj_date = obj_timestamp }
1428 let dflags = hsc_dflags hsc_env
1430 (dflags', hspp_fn, buf)
1431 <- preprocessFile dflags file mb_phase maybe_buf
1433 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
1435 -- Make a ModLocation for this file
1436 location <- mkHomeModLocation dflags mod_name file
1438 -- Tell the Finder cache where it is, so that subsequent calls
1439 -- to findModule will find it, even if it's not on any search path
1440 mod <- addHomeModuleToFinder hsc_env mod_name location
1442 src_timestamp <- case maybe_buf of
1443 Just (_,t) -> return t
1444 Nothing -> getModificationTime file
1445 -- getMofificationTime may fail
1447 obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1449 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1450 ms_location = location,
1451 ms_hspp_file = hspp_fn,
1452 ms_hspp_opts = dflags',
1453 ms_hspp_buf = Just buf,
1454 ms_srcimps = srcimps, ms_imps = the_imps,
1455 ms_hs_date = src_timestamp,
1456 ms_obj_date = obj_timestamp })
1458 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1459 findSummaryBySourceFile summaries file
1460 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1461 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1465 -- Summarise a module, and pick up source and timestamp.
1468 -> NodeMap ModSummary -- Map of old summaries
1469 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
1470 -> Located ModuleName -- Imported module to be summarised
1471 -> Maybe (StringBuffer, ClockTime)
1472 -> [ModuleName] -- Modules to exclude
1473 -> IO (Maybe ModSummary) -- Its new summary
1475 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
1476 | wanted_mod `elem` excl_mods
1479 | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1480 = do -- Find its new timestamp; all the
1481 -- ModSummaries in the old map have valid ml_hs_files
1482 let location = ms_location old_summary
1483 src_fn = expectJust "summariseModule" (ml_hs_file location)
1485 -- check the modification time on the source file, and
1486 -- return the cached summary if it hasn't changed. If the
1487 -- file has disappeared, we need to call the Finder again.
1489 Just (_,t) -> check_timestamp old_summary location src_fn t
1491 m <- System.IO.Error.try (getModificationTime src_fn)
1493 Right t -> check_timestamp old_summary location src_fn t
1494 Left e | isDoesNotExistError e -> find_it
1495 | otherwise -> ioError e
1497 | otherwise = find_it
1499 dflags = hsc_dflags hsc_env
1501 hsc_src = if is_boot then HsBootFile else HsSrcFile
1503 check_timestamp old_summary location src_fn src_timestamp
1504 | ms_hs_date old_summary == src_timestamp = do
1505 -- update the object-file timestamp
1506 obj_timestamp <- getObjTimestamp location is_boot
1507 return (Just old_summary{ ms_obj_date = obj_timestamp })
1509 -- source changed: re-summarise.
1510 new_summary location (ms_mod old_summary) src_fn src_timestamp
1513 -- Don't use the Finder's cache this time. If the module was
1514 -- previously a package module, it may have now appeared on the
1515 -- search path, so we want to consider it to be a home module. If
1516 -- the module was previously a home module, it may have moved.
1517 uncacheModule hsc_env wanted_mod
1518 found <- findImportedModule hsc_env wanted_mod Nothing
1521 | isJust (ml_hs_file location) ->
1523 just_found location mod
1525 -- Drop external-pkg
1526 ASSERT(modulePackageId mod /= thisPackage dflags)
1530 err -> noModError dflags loc wanted_mod err
1533 just_found location mod = do
1534 -- Adjust location to point to the hs-boot source file,
1535 -- hi file, object file, when is_boot says so
1536 let location' | is_boot = addBootSuffixLocn location
1537 | otherwise = location
1538 src_fn = expectJust "summarise2" (ml_hs_file location')
1540 -- Check that it exists
1541 -- It might have been deleted since the Finder last found it
1542 maybe_t <- modificationTimeIfExists src_fn
1544 Nothing -> noHsFileErr loc src_fn
1545 Just t -> new_summary location' mod src_fn t
1548 new_summary location mod src_fn src_timestamp
1550 -- Preprocess the source file and get its imports
1551 -- The dflags' contains the OPTIONS pragmas
1552 (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1553 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
1555 when (mod_name /= wanted_mod) $
1556 throwDyn $ mkPlainErrMsg mod_loc $
1557 text "file name does not match module name"
1558 <+> quotes (ppr mod_name)
1560 -- Find the object timestamp, and return the summary
1561 obj_timestamp <- getObjTimestamp location is_boot
1563 return (Just ( ModSummary { ms_mod = mod,
1564 ms_hsc_src = hsc_src,
1565 ms_location = location,
1566 ms_hspp_file = hspp_fn,
1567 ms_hspp_opts = dflags',
1568 ms_hspp_buf = Just buf,
1569 ms_srcimps = srcimps,
1571 ms_hs_date = src_timestamp,
1572 ms_obj_date = obj_timestamp }))
1575 getObjTimestamp location is_boot
1576 = if is_boot then return Nothing
1577 else modificationTimeIfExists (ml_obj_file location)
1580 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1581 -> IO (DynFlags, FilePath, StringBuffer)
1582 preprocessFile dflags src_fn mb_phase Nothing
1584 (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1585 buf <- hGetStringBuffer hspp_fn
1586 return (dflags', hspp_fn, buf)
1588 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1590 -- case we bypass the preprocessing stage?
1592 local_opts = getOptions buf src_fn
1594 (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
1598 | Just (Unlit _) <- mb_phase = True
1599 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
1600 -- note: local_opts is only required if there's no Unlit phase
1601 | dopt Opt_Cpp dflags' = True
1602 | dopt Opt_Pp dflags' = True
1605 when needs_preprocessing $
1606 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1608 return (dflags', src_fn, buf)
1611 -----------------------------------------------------------------------------
1613 -----------------------------------------------------------------------------
1615 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1616 -- ToDo: we don't have a proper line number for this error
1617 noModError dflags loc wanted_mod err
1618 = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1620 noHsFileErr loc path
1621 = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1624 = throwDyn $ mkPlainErrMsg noSrcSpan $
1625 text "module" <+> quotes (ppr mod) <+> text "is a package module"
1627 multiRootsErr :: [ModSummary] -> IO ()
1628 multiRootsErr summs@(summ1:_)
1629 = throwDyn $ mkPlainErrMsg noSrcSpan $
1630 text "module" <+> quotes (ppr mod) <+>
1631 text "is defined in multiple files:" <+>
1632 sep (map text files)
1635 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1637 cyclicModuleErr :: [ModSummary] -> SDoc
1639 = hang (ptext SLIT("Module imports form a cycle for modules:"))
1640 2 (vcat (map show_one ms))
1642 show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1643 nest 2 $ ptext SLIT("imports:") <+>
1644 (pp_imps HsBootFile (ms_srcimps ms)
1645 $$ pp_imps HsSrcFile (ms_imps ms))]
1646 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1647 pp_imps src mods = fsep (map (show_mod src) mods)
1650 -- | Inform GHC that the working directory has changed. GHC will flush
1651 -- its cache of module locations, since it may no longer be valid.
1652 -- Note: if you change the working directory, you should also unload
1653 -- the current program (set targets to empty, followed by load).
1654 workingDirectoryChanged :: Session -> IO ()
1655 workingDirectoryChanged s = withSession s $ flushFinderCaches
1657 -- -----------------------------------------------------------------------------
1658 -- inspecting the session
1660 -- | Get the module dependency graph.
1661 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1662 getModuleGraph s = withSession s (return . hsc_mod_graph)
1664 isLoaded :: Session -> ModuleName -> IO Bool
1665 isLoaded s m = withSession s $ \hsc_env ->
1666 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1668 getBindings :: Session -> IO [TyThing]
1669 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1671 getPrintUnqual :: Session -> IO PrintUnqualified
1672 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1674 -- | Container for information about a 'Module'.
1675 data ModuleInfo = ModuleInfo {
1676 minf_type_env :: TypeEnv,
1677 minf_exports :: NameSet,
1678 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
1679 minf_instances :: [Instance]
1680 -- ToDo: this should really contain the ModIface too
1682 -- We don't want HomeModInfo here, because a ModuleInfo applies
1683 -- to package modules too.
1685 -- | Request information about a loaded 'Module'
1686 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1687 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1688 let mg = hsc_mod_graph hsc_env
1689 if mdl `elem` map ms_mod mg
1690 then getHomeModuleInfo hsc_env (moduleName mdl)
1692 {- if isHomeModule (hsc_dflags hsc_env) mdl
1694 else -} getPackageModuleInfo hsc_env mdl
1695 -- getPackageModuleInfo will attempt to find the interface, so
1696 -- we don't want to call it for a home module, just in case there
1697 -- was a problem loading the module and the interface doesn't
1698 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
1700 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1701 getPackageModuleInfo hsc_env mdl = do
1703 (_msgs, mb_names) <- getModuleExports hsc_env mdl
1705 Nothing -> return Nothing
1707 eps <- readIORef (hsc_EPS hsc_env)
1710 n_list = nameSetToList names
1711 tys = [ ty | name <- n_list,
1712 Just ty <- [lookupTypeEnv pte name] ]
1714 return (Just (ModuleInfo {
1715 minf_type_env = mkTypeEnv tys,
1716 minf_exports = names,
1717 minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
1718 minf_instances = error "getModuleInfo: instances for package module unimplemented"
1721 -- bogusly different for non-GHCI (ToDo)
1725 getHomeModuleInfo hsc_env mdl =
1726 case lookupUFM (hsc_HPT hsc_env) mdl of
1727 Nothing -> return Nothing
1729 let details = hm_details hmi
1730 return (Just (ModuleInfo {
1731 minf_type_env = md_types details,
1732 minf_exports = md_exports details,
1733 minf_rdr_env = mi_globals $! hm_iface hmi,
1734 minf_instances = md_insts details
1737 -- | The list of top-level entities defined in a module
1738 modInfoTyThings :: ModuleInfo -> [TyThing]
1739 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1741 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1742 modInfoTopLevelScope minf
1743 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1745 modInfoExports :: ModuleInfo -> [Name]
1746 modInfoExports minf = nameSetToList $! minf_exports minf
1748 -- | Returns the instances defined by the specified module.
1749 -- Warning: currently unimplemented for package modules.
1750 modInfoInstances :: ModuleInfo -> [Instance]
1751 modInfoInstances = minf_instances
1753 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1754 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1756 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1757 modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
1759 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1760 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1761 case lookupTypeEnv (minf_type_env minf) name of
1762 Just tyThing -> return (Just tyThing)
1764 eps <- readIORef (hsc_EPS hsc_env)
1765 return $! lookupType (hsc_dflags hsc_env)
1766 (hsc_HPT hsc_env) (eps_PTE eps) name
1768 isDictonaryId :: Id -> Bool
1770 = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1772 -- | Looks up a global name: that is, any top-level name in any
1773 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
1774 -- the interactive context, and therefore does not require a preceding
1776 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1777 lookupGlobalName s name = withSession s $ \hsc_env -> do
1778 eps <- readIORef (hsc_EPS hsc_env)
1779 return $! lookupType (hsc_dflags hsc_env)
1780 (hsc_HPT hsc_env) (eps_PTE eps) name
1782 -- -----------------------------------------------------------------------------
1783 -- Misc exported utils
1785 dataConType :: DataCon -> Type
1786 dataConType dc = idType (dataConWrapId dc)
1788 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1789 pprParenSymName :: NamedThing a => a -> SDoc
1790 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1792 -- ----------------------------------------------------------------------------
1797 -- - Data and Typeable instances for HsSyn.
1799 -- ToDo: check for small transformations that happen to the syntax in
1800 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1802 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
1803 -- to get from TyCons, Ids etc. to TH syntax (reify).
1805 -- :browse will use either lm_toplev or inspect lm_interface, depending
1806 -- on whether the module is interpreted or not.
1808 -- This is for reconstructing refactored source code
1809 -- Calls the lexer repeatedly.
1810 -- ToDo: add comment tokens to token stream
1811 getTokenStream :: Session -> Module -> IO [Located Token]
1814 -- -----------------------------------------------------------------------------
1815 -- Interactive evaluation
1817 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
1818 -- filesystem and package database to find the corresponding 'Module',
1819 -- using the algorithm that is used for an @import@ declaration.
1820 findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
1821 findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
1822 findModule' hsc_env mod_name maybe_pkg
1824 findModule' hsc_env mod_name maybe_pkg =
1826 dflags = hsc_dflags hsc_env
1827 hpt = hsc_HPT hsc_env
1828 this_pkg = thisPackage dflags
1830 case lookupUFM hpt mod_name of
1831 Just mod_info -> return (mi_module (hm_iface mod_info))
1832 _not_a_home_module -> do
1833 res <- findImportedModule hsc_env mod_name Nothing
1835 Found _ m | modulePackageId m /= this_pkg -> return m
1836 | otherwise -> throwDyn (CmdLineError (showSDoc $
1837 text "module" <+> pprModule m <+>
1838 text "is not loaded"))
1839 err -> let msg = cannotFindModule dflags mod_name err in
1840 throwDyn (CmdLineError (showSDoc msg))
1844 -- | Set the interactive evaluation context.
1846 -- Setting the context doesn't throw away any bindings; the bindings
1847 -- we've built up in the InteractiveContext simply move to the new
1848 -- module. They always shadow anything in scope in the current context.
1849 setContext :: Session
1850 -> [Module] -- entire top level scope of these modules
1851 -> [Module] -- exports only of these modules
1853 setContext (Session ref) toplev_mods export_mods = do
1854 hsc_env <- readIORef ref
1855 let old_ic = hsc_IC hsc_env
1856 hpt = hsc_HPT hsc_env
1858 export_env <- mkExportEnv hsc_env export_mods
1859 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
1860 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1861 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
1862 ic_exports = export_mods,
1863 ic_rn_gbl_env = all_env }}
1866 -- Make a GlobalRdrEnv based on the exports of the modules only.
1867 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1868 mkExportEnv hsc_env mods = do
1869 stuff <- mapM (getModuleExports hsc_env) mods
1871 (_msgs, mb_name_sets) = unzip stuff
1872 gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod)
1873 | (Just name_set, mod) <- zip mb_name_sets mods ]
1875 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1877 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
1878 nameSetToGlobalRdrEnv names mod =
1879 mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1880 | name <- nameSetToList names ]
1882 vanillaProv :: ModuleName -> Provenance
1883 -- We're building a GlobalRdrEnv as if the user imported
1884 -- all the specified modules into the global interactive module
1885 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
1887 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1889 is_dloc = srcLocSpan interactiveSrcLoc }
1891 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1892 mkTopLevEnv hpt modl
1893 = case lookupUFM hpt (moduleName modl) of
1894 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
1895 showSDoc (ppr modl)))
1897 case mi_globals (hm_iface details) of
1899 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1900 ++ showSDoc (ppr modl)))
1901 Just env -> return env
1903 -- | Get the interactive evaluation context, consisting of a pair of the
1904 -- set of modules from which we take the full top-level scope, and the set
1905 -- of modules from which we take just the exports respectively.
1906 getContext :: Session -> IO ([Module],[Module])
1907 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1908 return (ic_toplev_scope ic, ic_exports ic))
1910 -- | Returns 'True' if the specified module is interpreted, and hence has
1911 -- its full top-level scope available.
1912 moduleIsInterpreted :: Session -> Module -> IO Bool
1913 moduleIsInterpreted s modl = withSession s $ \h ->
1914 if modulePackageId modl /= thisPackage (hsc_dflags h)
1916 else case lookupUFM (hsc_HPT h) (moduleName modl) of
1917 Just details -> return (isJust (mi_globals (hm_iface details)))
1918 _not_a_home_module -> return False
1920 -- | Looks up an identifier in the current interactive context (for :info)
1921 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
1922 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
1924 -- | Returns all names in scope in the current interactive context
1925 getNamesInScope :: Session -> IO [Name]
1926 getNamesInScope s = withSession s $ \hsc_env -> do
1927 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
1929 getRdrNamesInScope :: Session -> IO [RdrName]
1930 getRdrNamesInScope s = withSession s $ \hsc_env -> do
1931 let env = ic_rn_gbl_env (hsc_IC hsc_env)
1932 return (concat (map greToRdrNames (globalRdrEnvElts env)))
1934 -- ToDo: move to RdrName
1935 greToRdrNames :: GlobalRdrElt -> [RdrName]
1936 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
1938 LocalDef -> [unqual]
1939 Imported specs -> concat (map do_spec (map is_decl specs))
1941 occ = nameOccName name
1944 | is_qual decl_spec = [qual]
1945 | otherwise = [unqual,qual]
1946 where qual = Qual (is_as decl_spec) occ
1948 -- | Parses a string as an identifier, and returns the list of 'Name's that
1949 -- the identifier can refer to in the current interactive context.
1950 parseName :: Session -> String -> IO [Name]
1951 parseName s str = withSession s $ \hsc_env -> do
1952 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
1953 case maybe_rdr_name of
1954 Nothing -> return []
1955 Just (L _ rdr_name) -> do
1956 mb_names <- tcRnLookupRdrName hsc_env rdr_name
1958 Nothing -> return []
1959 Just ns -> return ns
1960 -- ToDo: should return error messages
1962 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
1963 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1964 lookupName :: Session -> Name -> IO (Maybe TyThing)
1965 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
1967 -- -----------------------------------------------------------------------------
1968 -- Getting the type of an expression
1970 -- | Get the type of an expression
1971 exprType :: Session -> String -> IO (Maybe Type)
1972 exprType s expr = withSession s $ \hsc_env -> do
1973 maybe_stuff <- hscTcExpr hsc_env expr
1975 Nothing -> return Nothing
1976 Just ty -> return (Just tidy_ty)
1978 tidy_ty = tidyType emptyTidyEnv ty
1980 -- -----------------------------------------------------------------------------
1981 -- Getting the kind of a type
1983 -- | Get the kind of a type
1984 typeKind :: Session -> String -> IO (Maybe Kind)
1985 typeKind s str = withSession s $ \hsc_env -> do
1986 maybe_stuff <- hscKcType hsc_env str
1988 Nothing -> return Nothing
1989 Just kind -> return (Just kind)
1991 -----------------------------------------------------------------------------
1992 -- cmCompileExpr: compile an expression and deliver an HValue
1994 compileExpr :: Session -> String -> IO (Maybe HValue)
1995 compileExpr s expr = withSession s $ \hsc_env -> do
1996 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
1998 Nothing -> return Nothing
1999 Just (new_ic, names, hval) -> do
2001 hvals <- (unsafeCoerce# hval) :: IO [HValue]
2003 case (names,hvals) of
2004 ([n],[hv]) -> return (Just hv)
2005 _ -> panic "compileExpr"
2007 -- -----------------------------------------------------------------------------
2008 -- Compile an expression into a dynamic
2010 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
2011 dynCompileExpr ses expr = do
2012 (full,exports) <- getContext ses
2013 setContext ses full $
2015 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
2017 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
2018 res <- withSession ses (flip hscStmt stmt)
2019 setContext ses full exports
2021 Nothing -> return Nothing
2022 Just (_, names, hvals) -> do
2023 vals <- (unsafeCoerce# hvals :: IO [Dynamic])
2024 case (names,vals) of
2025 (_:[], v:[]) -> return (Just v)
2026 _ -> panic "dynCompileExpr"
2028 -- -----------------------------------------------------------------------------
2029 -- running a statement interactively
2032 = RunOk [Name] -- ^ names bound by this evaluation
2033 | RunFailed -- ^ statement failed compilation
2034 | RunException Exception -- ^ statement raised an exception
2036 -- | Run a statement in the current interactive context. Statemenet
2037 -- may bind multple values.
2038 runStmt :: Session -> String -> IO RunResult
2039 runStmt (Session ref) expr
2041 hsc_env <- readIORef ref
2043 -- Turn off -fwarn-unused-bindings when running a statement, to hide
2044 -- warnings about the implicit bindings we introduce.
2045 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
2046 hsc_env' = hsc_env{ hsc_dflags = dflags' }
2048 maybe_stuff <- hscStmt hsc_env' expr
2051 Nothing -> return RunFailed
2052 Just (new_hsc_env, names, hval) -> do
2054 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
2055 either_hvals <- sandboxIO thing_to_run
2057 case either_hvals of
2059 -- on error, keep the *old* interactive context,
2060 -- so that 'it' is not bound to something
2061 -- that doesn't exist.
2062 return (RunException e)
2065 -- Get the newly bound things, and bind them.
2066 -- Don't need to delete any shadowed bindings;
2067 -- the new ones override the old ones.
2068 extendLinkEnv (zip names hvals)
2070 writeIORef ref new_hsc_env
2071 return (RunOk names)
2073 -- When running a computation, we redirect ^C exceptions to the running
2074 -- thread. ToDo: we might want a way to continue even if the target
2075 -- thread doesn't die when it receives the exception... "this thread
2076 -- is not responding".
2077 sandboxIO :: IO a -> IO (Either Exception a)
2078 sandboxIO thing = do
2080 ts <- takeMVar interruptTargetThread
2081 child <- forkIO (do res <- Exception.try thing; putMVar m res)
2082 putMVar interruptTargetThread (child:ts)
2083 takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
2086 -- This version of sandboxIO runs the expression in a completely new
2087 -- RTS main thread. It is disabled for now because ^C exceptions
2088 -- won't be delivered to the new thread, instead they'll be delivered
2089 -- to the (blocked) GHCi main thread.
2091 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
2093 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
2094 sandboxIO thing = do
2095 st_thing <- newStablePtr (Exception.try thing)
2096 alloca $ \ p_st_result -> do
2097 stat <- rts_evalStableIO st_thing p_st_result
2098 freeStablePtr st_thing
2100 then do st_result <- peek p_st_result
2101 result <- deRefStablePtr st_result
2102 freeStablePtr st_result
2103 return (Right result)
2105 return (Left (fromIntegral stat))
2107 foreign import "rts_evalStableIO" {- safe -}
2108 rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
2109 -- more informative than the C type!
2112 -----------------------------------------------------------------------------
2113 -- show a module and it's source/object filenames
2115 showModule :: Session -> ModSummary -> IO String
2116 showModule s mod_summary = withSession s $ \hsc_env -> do
2117 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
2118 Nothing -> panic "missing linkable"
2119 Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
2121 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))