207f5a39f0838daae3603c0f2a682f3b807e1417
[ghc.git] / compiler / main / GHC.hs
1 -- -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2005
4 --
5 -- The GHC API
6 --
7 -- -----------------------------------------------------------------------------
8
9 module GHC (
10 -- * Initialisation
11 Session,
12 defaultErrorHandler,
13 defaultCleanupHandler,
14 init, initFromArgs,
15 newSession,
16
17 -- * Flags and settings
18 DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
19 parseDynamicFlags,
20 initPackages,
21 getSessionDynFlags,
22 setSessionDynFlags,
23
24 -- * Targets
25 Target(..), TargetId(..), Phase,
26 setTargets,
27 getTargets,
28 addTarget,
29 removeTarget,
30 guessTarget,
31
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 ()
37
38 -- * Loading\/compiling the program
39 depanal,
40 load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
41 workingDirectoryChanged,
42 checkModule, CheckedModule(..),
43 TypecheckedSource, ParsedSource, RenamedSource,
44
45 -- * Inspecting the module structure of the program
46 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
47 getModuleGraph,
48 isLoaded,
49 topSortModuleGraph,
50
51 -- * Inspecting modules
52 ModuleInfo,
53 getModuleInfo,
54 modInfoTyThings,
55 modInfoTopLevelScope,
56 modInfoPrintUnqualified,
57 modInfoExports,
58 modInfoInstances,
59 modInfoIsExportedName,
60 modInfoLookupName,
61 lookupGlobalName,
62
63 -- * Printing
64 PrintUnqualified, alwaysQualify,
65
66 -- * Interactive evaluation
67 getBindings, getPrintUnqual,
68 findModule,
69 #ifdef GHCI
70 setContext, getContext,
71 getNamesInScope,
72 getRdrNamesInScope,
73 moduleIsInterpreted,
74 getInfo,
75 exprType,
76 typeKind,
77 parseName,
78 RunResult(..),
79 runStmt,
80 showModule,
81 compileExpr, HValue,
82 lookupName,
83 #endif
84
85 -- * Abstract syntax elements
86
87 -- ** Packages
88 PackageId,
89
90 -- ** Modules
91 Module, mkModule, pprModule, moduleName, modulePackageId,
92 ModuleName, mkModuleName, moduleNameString,
93
94 -- ** Names
95 Name,
96 nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
97 NamedThing(..),
98 RdrName(Qual,Unqual),
99
100 -- ** Identifiers
101 Id, idType,
102 isImplicitId, isDeadBinder,
103 isExportedId, isLocalId, isGlobalId,
104 isRecordSelector,
105 isPrimOpId, isFCallId, isClassOpId_maybe,
106 isDataConWorkId, idDataCon,
107 isBottomingId, isDictonaryId,
108 recordSelectorFieldLabel,
109
110 -- ** Type constructors
111 TyCon,
112 tyConTyVars, tyConDataCons, tyConArity,
113 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
114 synTyConDefn, synTyConRhs,
115
116 -- ** Type variables
117 TyVar,
118 alphaTyVars,
119
120 -- ** Data constructors
121 DataCon,
122 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
123 dataConIsInfix, isVanillaDataCon,
124 dataConStrictMarks,
125 StrictnessMark(..), isMarkedStrict,
126
127 -- ** Classes
128 Class,
129 classMethods, classSCTheta, classTvsFds,
130 pprFundeps,
131
132 -- ** Instances
133 Instance,
134 instanceDFunId, pprInstance, pprInstanceHdr,
135
136 -- ** Types and Kinds
137 Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
138 Kind,
139 PredType,
140 ThetaType, pprThetaArrow,
141
142 -- ** Entities
143 TyThing(..),
144
145 -- ** Syntax
146 module HsSyn, -- ToDo: remove extraneous bits
147
148 -- ** Fixities
149 FixityDirection(..),
150 defaultFixity, maxPrecedence,
151 negateFixity,
152 compareFixity,
153
154 -- ** Source locations
155 SrcLoc, pprDefnLoc,
156
157 -- * Exceptions
158 GhcException(..), showGhcException,
159
160 -- * Miscellaneous
161 sessionHscEnv,
162 cyclicModuleErr,
163 ) where
164
165 {-
166 ToDo:
167
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?
172 -}
173
174 #include "HsVersions.h"
175
176 #ifdef GHCI
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(..),
183 mkGlobalRdrEnv )
184 import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
185 import Name ( nameOccName )
186 import Type ( tidyType )
187 import VarEnv ( emptyTidyEnv )
188 import GHC.Exts ( unsafeCoerce# )
189 #endif
190
191 import Packages ( initPackages )
192 import NameSet ( NameSet, nameSetToList, elemNameSet )
193 import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
194 globalRdrEnvElts, extendGlobalRdrEnv,
195 emptyGlobalRdrEnv )
196 import HsSyn
197 import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
198 pprThetaArrow, pprParendType, splitForAllTys,
199 funResultTy )
200 import Id ( Id, idType, isImplicitId, isDeadBinder,
201 isExportedId, isLocalId, isGlobalId,
202 isRecordSelector, recordSelectorFieldLabel,
203 isPrimOpId, isFCallId, isClassOpId_maybe,
204 isDataConWorkId, idDataCon,
205 isBottomingId )
206 import Var ( TyVar )
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,
217 nameSrcLoc )
218 import OccName ( parenSymOcc )
219 import NameEnv ( nameEnvElts )
220 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
221 import SrcLoc
222 import DriverPipeline
223 import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
224 import HeaderInfo ( getImports, getOptions )
225 import Finder
226 import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
227 import HscTypes
228 import DynFlags
229 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
230 cleanTempDirs )
231 import Module
232 import UniqFM
233 import PackageConfig ( PackageId )
234 import FiniteMap
235 import Panic
236 import Digraph
237 import Bag ( unitBag )
238 import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
239 mkPlainErrMsg, printBagOfErrors )
240 import qualified ErrUtils
241 import Util
242 import StringBuffer ( StringBuffer, hGetStringBuffer )
243 import Outputable
244 import BasicTypes
245 import TcType ( tcSplitSigmaTy, isDictTy )
246 import Maybes ( expectJust, mapCatMaybes )
247
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)
257 import Data.IORef
258 import System.IO
259 import System.IO.Error ( isDoesNotExistError )
260 import Prelude hiding (init)
261
262 #if __GLASGOW_HASKELL__ < 600
263 import System.IO as System.IO.Error ( try )
264 #else
265 import System.IO.Error ( try )
266 #endif
267
268 -- -----------------------------------------------------------------------------
269 -- Exception handlers
270
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
279 hFlush stdout
280 case exception of
281 -- an IO exception probably isn't our fault, so don't panic
282 IOException _ ->
283 fatalErrorMsg dflags (text (show exception))
284 AsyncException StackOverflow ->
285 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
286 _other ->
287 fatalErrorMsg dflags (text (show (Panic (show exception))))
288 exitWith (ExitFailure 1)
289 ) $
290
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)) $
295
296 -- error messages propagated as exceptions
297 handleDyn (\dyn -> do
298 hFlush stdout
299 case dyn of
300 PhaseFailed _ code -> exitWith code
301 Interrupted -> exitWith (ExitFailure 1)
302 _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
303 exitWith (ExitFailure 1)
304 ) $
305 inner
306
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
316 cleanTempDirs dflags
317 )
318 -- exceptions will be blocked while we clean the temporary files,
319 -- so there shouldn't be any difficulty if we receive further
320 -- signals.
321 inner
322
323
324 -- | Initialises GHC. This must be done /once/ only. Takes the
325 -- TopDir path without the '-B' prefix.
326
327 init :: Maybe String -> IO ()
328 init mbMinusB = do
329 -- catch ^C
330 main_thread <- myThreadId
331 putMVar interruptTargetThread [main_thread]
332 installSignalHandlers
333
334 dflags0 <- initSysTools mbMinusB defaultDynFlags
335 writeIORef v_initDynFlags dflags0
336
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.
340
341 initFromArgs :: [String] -> IO [String]
342 initFromArgs args
343 = do init mbMinusB
344 return argv1
345 where -- Grab the -B option if there is one
346 (minusB_args, argv1) = partition (prefixMatch "-B") args
347 mbMinusB | null minusB_args
348 = Nothing
349 | otherwise
350 = Just (drop 2 (last minusB_args))
351
352 GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
353 -- stores the DynFlags between the call to init and subsequent
354 -- calls to newSession.
355
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
359 -- code".
360 newSession :: GhcMode -> IO Session
361 newSession mode = do
362 dflags0 <- readIORef v_initDynFlags
363 dflags <- initDynFlags dflags0
364 env <- newHscEnv dflags{ ghcMode=mode }
365 ref <- newIORef env
366 return (Session ref)
367
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
372
373 withSession :: Session -> (HscEnv -> IO a) -> IO a
374 withSession (Session ref) f = do h <- readIORef ref; f h
375
376 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
377 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
378
379 -- -----------------------------------------------------------------------------
380 -- Flags & settings
381
382 -- | Grabs the DynFlags from the Session
383 getSessionDynFlags :: Session -> IO DynFlags
384 getSessionDynFlags s = withSession s (return . hsc_dflags)
385
386 -- | Updates the DynFlags in a Session
387 setSessionDynFlags :: Session -> DynFlags -> IO ()
388 setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
389
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
402 in
403 case outputFile dflags of
404 Just _ -> env
405 Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
406
407 -- -----------------------------------------------------------------------------
408 -- Targets
409
410 -- ToDo: think about relative vs. absolute file paths. And what
411 -- happens when the current directory changes.
412
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 })
419
420 -- | returns the current set of targets
421 getTargets :: Session -> IO [Target]
422 getTargets s = withSession s (return . hsc_targets)
423
424 -- | Add another target
425 addTarget :: Session -> Target -> IO ()
426 addTarget s target
427 = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
428
429 -- | Remove a target
430 removeTarget :: Session -> TargetId -> IO ()
431 removeTarget s target_id
432 = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
433 where
434 filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
435
436 -- Attempts to guess what Target a string refers to. This function implements
437 -- the --make/GHCi command-line syntax for filenames:
438 --
439 -- - if the string looks like a Haskell source filename, then interpret
440 -- it as such
441 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
442 -- then use that
443 -- - otherwise interpret the string as a module name
444 --
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)
451 | otherwise
452 = do exists <- doesFileExist hs_file
453 if exists
454 then return (Target (TargetFile hs_file Nothing) Nothing)
455 else do
456 exists <- doesFileExist lhs_file
457 if exists
458 then return (Target (TargetFile lhs_file Nothing) Nothing)
459 else do
460 return (Target (TargetModule (mkModuleName file)) Nothing)
461 where
462 hs_file = file `joinFileExt` "hs"
463 lhs_file = file `joinFileExt` "lhs"
464
465 -- -----------------------------------------------------------------------------
466 -- Extending the program scope
467
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 }
473
474 setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
475 setGlobalRdrScope session rdrElts
476 = modifySession session $ \hscEnv ->
477 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
478
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 }
484
485 setGlobalTypeScope :: Session -> [Id] -> IO ()
486 setGlobalTypeScope session ids
487 = modifySession session $ \hscEnv ->
488 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
489
490 -- -----------------------------------------------------------------------------
491 -- Loading the program
492
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
498 let
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
503
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))])
509
510 r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
511 case r of
512 Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
513 _ -> return ()
514 return r
515
516 {-
517 -- | The result of load.
518 data LoadResult
519 = LoadOk Errors -- ^ all specified targets were loaded successfully.
520 | LoadFailed Errors -- ^ not all modules were loaded.
521
522 type Errors = [String]
523
524 data ErrMsg = ErrMsg {
525 errMsgSeverity :: Severity, -- warning, error, etc.
526 errMsgSpans :: [SrcSpan],
527 errMsgShortDoc :: Doc,
528 errMsgExtraInfo :: Doc
529 }
530 -}
531
532 data LoadHowMuch
533 = LoadAllTargets
534 | LoadUpTo ModuleName
535 | LoadDependenciesOf ModuleName
536
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
542 = do
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
548 case mb_graph of
549 Just mod_graph -> load2 s how_much mod_graph
550 Nothing -> return Failed
551
552 load2 s@(Session ref) how_much mod_graph = do
553 guessOutputFile s
554 hsc_env <- readIORef ref
555
556 let hpt1 = hsc_HPT hsc_env
557 let dflags = hsc_dflags hsc_env
558 let ghci_mode = ghcMode dflags -- this never changes
559
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
563 -- (see msDeps)
564 let all_home_mods = [ms_mod_name s
565 | s <- mod_graph, not (isBootSummary s)]
566 #ifdef DEBUG
567 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
568 not (ms_mod_name s `elem` all_home_mods)]
569 #endif
570 ASSERT( null bad_boot_mods ) return ()
571
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
579
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
584
585 -- prune bits of the HPT which are definitely redundant now,
586 -- to save space.
587 pruned_hpt = pruneHomePackageTable hpt1
588 (flattenSCCs mg2_with_srcimps)
589 stable_mods
590
591 evaluate pruned_hpt
592
593 debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
594 text "Stable BCO:" <+> ppr stable_bco)
595
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
602
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)))
609
610 -- Now do the upsweep, calling compile for each module in
611 -- turn. Final result is version 3 of everything.
612
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
621
622 maybe_top_mod = case how_much of
623 LoadUpTo m -> Just m
624 LoadDependenciesOf m -> Just m
625 _ -> Nothing
626
627 partial_mg0 :: [SCC ModSummary]
628 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
629
630 -- LoadDependenciesOf m: we want the upsweep to stop just
631 -- short of the specified module (unless the specified module
632 -- is stable).
633 partial_mg
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
638 | otherwise
639 = partial_mg0
640
641 stable_mg =
642 [ AcyclicSCC ms
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 ] ]
647
648 mg = stable_mg ++ partial_mg
649
650 -- clean up between compilations
651 let cleanup = cleanTempFilesExcept dflags
652 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
653
654 (upsweep_ok, hsc_env1, modsUpswept)
655 <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
656 pruned_hpt stable_mods cleanup mg
657
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).
661
662 let modsDone = reverse modsUpswept
663
664 -- Try and do linking in some form, depending on whether the
665 -- upsweep was completely or only partially successful.
666
667 if succeeded upsweep_ok
668
669 then
670 -- Easy; just relink it all.
671 do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
672
673 -- Clean up after ourselves
674 cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
675
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.
681 --
682 let ofile = outputFile dflags
683 let no_hs_main = dopt Opt_NoHsMain dflags
684 let
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
688
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."))
693
694 -- link everything together
695 linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
696
697 loadFinish Succeeded linkresult ref hsc_env1
698
699 else
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.")
704
705 let modsDone_names
706 = map ms_mod modsDone
707 let mods_to_zap_names
708 = findPartiallyCompletedCycles modsDone_names
709 mg2_with_srcimps
710 let mods_to_keep
711 = filter ((`notElem` mods_to_zap_names).ms_mod)
712 modsDone
713
714 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
715 (hsc_HPT hsc_env1)
716
717 -- Clean up after ourselves
718 cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
719
720 -- there should be no Nothings where linkables should be, now
721 ASSERT(all (isJust.hm_linkable)
722 (eltsUFM (hsc_HPT hsc_env))) do
723
724 -- Link everything together
725 linkresult <- link ghci_mode dflags False hpt4
726
727 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
728 loadFinish Failed linkresult ref hsc_env4
729
730 -- Finish up after a load.
731
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
736 return Failed
737
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 }
742 return all_ok
743
744
745 -- Forget the current program, but retain the persistent info in HscEnv
746 discardProg :: HscEnv -> HscEnv
747 discardProg hsc_env
748 = hsc_env { hsc_mod_graph = emptyMG,
749 hsc_IC = emptyInteractiveContext,
750 hsc_HPT = emptyHomePackageTable }
751
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
756
757 -- -----------------------------------------------------------------------------
758 -- Check module
759
760 data CheckedModule =
761 CheckedModule { parsedSource :: ParsedSource,
762 renamedSource :: Maybe RenamedSource,
763 typecheckedSource :: Maybe TypecheckedSource,
764 checkedModuleInfo :: Maybe ModuleInfo
765 }
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.
771
772 type ParsedSource = Located (HsModule RdrName)
773 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
774 type TypecheckedSource = LHsBinds Id
775
776 -- NOTE:
777 -- - things that aren't in the output of the typechecker right now:
778 -- - the export list
779 -- - the imports
780 -- - type signatures
781 -- - type/data/newtype declarations
782 -- - class declarations
783 -- - instances
784 -- - extra things in the typechecker's output:
785 -- - default methods are turned into top-level decls.
786 -- - dictionary bindings
787
788
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
798
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
803 [] -> return Nothing
804 (ms:_) -> do
805 mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
806 case mbChecked of
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
821 }
822 return (Just (CheckedModule {
823 parsedSource = parsed,
824 renamedSource = renamed,
825 typecheckedSource = Just tc_binds,
826 checkedModuleInfo = Just minf }))
827
828 -- ---------------------------------------------------------------------------
829 -- Unloading
830
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 ()
836 #ifdef GHCI
837 Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
838 #else
839 Interactive -> panic "unload: no interpreter"
840 #endif
841 other -> panic "unload: strange mode"
842
843 -- -----------------------------------------------------------------------------
844 -- checkStability
845
846 {-
847 Stability tells us which modules definitely do not need to be recompiled.
848 There are two main reasons for having stability:
849
850 - avoid doing a complete upsweep of the module graph in GHCi when
851 modules near the bottom of the tree have not changed.
852
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.
857
858 NB. stability is of no importance to BatchCompile at all, only Interactive.
859 (ToDo: what about JustTypecheck?)
860
861 The stability check is as follows. Both stableObject and
862 stableBCO are used during the upsweep phase later.
863
864 -------------------
865 stable m = stableObject m || stableBCO m
866
867 stableObject m =
868 all stableObject (imports m)
869 && old linkable does not exist, or is == on-disk .o
870 && date(on-disk .o) > date(.hs)
871
872 stableBCO m =
873 all stable (imports m)
874 && date(BCO) > date(.hs)
875 -------------------
876
877 These properties embody the following ideas:
878
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.
885
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
889 before the upsweep.
890
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.
893 -}
894
895 checkStability
896 :: HomePackageTable -- HPT from last compilation
897 -> [SCC ModSummary] -- current module graph (cyclic)
898 -> [ModuleName] -- all home modules
899 -> ([ModuleName], -- stableObject
900 [ModuleName]) -- stableBCO
901
902 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
903 where
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)
908 where
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
912
913 scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
914 -- all imports outside the current SCC, but in the home pkg
915
916 stable_obj_imps = map (`elem` stable_obj) scc_allimps
917 stable_bco_imps = map (`elem` stable_bco) scc_allimps
918
919 stableObjects =
920 and stable_obj_imps
921 && all object_ok scc
922
923 stableBCOs =
924 and (zipWith (||) stable_obj_imps stable_bco_imps)
925 && all bco_ok scc
926
927 object_ok ms
928 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
929 && same_as_prev t
930 | otherwise = False
931 where
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
935 _other -> True
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
941 -- make's behaviour.
942
943 bco_ok ms
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
948 _other -> False
949
950 ms_allimps :: ModSummary -> [ModuleName]
951 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
952
953 -- -----------------------------------------------------------------------------
954 -- Prune the HomePackageTable
955
956 -- Before doing an upsweep, we can throw away:
957 --
958 -- - For non-stable modules:
959 -- - all ModDetails, all linked code
960 -- - all unlinked code that is out of date with respect to
961 -- the source file
962 --
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
966 -- compilation.
967
968 pruneHomePackageTable
969 :: HomePackageTable
970 -> [ModSummary]
971 -> ([ModuleName],[ModuleName])
972 -> HomePackageTable
973
974 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
975 = mapUFM prune hpt
976 where prune hmi
977 | is_stable modl = hmi'
978 | otherwise = hmi'{ hm_details = emptyModDetails }
979 where
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 }
983 | otherwise
984 = hmi
985 where ms = expectJust "prune" (lookupUFM ms_map modl)
986
987 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
988
989 is_stable m = m `elem` stable_obj || m `elem` stable_bco
990
991 -- -----------------------------------------------------------------------------
992
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
997 = chew theGraph
998 where
999 chew [] = []
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)
1003 mods_in_this_cycle
1004 = nub ([done | done <- modsDone,
1005 done `elem` names_in_this_cycle])
1006 chewed_rest = chew rest
1007 in
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
1011 else chewed_rest
1012
1013 -- -----------------------------------------------------------------------------
1014 -- The upsweep
1015
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.
1018
1019 -- There better had not be any cyclic groups here -- we check for them.
1020
1021 upsweep
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)
1027 -> IO (SuccessFlag,
1028 HscEnv, -- With an updated HPT
1029 [ModSummary]) -- Mods which succeeded
1030
1031 upsweep hsc_env old_hpt stable_mods cleanup mods
1032 = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
1033
1034 upsweep' hsc_env old_hpt stable_mods cleanup
1035 [] _ _
1036 = return (Succeeded, hsc_env, [])
1037
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, [])
1042
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)))
1048
1049 mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
1050 mod_index nmods
1051
1052 cleanup -- Remove unwanted tmp files between compilations
1053
1054 case mb_mod_info of
1055 Nothing -> return (Failed, hsc_env, [])
1056 Just mod_info -> do
1057 { let this_mod = ms_mod_name mod
1058
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 }
1062
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
1071
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)
1076 }
1077
1078
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
1082 -> HomePackageTable
1083 -> ([ModuleName],[ModuleName])
1084 -> ModSummary
1085 -> Int -- index of module
1086 -> Int -- total number of modules
1087 -> IO (Maybe HomeModInfo) -- Nothing => Failed
1088
1089 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1090 = do
1091 let
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
1097
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
1101
1102 case ghcMode (hsc_dflags hsc_env) of
1103 BatchCompile ->
1104 case () 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
1109 linkable <-
1110 findObjectLinkable this_mod obj_fn obj_date
1111 compile_it (Just linkable)
1112
1113 | otherwise ->
1114 compile_it Nothing
1115
1116 interactive ->
1117 case () of
1118 _ | is_stable_obj, isJust old_hmi ->
1119 return old_hmi
1120 -- object is stable, and we have an entry in the
1121 -- old HPT: nothing to do
1122
1123 | is_stable_obj, isNothing old_hmi -> do
1124 linkable <-
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.
1130
1131 | is_stable_bco ->
1132 ASSERT(isJust old_hmi) -- must be in the old_hpt
1133 return old_hmi
1134 -- BCO is stable: nothing to do
1135
1136 | Just hmi <- old_hmi,
1137 Just l <- hm_linkable hmi, not (isObjectLinkable l),
1138 linkableTime l >= ms_hs_date summary ->
1139 compile_it (Just l)
1140 -- we have an old BCO that is up to date with respect
1141 -- to the source: do a recompilation check as normal.
1142
1143 | otherwise ->
1144 compile_it Nothing
1145 -- no existing code at all: we must recompile.
1146 where
1147 is_stable_obj = this_mod_name `elem` stable_obj
1148 is_stable_bco = this_mod_name `elem` stable_bco
1149
1150 old_hmi = lookupUFM old_hpt this_mod_name
1151
1152 -- Run hsc to compile a module
1153 upsweep_compile hsc_env old_hpt this_mod summary
1154 mod_index nmods
1155 mb_old_linkable = do
1156 let
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
1165
1166 mb_old_iface
1167 = case lookupUFM old_hpt this_mod of
1168 Nothing -> Nothing
1169 Just hm_info | isBootSummary summary -> Just iface
1170 | not (mi_boot iface) -> Just iface
1171 | otherwise -> Nothing
1172 where
1173 iface = hm_iface hm_info
1174
1175 compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
1176 mod_index nmods
1177
1178 case compresult of
1179 -- Compilation failed. Compile may still have updated the PCS, tho.
1180 CompErrs -> return Nothing
1181
1182 -- Compilation "succeeded", and may or may not have returned a new
1183 -- linkable (depending on whether compilation was actually performed
1184 -- or not).
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)
1190
1191
1192 -- Filter modules in the HPT
1193 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1194 retainInTopLevelEnvs keep_these hpt
1195 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1196 | mod <- keep_these
1197 , let mb_mod_info = lookupUFM hpt mod
1198 , isJust mb_mod_info ]
1199
1200 -- ---------------------------------------------------------------------------
1201 -- Topological sort of the module graph
1202
1203 topSortModuleGraph
1204 :: Bool -- Drop hi-boot nodes? (see below)
1205 -> [ModSummary]
1206 -> Maybe ModuleName
1207 -> [SCC ModSummary]
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
1212 -- the top.
1213 --
1214 -- Drop hi-boot nodes (first boolean arg)?
1215 --
1216 -- False: treat the hi-boot summaries as nodes of the graph,
1217 -- so the graph must be acyclic
1218 --
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
1222
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))
1227 where
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
1234 root
1235 | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1236 | otherwise = throwDyn (ProgramError "module does not exist")
1237
1238 moduleGraphNodes :: Bool -> [ModSummary]
1239 -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
1240 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1241 where
1242 -- Drop hs-boot nodes by using HsSrcFile as the key
1243 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1244 | otherwise = HsBootFile
1245
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)) )
1251 | s <- summaries
1252 , not (isBootSummary s && drop_hs_boot_nodes) ]
1253 -- Drop the hi-boot ones if told to do so
1254
1255 key_map :: NodeMap Int
1256 key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
1257 | s <- summaries]
1258 `zip` [1..])
1259
1260 lookup_key :: HscSource -> ModuleName -> Maybe Int
1261 lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1262
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
1267
1268
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
1271
1272 msKey :: ModSummary -> NodeKey
1273 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1274
1275 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1276 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1277
1278 nodeMapElts :: NodeMap a -> [a]
1279 nodeMapElts = eltsFM
1280
1281 ms_mod_name :: ModSummary -> ModuleName
1282 ms_mod_name = moduleName . ms_mod
1283
1284 -----------------------------------------------------------------------------
1285 -- Downsweep (dependency analysis)
1286
1287 -- Chase downwards from the specified root set, returning summaries
1288 -- for all home modules encountered. Only follow source-import
1289 -- links.
1290
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
1293 -- unchanged.
1294 --
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.
1298
1299 downsweep :: HscEnv
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
1317 return (Just summs)
1318 where
1319 roots = hsc_targets hsc_env
1320
1321 old_summary_map :: NodeMap ModSummary
1322 old_summary_map = mkNodeMap old_summaries
1323
1324 getRootSummary :: Target -> IO ModSummary
1325 getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1326 = do exists <- doesFileExist file
1327 if exists
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
1336 Just s -> return s
1337
1338 rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
1339
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)
1349 where
1350 dup_roots :: [[ModSummary]] -- Each at least of length 2
1351 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1352
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
1359 -> IO [ModSummary]
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
1366 loop ss done
1367 else
1368 do { multiRootsErr summs; return [] }
1369 | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
1370 is_boot wanted_mod Nothing excl_mods
1371 ; case mb_s of
1372 Nothing -> loop ss done
1373 Just s -> loop (msDeps s ++ ss)
1374 (addToFM done key [s]) }
1375 where
1376 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1377
1378 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1379 mkRootMap summaries = addListToFM_C (++) emptyFM
1380 [ (msKey s, [s]) | s <- summaries ]
1381
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
1391 msDeps s =
1392 concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1393 ++ [ (m,False) | m <- ms_imps s ]
1394
1395 -----------------------------------------------------------------------------
1396 -- Summarising modules
1397
1398 -- We have two types of summarisation:
1399 --
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.
1403 --
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
1406 -- resides.
1407
1408 summariseFile
1409 :: HscEnv
1410 -> [ModSummary] -- old summaries
1411 -> FilePath -- source file name
1412 -> Maybe Phase -- start phase
1413 -> Maybe (StringBuffer,ClockTime)
1414 -> IO ModSummary
1415
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
1421 = do
1422 let location = ms_location old_summary
1423
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
1431 -- behaviour.
1432
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 }
1437 else
1438 new_summary
1439
1440 | otherwise
1441 = new_summary
1442 where
1443 new_summary = do
1444 let dflags = hsc_dflags hsc_env
1445
1446 (dflags', hspp_fn, buf)
1447 <- preprocessFile dflags file mb_phase maybe_buf
1448
1449 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
1450
1451 -- Make a ModLocation for this file
1452 location <- mkHomeModLocation dflags mod_name file
1453
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
1457
1458 src_timestamp <- case maybe_buf of
1459 Just (_,t) -> return t
1460 Nothing -> getModificationTime file
1461 -- getMofificationTime may fail
1462
1463 obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1464
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 })
1473
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
1478 [] -> Nothing
1479 (x:xs) -> Just x
1480
1481 -- Summarise a module, and pick up source and timestamp.
1482 summariseModule
1483 :: HscEnv
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
1490
1491 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
1492 | wanted_mod `elem` excl_mods
1493 = return Nothing
1494
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)
1500
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.
1504 case maybe_buf of
1505 Just (_,t) -> check_timestamp old_summary location src_fn t
1506 Nothing -> do
1507 m <- System.IO.Error.try (getModificationTime src_fn)
1508 case m of
1509 Right t -> check_timestamp old_summary location src_fn t
1510 Left e | isDoesNotExistError e -> find_it
1511 | otherwise -> ioError e
1512
1513 | otherwise = find_it
1514 where
1515 dflags = hsc_dflags hsc_env
1516
1517 hsc_src = if is_boot then HsBootFile else HsSrcFile
1518
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 })
1524 | otherwise =
1525 -- source changed: re-summarise.
1526 new_summary location (ms_mod old_summary) src_fn src_timestamp
1527
1528 find_it = do
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
1535 case found of
1536 Found location mod
1537 | isJust (ml_hs_file location) ->
1538 -- Home package
1539 just_found location mod
1540 | otherwise ->
1541 -- Drop external-pkg
1542 ASSERT(modulePackageId mod /= thisPackage dflags)
1543 return Nothing
1544 where
1545
1546 err -> noModError dflags loc wanted_mod err
1547 -- Not found
1548
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')
1555
1556 -- Check that it exists
1557 -- It might have been deleted since the Finder last found it
1558 maybe_t <- modificationTimeIfExists src_fn
1559 case maybe_t of
1560 Nothing -> noHsFileErr loc src_fn
1561 Just t -> new_summary location' mod src_fn t
1562
1563
1564 new_summary location mod src_fn src_timestamp
1565 = do
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
1570
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)
1575
1576 -- Find the object timestamp, and return the summary
1577 obj_timestamp <- getObjTimestamp location is_boot
1578
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,
1586 ms_imps = the_imps,
1587 ms_hs_date = src_timestamp,
1588 ms_obj_date = obj_timestamp }))
1589
1590
1591 getObjTimestamp location is_boot
1592 = if is_boot then return Nothing
1593 else modificationTimeIfExists (ml_obj_file location)
1594
1595
1596 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1597 -> IO (DynFlags, FilePath, StringBuffer)
1598 preprocessFile dflags src_fn mb_phase Nothing
1599 = do
1600 (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1601 buf <- hGetStringBuffer hspp_fn
1602 return (dflags', hspp_fn, buf)
1603
1604 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1605 = do
1606 -- case we bypass the preprocessing stage?
1607 let
1608 local_opts = getOptions buf src_fn
1609 --
1610 (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
1611
1612 let
1613 needs_preprocessing
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
1619 | otherwise = False
1620
1621 when needs_preprocessing $
1622 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1623
1624 return (dflags', src_fn, buf)
1625
1626
1627 -----------------------------------------------------------------------------
1628 -- Error messages
1629 -----------------------------------------------------------------------------
1630
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 $ cantFindError dflags wanted_mod err
1635
1636 noHsFileErr loc path
1637 = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1638
1639 packageModErr mod
1640 = throwDyn $ mkPlainErrMsg noSrcSpan $
1641 text "module" <+> quotes (ppr mod) <+> text "is a package module"
1642
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)
1649 where
1650 mod = ms_mod summ1
1651 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1652
1653 cyclicModuleErr :: [ModSummary] -> SDoc
1654 cyclicModuleErr ms
1655 = hang (ptext SLIT("Module imports form a cycle for modules:"))
1656 2 (vcat (map show_one ms))
1657 where
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)
1664
1665
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
1672
1673 -- -----------------------------------------------------------------------------
1674 -- inspecting the session
1675
1676 -- | Get the module dependency graph.
1677 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1678 getModuleGraph s = withSession s (return . hsc_mod_graph)
1679
1680 isLoaded :: Session -> ModuleName -> IO Bool
1681 isLoaded s m = withSession s $ \hsc_env ->
1682 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1683
1684 getBindings :: Session -> IO [TyThing]
1685 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1686
1687 getPrintUnqual :: Session -> IO PrintUnqualified
1688 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1689
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
1697 }
1698 -- We don't want HomeModInfo here, because a ModuleInfo applies
1699 -- to package modules too.
1700
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)
1707 else do
1708 {- if isHomeModule (hsc_dflags hsc_env) mdl
1709 then return Nothing
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)
1715
1716 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1717 getPackageModuleInfo hsc_env mdl = do
1718 #ifdef GHCI
1719 (_msgs, mb_names) <- getModuleExports hsc_env mdl
1720 case mb_names of
1721 Nothing -> return Nothing
1722 Just names -> do
1723 eps <- readIORef (hsc_EPS hsc_env)
1724 let
1725 pte = eps_PTE eps
1726 n_list = nameSetToList names
1727 tys = [ ty | name <- n_list,
1728 Just ty <- [lookupTypeEnv pte name] ]
1729 --
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"
1735 }))
1736 #else
1737 -- bogusly different for non-GHCI (ToDo)
1738 return Nothing
1739 #endif
1740
1741 getHomeModuleInfo hsc_env mdl =
1742 case lookupUFM (hsc_HPT hsc_env) mdl of
1743 Nothing -> return Nothing
1744 Just hmi -> do
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
1751 }))
1752
1753 -- | The list of top-level entities defined in a module
1754 modInfoTyThings :: ModuleInfo -> [TyThing]
1755 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1756
1757 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1758 modInfoTopLevelScope minf
1759 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1760
1761 modInfoExports :: ModuleInfo -> [Name]
1762 modInfoExports minf = nameSetToList $! minf_exports minf
1763
1764 -- | Returns the instances defined by the specified module.
1765 -- Warning: currently unimplemented for package modules.
1766 modInfoInstances :: ModuleInfo -> [Instance]
1767 modInfoInstances = minf_instances
1768
1769 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1770 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1771
1772 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1773 modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
1774
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)
1779 Nothing -> do
1780 eps <- readIORef (hsc_EPS hsc_env)
1781 return $! lookupType (hsc_dflags hsc_env)
1782 (hsc_HPT hsc_env) (eps_PTE eps) name
1783
1784 isDictonaryId :: Id -> Bool
1785 isDictonaryId id
1786 = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1787
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
1791 -- 'setContext'.
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
1797
1798 -- -----------------------------------------------------------------------------
1799 -- Misc exported utils
1800
1801 dataConType :: DataCon -> Type
1802 dataConType dc = idType (dataConWrapId dc)
1803
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))
1807
1808 -- ----------------------------------------------------------------------------
1809
1810 #if 0
1811
1812 -- ToDo:
1813 -- - Data and Typeable instances for HsSyn.
1814
1815 -- ToDo: check for small transformations that happen to the syntax in
1816 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1817
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).
1820
1821 -- :browse will use either lm_toplev or inspect lm_interface, depending
1822 -- on whether the module is interpreted or not.
1823
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]
1828 #endif
1829
1830 -- -----------------------------------------------------------------------------
1831 -- Interactive evaluation
1832
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
1839
1840 findModule' hsc_env mod_name maybe_pkg =
1841 let
1842 dflags = hsc_dflags hsc_env
1843 hpt = hsc_HPT hsc_env
1844 this_pkg = thisPackage dflags
1845 in
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
1850 case res of
1851 Found _ m | modulePackageId m /= this_pkg -> return m
1852 -- not allowed to be a home module
1853 err -> let msg = cantFindError dflags mod_name err in
1854 throwDyn (CmdLineError (showSDoc msg))
1855
1856 #ifdef GHCI
1857
1858 -- | Set the interactive evaluation context.
1859 --
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
1866 -> IO ()
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
1871 --
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 }}
1878
1879
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
1884 let
1885 (_msgs, mb_name_sets) = unzip stuff
1886 gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod)
1887 | (Just name_set, mod) <- zip mb_name_sets mods ]
1888 --
1889 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1890
1891 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
1892 nameSetToGlobalRdrEnv names mod =
1893 mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1894 | name <- nameSetToList names ]
1895
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}]
1900 where
1901 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1902 is_qual = False,
1903 is_dloc = srcLocSpan interactiveSrcLoc }
1904
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)))
1910 Just details ->
1911 case mi_globals (hm_iface details) of
1912 Nothing ->
1913 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1914 ++ showSDoc (ppr modl)))
1915 Just env -> return env
1916
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))
1923
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)
1929 then return False
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
1933
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
1937
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))))
1942
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)))
1947
1948 -- ToDo: move to RdrName
1949 greToRdrNames :: GlobalRdrElt -> [RdrName]
1950 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
1951 = case prov of
1952 LocalDef -> [unqual]
1953 Imported specs -> concat (map do_spec (map is_decl specs))
1954 where
1955 occ = nameOccName name
1956 unqual = Unqual occ
1957 do_spec decl_spec
1958 | is_qual decl_spec = [qual]
1959 | otherwise = [unqual,qual]
1960 where qual = Qual (is_as decl_spec) occ
1961
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
1971 case mb_names of
1972 Nothing -> return []
1973 Just ns -> return ns
1974 -- ToDo: should return error messages
1975
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
1980
1981 -- -----------------------------------------------------------------------------
1982 -- Getting the type of an expression
1983
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
1988 case maybe_stuff of
1989 Nothing -> return Nothing
1990 Just ty -> return (Just tidy_ty)
1991 where
1992 tidy_ty = tidyType emptyTidyEnv ty
1993
1994 -- -----------------------------------------------------------------------------
1995 -- Getting the kind of a type
1996
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
2001 case maybe_stuff of
2002 Nothing -> return Nothing
2003 Just kind -> return (Just kind)
2004
2005 -----------------------------------------------------------------------------
2006 -- cmCompileExpr: compile an expression and deliver an HValue
2007
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)
2011 case maybe_stuff of
2012 Nothing -> return Nothing
2013 Just (new_ic, names, hval) -> do
2014 -- Run it!
2015 hvals <- (unsafeCoerce# hval) :: IO [HValue]
2016
2017 case (names,hvals) of
2018 ([n],[hv]) -> return (Just hv)
2019 _ -> panic "compileExpr"
2020
2021 -- -----------------------------------------------------------------------------
2022 -- running a statement interactively
2023
2024 data RunResult
2025 = RunOk [Name] -- ^ names bound by this evaluation
2026 | RunFailed -- ^ statement failed compilation
2027 | RunException Exception -- ^ statement raised an exception
2028
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
2033 = do
2034 hsc_env <- readIORef ref
2035
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' }
2040
2041 maybe_stuff <- hscStmt hsc_env' expr
2042
2043 case maybe_stuff of
2044 Nothing -> return RunFailed
2045 Just (new_hsc_env, names, hval) -> do
2046
2047 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
2048 either_hvals <- sandboxIO thing_to_run
2049
2050 case either_hvals of
2051 Left e -> do
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)
2056
2057 Right hvals -> do
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)
2062
2063 writeIORef ref new_hsc_env
2064 return (RunOk names)
2065
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
2072 m <- newEmptyMVar
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)
2077
2078 {-
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.
2083
2084 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
2085
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
2092 if stat == 1
2093 then do st_result <- peek p_st_result
2094 result <- deRefStablePtr st_result
2095 freeStablePtr st_result
2096 return (Right result)
2097 else do
2098 return (Left (fromIntegral stat))
2099
2100 foreign import "rts_evalStableIO" {- safe -}
2101 rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
2102 -- more informative than the C type!
2103 -}
2104
2105 -----------------------------------------------------------------------------
2106 -- show a module and it's source/object filenames
2107
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)
2113 where
2114 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
2115
2116 #endif /* GHCI */