Remove GHC.extendGlobalRdrScope, GHC.extendGlobalTypeScope
[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 defaultErrorHandler,
12 defaultCleanupHandler,
13
14 -- * GHC Monad
15 Ghc, GhcT, GhcMonad(..),
16 runGhc, runGhcT, initGhcMonad,
17 gcatch, gbracket, gfinally,
18 clearWarnings, getWarnings, hasWarnings,
19 printExceptionAndWarnings, printWarnings,
20 handleSourceError, defaultCallbacks, GhcApiCallbacks(..),
21 needsTemplateHaskell,
22
23 -- * Flags and settings
24 DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
25 GhcMode(..), GhcLink(..), defaultObjectTarget,
26 parseDynamicFlags,
27 getSessionDynFlags,
28 setSessionDynFlags,
29 parseStaticFlags,
30
31 -- * Targets
32 Target(..), TargetId(..), Phase,
33 setTargets,
34 getTargets,
35 addTarget,
36 removeTarget,
37 guessTarget,
38
39 -- * Loading\/compiling the program
40 depanal,
41 load, loadWithLogger, LoadHowMuch(..),
42 SuccessFlag(..), succeeded, failed,
43 defaultWarnErrLogger, WarnErrLogger,
44 workingDirectoryChanged,
45 parseModule, typecheckModule, desugarModule, loadModule,
46 ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
47 TypecheckedSource, ParsedSource, RenamedSource, -- ditto
48 TypecheckedMod, ParsedMod,
49 moduleInfo, renamedSource, typecheckedSource,
50 parsedSource, coreModule,
51 compileToCoreModule, compileToCoreSimplified,
52 compileCoreToObj,
53 getModSummary,
54
55 -- * Inspecting the module structure of the program
56 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
57 getModuleGraph,
58 isLoaded,
59 topSortModuleGraph,
60
61 -- * Inspecting modules
62 ModuleInfo,
63 getModuleInfo,
64 modInfoTyThings,
65 modInfoTopLevelScope,
66 modInfoExports,
67 modInfoInstances,
68 modInfoIsExportedName,
69 modInfoLookupName,
70 lookupGlobalName,
71 findGlobalAnns,
72 mkPrintUnqualifiedForModule,
73
74 -- * Querying the environment
75 packageDbModules,
76
77 -- * Printing
78 PrintUnqualified, alwaysQualify,
79
80 -- * Interactive evaluation
81 getBindings, getPrintUnqual,
82 findModule,
83 lookupModule,
84 #ifdef GHCI
85 setContext, getContext,
86 getNamesInScope,
87 getRdrNamesInScope,
88 getGRE,
89 moduleIsInterpreted,
90 getInfo,
91 exprType,
92 typeKind,
93 parseName,
94 RunResult(..),
95 runStmt, parseImportDecl, SingleStep(..),
96 resume,
97 Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
98 resumeHistory, resumeHistoryIx),
99 History(historyBreakInfo, historyEnclosingDecl),
100 GHC.getHistorySpan, getHistoryModule,
101 getResumeContext,
102 abandon, abandonAll,
103 InteractiveEval.back,
104 InteractiveEval.forward,
105 showModule,
106 isModuleInterpreted,
107 InteractiveEval.compileExpr, HValue, dynCompileExpr,
108 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
109 modInfoModBreaks,
110 ModBreaks(..), BreakIndex,
111 BreakInfo(breakInfo_number, breakInfo_module),
112 BreakArray, setBreakOn, setBreakOff, getBreak,
113 #endif
114 lookupName,
115
116 -- * Abstract syntax elements
117
118 -- ** Packages
119 PackageId,
120
121 -- ** Modules
122 Module, mkModule, pprModule, moduleName, modulePackageId,
123 ModuleName, mkModuleName, moduleNameString,
124
125 -- ** Names
126 Name,
127 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
128 NamedThing(..),
129 RdrName(Qual,Unqual),
130
131 -- ** Identifiers
132 Id, idType,
133 isImplicitId, isDeadBinder,
134 isExportedId, isLocalId, isGlobalId,
135 isRecordSelector,
136 isPrimOpId, isFCallId, isClassOpId_maybe,
137 isDataConWorkId, idDataCon,
138 isBottomingId, isDictonaryId,
139 recordSelectorFieldLabel,
140
141 -- ** Type constructors
142 TyCon,
143 tyConTyVars, tyConDataCons, tyConArity,
144 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
145 isFamilyTyCon,
146 synTyConDefn, synTyConType, synTyConResKind,
147
148 -- ** Type variables
149 TyVar,
150 alphaTyVars,
151
152 -- ** Data constructors
153 DataCon,
154 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
155 dataConIsInfix, isVanillaDataCon, dataConUserType,
156 dataConStrictMarks,
157 StrictnessMark(..), isMarkedStrict,
158
159 -- ** Classes
160 Class,
161 classMethods, classSCTheta, classTvsFds,
162 pprFundeps,
163
164 -- ** Instances
165 Instance,
166 instanceDFunId, pprInstance, pprInstanceHdr,
167
168 -- ** Types and Kinds
169 Type, splitForAllTys, funResultTy,
170 pprParendType, pprTypeApp,
171 Kind,
172 PredType,
173 ThetaType, pprForAll, pprThetaArrow,
174
175 -- ** Entities
176 TyThing(..),
177
178 -- ** Syntax
179 module HsSyn, -- ToDo: remove extraneous bits
180
181 -- ** Fixities
182 FixityDirection(..),
183 defaultFixity, maxPrecedence,
184 negateFixity,
185 compareFixity,
186
187 -- ** Source locations
188 SrcLoc, pprDefnLoc,
189 mkSrcLoc, isGoodSrcLoc, noSrcLoc,
190 srcLocFile, srcLocLine, srcLocCol,
191 SrcSpan,
192 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
193 srcSpanStart, srcSpanEnd,
194 srcSpanFile,
195 srcSpanStartLine, srcSpanEndLine,
196 srcSpanStartCol, srcSpanEndCol,
197
198 -- ** Located
199 Located(..),
200
201 -- *** Constructing Located
202 noLoc, mkGeneralLocated,
203
204 -- *** Deconstructing Located
205 getLoc, unLoc,
206
207 -- *** Combining and comparing Located values
208 eqLocated, cmpLocated, combineLocs, addCLoc,
209 leftmost_smallest, leftmost_largest, rightmost,
210 spans, isSubspanOf,
211
212 -- * Exceptions
213 GhcException(..), showGhcException,
214
215 -- * Token stream manipulations
216 Token,
217 getTokenStream, getRichTokenStream,
218 showRichTokenStream, addSourceToTokens,
219
220 -- * Miscellaneous
221 --sessionHscEnv,
222 cyclicModuleErr,
223 ) where
224
225 {-
226 ToDo:
227
228 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
229 * what StaticFlags should we expose, if any?
230 -}
231
232 #include "HsVersions.h"
233
234 #ifdef GHCI
235 import qualified Linker
236 import Linker ( HValue )
237 import ByteCodeInstr
238 import BreakArray
239 import InteractiveEval
240 #endif
241
242 import TcRnDriver
243 import TcIface
244 import TcRnTypes
245 import TcRnMonad ( initIfaceCheck )
246 import Packages
247 import NameSet
248 import RdrName
249 import qualified HsSyn -- hack as we want to reexport the whole module
250 import HsSyn hiding ((<.>))
251 import Type
252 import Coercion ( synTyConResKind )
253 import TcType hiding( typeKind )
254 import Id
255 import Var
256 import TysPrim ( alphaTyVars )
257 import TyCon
258 import Class
259 -- import FunDeps
260 import DataCon
261 import Name hiding ( varName )
262 -- import OccName ( parenSymOcc )
263 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
264 emptyInstEnv )
265 import FamInstEnv ( emptyFamInstEnv )
266 import SrcLoc
267 --import CoreSyn
268 import TidyPgm
269 import DriverPipeline
270 import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
271 import HeaderInfo
272 import Finder
273 import HscMain
274 import HscTypes
275 import DynFlags
276 import StaticFlagParser
277 import qualified StaticFlags
278 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
279 cleanTempDirs )
280 import Annotations
281 import Module
282 import UniqFM
283 import Panic
284 import Digraph
285 import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
286 import ErrUtils
287 import MonadUtils
288 import Util
289 import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
290 import Outputable
291 import BasicTypes
292 import Maybes ( expectJust, mapCatMaybes )
293 import FastString
294 import Lexer
295
296 import System.Directory ( getModificationTime, doesFileExist,
297 getCurrentDirectory )
298 import Data.Maybe
299 import Data.Map (Map)
300 import qualified Data.Map as Map
301 import qualified FiniteMap as Map
302 import Data.List
303 import qualified Data.List as List
304 import Data.Typeable ( Typeable )
305 import Data.Word ( Word8 )
306 import Control.Monad
307 import System.Exit ( exitWith, ExitCode(..) )
308 import System.Time ( ClockTime, getClockTime )
309 import Exception
310 import Data.IORef
311 import System.FilePath
312 import System.IO
313 import System.IO.Error ( try, isDoesNotExistError )
314 import Prelude hiding (init)
315
316
317 -- -----------------------------------------------------------------------------
318 -- Exception handlers
319
320 -- | Install some default exception handlers and run the inner computation.
321 -- Unless you want to handle exceptions yourself, you should wrap this around
322 -- the top level of your program. The default handlers output the error
323 -- message(s) to stderr and exit cleanly.
324 defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
325 defaultErrorHandler dflags inner =
326 -- top-level exception handler: any unrecognised exception is a compiler bug.
327 ghandle (\exception -> liftIO $ do
328 hFlush stdout
329 case fromException exception of
330 -- an IO exception probably isn't our fault, so don't panic
331 Just (ioe :: IOException) ->
332 fatalErrorMsg dflags (text (show ioe))
333 _ -> case fromException exception of
334 Just UserInterrupt -> exitWith (ExitFailure 1)
335 Just StackOverflow ->
336 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
337 _ -> case fromException exception of
338 Just (ex :: ExitCode) -> throw ex
339 _ ->
340 fatalErrorMsg dflags
341 (text (show (Panic (show exception))))
342 exitWith (ExitFailure 1)
343 ) $
344
345 -- error messages propagated as exceptions
346 handleGhcException
347 (\ge -> liftIO $ do
348 hFlush stdout
349 case ge of
350 PhaseFailed _ code -> exitWith code
351 Signal _ -> exitWith (ExitFailure 1)
352 _ -> do fatalErrorMsg dflags (text (show ge))
353 exitWith (ExitFailure 1)
354 ) $
355 inner
356
357 -- | Install a default cleanup handler to remove temporary files deposited by
358 -- a GHC run. This is seperate from 'defaultErrorHandler', because you might
359 -- want to override the error handling, but still get the ordinary cleanup
360 -- behaviour.
361 defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
362 DynFlags -> m a -> m a
363 defaultCleanupHandler dflags inner =
364 -- make sure we clean up after ourselves
365 inner `gfinally`
366 (liftIO $ do
367 cleanTempFiles dflags
368 cleanTempDirs dflags
369 )
370 -- exceptions will be blocked while we clean the temporary files,
371 -- so there shouldn't be any difficulty if we receive further
372 -- signals.
373
374 -- | Print the error message and all warnings. Useful inside exception
375 -- handlers. Clears warnings after printing.
376 printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
377 printExceptionAndWarnings err = do
378 let errs = srcErrorMessages err
379 warns <- getWarnings
380 dflags <- getSessionDynFlags
381 if isEmptyBag errs
382 -- Empty errors means we failed due to -Werror. (Since this function
383 -- takes a source error as argument, we know for sure _some_ error
384 -- did indeed happen.)
385 then liftIO $ do
386 printBagOfWarnings dflags warns
387 printBagOfErrors dflags (unitBag warnIsErrorMsg)
388 else liftIO $ printBagOfErrors dflags errs
389 clearWarnings
390
391 -- | Print all accumulated warnings using 'log_action'.
392 printWarnings :: GhcMonad m => m ()
393 printWarnings = do
394 dflags <- getSessionDynFlags
395 warns <- getWarnings
396 liftIO $ printBagOfWarnings dflags warns
397 clearWarnings
398
399 -- | Run function for the 'Ghc' monad.
400 --
401 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
402 -- to this function will create a new session which should not be shared among
403 -- several threads.
404 --
405 -- Any errors not handled inside the 'Ghc' action are propagated as IO
406 -- exceptions.
407
408 runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
409 -> Ghc a -- ^ The action to perform.
410 -> IO a
411 runGhc mb_top_dir ghc = do
412 wref <- newIORef emptyBag
413 ref <- newIORef undefined
414 let session = Session ref wref
415 flip unGhc session $ do
416 initGhcMonad mb_top_dir
417 ghc
418 -- XXX: unregister interrupt handlers here?
419
420 -- | Run function for 'GhcT' monad transformer.
421 --
422 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
423 -- to this function will create a new session which should not be shared among
424 -- several threads.
425
426 runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
427 Maybe FilePath -- ^ See argument to 'initGhcMonad'.
428 -> GhcT m a -- ^ The action to perform.
429 -> m a
430 runGhcT mb_top_dir ghct = do
431 wref <- liftIO $ newIORef emptyBag
432 ref <- liftIO $ newIORef undefined
433 let session = Session ref wref
434 flip unGhcT session $ do
435 initGhcMonad mb_top_dir
436 ghct
437
438 -- | Initialise a GHC session.
439 --
440 -- If you implement a custom 'GhcMonad' you must call this function in the
441 -- monad run function. It will initialise the session variable and clear all
442 -- warnings.
443 --
444 -- The first argument should point to the directory where GHC's library files
445 -- reside. More precisely, this should be the output of @ghc --print-libdir@
446 -- of the version of GHC the module using this API is compiled with. For
447 -- portability, you should use the @ghc-paths@ package, available at
448 -- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
449
450 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
451 initGhcMonad mb_top_dir = do
452 -- catch ^C
453 liftIO $ installSignalHandlers
454
455 liftIO $ StaticFlags.initStaticOpts
456
457 dflags0 <- liftIO $ initDynFlags defaultDynFlags
458 dflags <- liftIO $ initSysTools mb_top_dir dflags0
459 env <- liftIO $ newHscEnv defaultCallbacks dflags
460 setSession env
461 clearWarnings
462
463 defaultCallbacks :: GhcApiCallbacks
464 defaultCallbacks =
465 GhcApiCallbacks {
466 reportModuleCompilationResult =
467 \_ mb_err -> defaultWarnErrLogger mb_err
468 }
469
470 -- -----------------------------------------------------------------------------
471 -- Flags & settings
472
473 -- | Grabs the DynFlags from the Session
474 getSessionDynFlags :: GhcMonad m => m DynFlags
475 getSessionDynFlags = withSession (return . hsc_dflags)
476
477 -- | Updates the DynFlags in a Session. This also reads
478 -- the package database (unless it has already been read),
479 -- and prepares the compilers knowledge about packages. It
480 -- can be called again to load new packages: just add new
481 -- package flags to (packageFlags dflags).
482 --
483 -- Returns a list of new packages that may need to be linked in using
484 -- the dynamic linker (see 'linkPackages') as a result of new package
485 -- flags. If you are not doing linking or doing static linking, you
486 -- can ignore the list of packages returned.
487 --
488 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
489 setSessionDynFlags dflags = do
490 (dflags', preload) <- liftIO $ initPackages dflags
491 modifySession (\h -> h{ hsc_dflags = dflags' })
492 return preload
493
494 -- | If there is no -o option, guess the name of target executable
495 -- by using top-level source file name as a base.
496 guessOutputFile :: GhcMonad m => m ()
497 guessOutputFile = modifySession $ \env ->
498 let dflags = hsc_dflags env
499 mod_graph = hsc_mod_graph env
500 mainModuleSrcPath :: Maybe String
501 mainModuleSrcPath = do
502 let isMain = (== mainModIs dflags) . ms_mod
503 [ms] <- return (filter isMain mod_graph)
504 ml_hs_file (ms_location ms)
505 name = fmap dropExtension mainModuleSrcPath
506
507 #if defined(mingw32_HOST_OS)
508 -- we must add the .exe extention unconditionally here, otherwise
509 -- when name has an extension of its own, the .exe extension will
510 -- not be added by DriverPipeline.exeFileName. See #2248
511 name_exe = fmap (<.> "exe") name
512 #else
513 name_exe = name
514 #endif
515 in
516 case outputFile dflags of
517 Just _ -> env
518 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
519
520 -- -----------------------------------------------------------------------------
521 -- Targets
522
523 -- ToDo: think about relative vs. absolute file paths. And what
524 -- happens when the current directory changes.
525
526 -- | Sets the targets for this session. Each target may be a module name
527 -- or a filename. The targets correspond to the set of root modules for
528 -- the program\/library. Unloading the current program is achieved by
529 -- setting the current set of targets to be empty, followed by 'load'.
530 setTargets :: GhcMonad m => [Target] -> m ()
531 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
532
533 -- | Returns the current set of targets
534 getTargets :: GhcMonad m => m [Target]
535 getTargets = withSession (return . hsc_targets)
536
537 -- | Add another target.
538 addTarget :: GhcMonad m => Target -> m ()
539 addTarget target
540 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
541
542 -- | Remove a target
543 removeTarget :: GhcMonad m => TargetId -> m ()
544 removeTarget target_id
545 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
546 where
547 filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
548
549 -- | Attempts to guess what Target a string refers to. This function
550 -- implements the @--make@/GHCi command-line syntax for filenames:
551 --
552 -- - if the string looks like a Haskell source filename, then interpret it
553 -- as such
554 --
555 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
556 -- then use that
557 --
558 -- - otherwise interpret the string as a module name
559 --
560 guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
561 guessTarget str (Just phase)
562 = return (Target (TargetFile str (Just phase)) True Nothing)
563 guessTarget str Nothing
564 | isHaskellSrcFilename file
565 = return (target (TargetFile file Nothing))
566 | otherwise
567 = do exists <- liftIO $ doesFileExist hs_file
568 if exists
569 then return (target (TargetFile hs_file Nothing))
570 else do
571 exists <- liftIO $ doesFileExist lhs_file
572 if exists
573 then return (target (TargetFile lhs_file Nothing))
574 else do
575 if looksLikeModuleName file
576 then return (target (TargetModule (mkModuleName file)))
577 else do
578 throwGhcException
579 (ProgramError (showSDoc $
580 text "target" <+> quotes (text file) <+>
581 text "is not a module name or a source file"))
582 where
583 (file,obj_allowed)
584 | '*':rest <- str = (rest, False)
585 | otherwise = (str, True)
586
587 hs_file = file <.> "hs"
588 lhs_file = file <.> "lhs"
589
590 target tid = Target tid obj_allowed Nothing
591
592 -- -----------------------------------------------------------------------------
593 -- Loading the program
594
595 -- | Perform a dependency analysis starting from the current targets
596 -- and update the session with the new module graph.
597 --
598 -- Dependency analysis entails parsing the @import@ directives and may
599 -- therefore require running certain preprocessors.
600 --
601 -- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
602 -- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
603 -- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to
604 -- changes to the 'DynFlags' to take effect you need to call this function
605 -- again.
606 --
607 depanal :: GhcMonad m =>
608 [ModuleName] -- ^ excluded modules
609 -> Bool -- ^ allow duplicate roots
610 -> m ModuleGraph
611 depanal excluded_mods allow_dup_roots = do
612 hsc_env <- getSession
613 let
614 dflags = hsc_dflags hsc_env
615 targets = hsc_targets hsc_env
616 old_graph = hsc_mod_graph hsc_env
617
618 liftIO $ showPass dflags "Chasing dependencies"
619 liftIO $ debugTraceMsg dflags 2 (hcat [
620 text "Chasing modules from: ",
621 hcat (punctuate comma (map pprTarget targets))])
622
623 mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
624 modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
625 return mod_graph
626
627 -- | Describes which modules of the module graph need to be loaded.
628 data LoadHowMuch
629 = LoadAllTargets
630 -- ^ Load all targets and its dependencies.
631 | LoadUpTo ModuleName
632 -- ^ Load only the given module and its dependencies.
633 | LoadDependenciesOf ModuleName
634 -- ^ Load only the dependencies of the given module, but not the module
635 -- itself.
636
637 -- | Try to load the program. See 'LoadHowMuch' for the different modes.
638 --
639 -- This function implements the core of GHC's @--make@ mode. It preprocesses,
640 -- compiles and loads the specified modules, avoiding re-compilation wherever
641 -- possible. Depending on the target (see 'DynFlags.hscTarget') compilating
642 -- and loading may result in files being created on disk.
643 --
644 -- Calls the 'reportModuleCompilationResult' callback after each compiling
645 -- each module, whether successful or not.
646 --
647 -- Throw a 'SourceError' if errors are encountered before the actual
648 -- compilation starts (e.g., during dependency analysis). All other errors
649 -- are reported using the callback.
650 --
651 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
652 load how_much = do
653 mod_graph <- depanal [] False
654 load2 how_much mod_graph
655
656 -- | A function called to log warnings and errors.
657 type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
658
659 defaultWarnErrLogger :: WarnErrLogger
660 defaultWarnErrLogger Nothing = printWarnings
661 defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
662
663 -- | Try to load the program. If a Module is supplied, then just
664 -- attempt to load up to this target. If no Module is supplied,
665 -- then try to load all targets.
666 --
667 -- The first argument is a function that is called after compiling each
668 -- module to print wanrings and errors.
669 --
670 -- While compiling a module, all 'SourceError's are caught and passed to the
671 -- logger, however, this function may still throw a 'SourceError' if
672 -- dependency analysis failed (e.g., due to a parse error).
673 --
674 loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
675 loadWithLogger logger how_much = do
676 -- Dependency analysis first. Note that this fixes the module graph:
677 -- even if we don't get a fully successful upsweep, the full module
678 -- graph is still retained in the Session. We can tell which modules
679 -- were successfully loaded by inspecting the Session's HPT.
680 withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult =
681 \_ -> logger }) $
682 load how_much
683
684 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
685 -> m SuccessFlag
686 load2 how_much mod_graph = do
687 guessOutputFile
688 hsc_env <- getSession
689
690 let hpt1 = hsc_HPT hsc_env
691 let dflags = hsc_dflags hsc_env
692
693 -- The "bad" boot modules are the ones for which we have
694 -- B.hs-boot in the module graph, but no B.hs
695 -- The downsweep should have ensured this does not happen
696 -- (see msDeps)
697 let all_home_mods = [ms_mod_name s
698 | s <- mod_graph, not (isBootSummary s)]
699 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
700 not (ms_mod_name s `elem` all_home_mods)]
701 ASSERT( null bad_boot_mods ) return ()
702
703 -- check that the module given in HowMuch actually exists, otherwise
704 -- topSortModuleGraph will bomb later.
705 let checkHowMuch (LoadUpTo m) = checkMod m
706 checkHowMuch (LoadDependenciesOf m) = checkMod m
707 checkHowMuch _ = id
708
709 checkMod m and_then
710 | m `elem` all_home_mods = and_then
711 | otherwise = do
712 liftIO $ errorMsg dflags (text "no such module:" <+>
713 quotes (ppr m))
714 return Failed
715
716 checkHowMuch how_much $ do
717
718 -- mg2_with_srcimps drops the hi-boot nodes, returning a
719 -- graph with cycles. Among other things, it is used for
720 -- backing out partially complete cycles following a failed
721 -- upsweep, and for removing from hpt all the modules
722 -- not in strict downwards closure, during calls to compile.
723 let mg2_with_srcimps :: [SCC ModSummary]
724 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
725
726 -- If we can determine that any of the {-# SOURCE #-} imports
727 -- are definitely unnecessary, then emit a warning.
728 warnUnnecessarySourceImports mg2_with_srcimps
729
730 let
731 -- check the stability property for each module.
732 stable_mods@(stable_obj,stable_bco)
733 = checkStability hpt1 mg2_with_srcimps all_home_mods
734
735 -- prune bits of the HPT which are definitely redundant now,
736 -- to save space.
737 pruned_hpt = pruneHomePackageTable hpt1
738 (flattenSCCs mg2_with_srcimps)
739 stable_mods
740
741 _ <- liftIO $ evaluate pruned_hpt
742
743 -- before we unload anything, make sure we don't leave an old
744 -- interactive context around pointing to dead bindings. Also,
745 -- write the pruned HPT to allow the old HPT to be GC'd.
746 modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
747 hsc_HPT = pruned_hpt }
748
749 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
750 text "Stable BCO:" <+> ppr stable_bco)
751
752 -- Unload any modules which are going to be re-linked this time around.
753 let stable_linkables = [ linkable
754 | m <- stable_obj++stable_bco,
755 Just hmi <- [lookupUFM pruned_hpt m],
756 Just linkable <- [hm_linkable hmi] ]
757 liftIO $ unload hsc_env stable_linkables
758
759 -- We could at this point detect cycles which aren't broken by
760 -- a source-import, and complain immediately, but it seems better
761 -- to let upsweep_mods do this, so at least some useful work gets
762 -- done before the upsweep is abandoned.
763 --hPutStrLn stderr "after tsort:\n"
764 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
765
766 -- Now do the upsweep, calling compile for each module in
767 -- turn. Final result is version 3 of everything.
768
769 -- Topologically sort the module graph, this time including hi-boot
770 -- nodes, and possibly just including the portion of the graph
771 -- reachable from the module specified in the 2nd argument to load.
772 -- This graph should be cycle-free.
773 -- If we're restricting the upsweep to a portion of the graph, we
774 -- also want to retain everything that is still stable.
775 let full_mg :: [SCC ModSummary]
776 full_mg = topSortModuleGraph False mod_graph Nothing
777
778 maybe_top_mod = case how_much of
779 LoadUpTo m -> Just m
780 LoadDependenciesOf m -> Just m
781 _ -> Nothing
782
783 partial_mg0 :: [SCC ModSummary]
784 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
785
786 -- LoadDependenciesOf m: we want the upsweep to stop just
787 -- short of the specified module (unless the specified module
788 -- is stable).
789 partial_mg
790 | LoadDependenciesOf _mod <- how_much
791 = ASSERT( case last partial_mg0 of
792 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
793 List.init partial_mg0
794 | otherwise
795 = partial_mg0
796
797 stable_mg =
798 [ AcyclicSCC ms
799 | AcyclicSCC ms <- full_mg,
800 ms_mod_name ms `elem` stable_obj++stable_bco,
801 ms_mod_name ms `notElem` [ ms_mod_name ms' |
802 AcyclicSCC ms' <- partial_mg ] ]
803
804 mg = stable_mg ++ partial_mg
805
806 -- clean up between compilations
807 let cleanup = cleanTempFilesExcept dflags
808 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
809
810 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
811 2 (ppr mg))
812 (upsweep_ok, hsc_env1, modsUpswept)
813 <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
814 pruned_hpt stable_mods cleanup mg
815
816 -- Make modsDone be the summaries for each home module now
817 -- available; this should equal the domain of hpt3.
818 -- Get in in a roughly top .. bottom order (hence reverse).
819
820 let modsDone = reverse modsUpswept
821
822 -- Try and do linking in some form, depending on whether the
823 -- upsweep was completely or only partially successful.
824
825 if succeeded upsweep_ok
826
827 then
828 -- Easy; just relink it all.
829 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
830
831 -- Clean up after ourselves
832 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
833
834 -- Issue a warning for the confusing case where the user
835 -- said '-o foo' but we're not going to do any linking.
836 -- We attempt linking if either (a) one of the modules is
837 -- called Main, or (b) the user said -no-hs-main, indicating
838 -- that main() is going to come from somewhere else.
839 --
840 let ofile = outputFile dflags
841 let no_hs_main = dopt Opt_NoHsMain dflags
842 let
843 main_mod = mainModIs dflags
844 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
845 do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
846
847 when (ghcLink dflags == LinkBinary
848 && isJust ofile && not do_linking) $
849 liftIO $ debugTraceMsg dflags 1 $
850 text ("Warning: output was redirected with -o, " ++
851 "but no output will be generated\n" ++
852 "because there is no " ++
853 moduleNameString (moduleName main_mod) ++ " module.")
854
855 -- link everything together
856 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
857
858 loadFinish Succeeded linkresult hsc_env1
859
860 else
861 -- Tricky. We need to back out the effects of compiling any
862 -- half-done cycles, both so as to clean up the top level envs
863 -- and to avoid telling the interactive linker to link them.
864 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
865
866 let modsDone_names
867 = map ms_mod modsDone
868 let mods_to_zap_names
869 = findPartiallyCompletedCycles modsDone_names
870 mg2_with_srcimps
871 let mods_to_keep
872 = filter ((`notElem` mods_to_zap_names).ms_mod)
873 modsDone
874
875 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
876 (hsc_HPT hsc_env1)
877
878 -- Clean up after ourselves
879 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
880
881 -- there should be no Nothings where linkables should be, now
882 ASSERT(all (isJust.hm_linkable)
883 (eltsUFM (hsc_HPT hsc_env))) do
884
885 -- Link everything together
886 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
887
888 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
889 loadFinish Failed linkresult hsc_env4
890
891 -- Finish up after a load.
892
893 -- If the link failed, unload everything and return.
894 loadFinish :: GhcMonad m =>
895 SuccessFlag -> SuccessFlag -> HscEnv
896 -> m SuccessFlag
897 loadFinish _all_ok Failed hsc_env
898 = do liftIO $ unload hsc_env []
899 modifySession $ \_ -> discardProg hsc_env
900 return Failed
901
902 -- Empty the interactive context and set the module context to the topmost
903 -- newly loaded module, or the Prelude if none were loaded.
904 loadFinish all_ok Succeeded hsc_env
905 = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
906 return all_ok
907
908
909 -- Forget the current program, but retain the persistent info in HscEnv
910 discardProg :: HscEnv -> HscEnv
911 discardProg hsc_env
912 = hsc_env { hsc_mod_graph = emptyMG,
913 hsc_IC = emptyInteractiveContext,
914 hsc_HPT = emptyHomePackageTable }
915
916 -- used to fish out the preprocess output files for the purposes of
917 -- cleaning up. The preprocessed file *might* be the same as the
918 -- source file, but that doesn't do any harm.
919 ppFilesFromSummaries :: [ModSummary] -> [FilePath]
920 ppFilesFromSummaries summaries = map ms_hspp_file summaries
921
922 -- -----------------------------------------------------------------------------
923
924 class ParsedMod m where
925 modSummary :: m -> ModSummary
926 parsedSource :: m -> ParsedSource
927
928 class ParsedMod m => TypecheckedMod m where
929 renamedSource :: m -> Maybe RenamedSource
930 typecheckedSource :: m -> TypecheckedSource
931 moduleInfo :: m -> ModuleInfo
932 tm_internals :: m -> (TcGblEnv, ModDetails)
933 -- ToDo: improvements that could be made here:
934 -- if the module succeeded renaming but not typechecking,
935 -- we can still get back the GlobalRdrEnv and exports, so
936 -- perhaps the ModuleInfo should be split up into separate
937 -- fields.
938
939 class TypecheckedMod m => DesugaredMod m where
940 coreModule :: m -> ModGuts
941
942 -- | The result of successful parsing.
943 data ParsedModule =
944 ParsedModule { pm_mod_summary :: ModSummary
945 , pm_parsed_source :: ParsedSource }
946
947 instance ParsedMod ParsedModule where
948 modSummary m = pm_mod_summary m
949 parsedSource m = pm_parsed_source m
950
951 -- | The result of successful typechecking. It also contains the parser
952 -- result.
953 data TypecheckedModule =
954 TypecheckedModule { tm_parsed_module :: ParsedModule
955 , tm_renamed_source :: Maybe RenamedSource
956 , tm_typechecked_source :: TypecheckedSource
957 , tm_checked_module_info :: ModuleInfo
958 , tm_internals_ :: (TcGblEnv, ModDetails)
959 }
960
961 instance ParsedMod TypecheckedModule where
962 modSummary m = modSummary (tm_parsed_module m)
963 parsedSource m = parsedSource (tm_parsed_module m)
964
965 instance TypecheckedMod TypecheckedModule where
966 renamedSource m = tm_renamed_source m
967 typecheckedSource m = tm_typechecked_source m
968 moduleInfo m = tm_checked_module_info m
969 tm_internals m = tm_internals_ m
970
971 -- | The result of successful desugaring (i.e., translation to core). Also
972 -- contains all the information of a typechecked module.
973 data DesugaredModule =
974 DesugaredModule { dm_typechecked_module :: TypecheckedModule
975 , dm_core_module :: ModGuts
976 }
977
978 instance ParsedMod DesugaredModule where
979 modSummary m = modSummary (dm_typechecked_module m)
980 parsedSource m = parsedSource (dm_typechecked_module m)
981
982 instance TypecheckedMod DesugaredModule where
983 renamedSource m = renamedSource (dm_typechecked_module m)
984 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
985 moduleInfo m = moduleInfo (dm_typechecked_module m)
986 tm_internals m = tm_internals_ (dm_typechecked_module m)
987
988 instance DesugaredMod DesugaredModule where
989 coreModule m = dm_core_module m
990
991 type ParsedSource = Located (HsModule RdrName)
992 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
993 Maybe LHsDocString)
994 type TypecheckedSource = LHsBinds Id
995
996 -- NOTE:
997 -- - things that aren't in the output of the typechecker right now:
998 -- - the export list
999 -- - the imports
1000 -- - type signatures
1001 -- - type/data/newtype declarations
1002 -- - class declarations
1003 -- - instances
1004 -- - extra things in the typechecker's output:
1005 -- - default methods are turned into top-level decls.
1006 -- - dictionary bindings
1007
1008 -- | Return the 'ModSummary' of a module with the given name.
1009 --
1010 -- The module must be part of the module graph (see 'hsc_mod_graph' and
1011 -- 'ModuleGraph'). If this is not the case, this function will throw a
1012 -- 'GhcApiError'.
1013 --
1014 -- This function ignores boot modules and requires that there is only one
1015 -- non-boot module with the given name.
1016 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
1017 getModSummary mod = do
1018 mg <- liftM hsc_mod_graph getSession
1019 case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
1020 [] -> throw $ mkApiErr (text "Module not part of module graph")
1021 [ms] -> return ms
1022 multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
1023
1024 -- | Parse a module.
1025 --
1026 -- Throws a 'SourceError' on parse error.
1027 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
1028 parseModule ms = do
1029 rdr_module <- withTempSession
1030 (\e -> e { hsc_dflags = ms_hspp_opts ms }) $
1031 hscParse ms
1032 return (ParsedModule ms rdr_module)
1033
1034 -- | Typecheck and rename a parsed module.
1035 --
1036 -- Throws a 'SourceError' if either fails.
1037 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
1038 typecheckModule pmod = do
1039 let ms = modSummary pmod
1040 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1041 (tc_gbl_env, rn_info)
1042 <- hscTypecheckRename ms (parsedSource pmod)
1043 details <- makeSimpleDetails tc_gbl_env
1044 return $
1045 TypecheckedModule {
1046 tm_internals_ = (tc_gbl_env, details),
1047 tm_parsed_module = pmod,
1048 tm_renamed_source = rn_info,
1049 tm_typechecked_source = tcg_binds tc_gbl_env,
1050 tm_checked_module_info =
1051 ModuleInfo {
1052 minf_type_env = md_types details,
1053 minf_exports = availsToNameSet $ md_exports details,
1054 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
1055 minf_instances = md_insts details
1056 #ifdef GHCI
1057 ,minf_modBreaks = emptyModBreaks
1058 #endif
1059 }}
1060
1061 -- | Desugar a typechecked module.
1062 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
1063 desugarModule tcm = do
1064 let ms = modSummary tcm
1065 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1066 let (tcg, _) = tm_internals tcm
1067 guts <- hscDesugar ms tcg
1068 return $
1069 DesugaredModule {
1070 dm_typechecked_module = tcm,
1071 dm_core_module = guts
1072 }
1073
1074 -- | Load a module. Input doesn't need to be desugared.
1075 --
1076 -- A module must be loaded before dependent modules can be typechecked. This
1077 -- always includes generating a 'ModIface' and, depending on the
1078 -- 'DynFlags.hscTarget', may also include code generation.
1079 --
1080 -- This function will always cause recompilation and will always overwrite
1081 -- previous compilation results (potentially files on disk).
1082 --
1083 loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
1084 loadModule tcm = do
1085 let ms = modSummary tcm
1086 let mod = ms_mod_name ms
1087 let loc = ms_location ms
1088 let (tcg, _details) = tm_internals tcm
1089 hpt_new <-
1090 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1091
1092 let compilerBackend comp env ms' _ _mb_old_iface _ =
1093 withTempSession (\_ -> env) $
1094 hscBackend comp tcg ms' Nothing
1095
1096 hsc_env <- getSession
1097 mod_info <- do
1098 mb_linkable <-
1099 case ms_obj_date ms of
1100 Just t | t > ms_hs_date ms -> do
1101 l <- liftIO $ findObjectLinkable (ms_mod ms)
1102 (ml_obj_file loc) t
1103 return (Just l)
1104 _otherwise -> return Nothing
1105
1106 compile' (compilerBackend hscNothingCompiler
1107 ,compilerBackend hscInteractiveCompiler
1108 ,hscCheckRecompBackend hscBatchCompiler tcg)
1109 hsc_env ms 1 1 Nothing mb_linkable
1110 -- compile' shouldn't change the environment
1111 return $ addToUFM (hsc_HPT hsc_env) mod mod_info
1112 modifySession $ \e -> e{ hsc_HPT = hpt_new }
1113 return tcm
1114
1115
1116 -- | This is the way to get access to the Core bindings corresponding
1117 -- to a module. 'compileToCore' parses, typechecks, and
1118 -- desugars the module, then returns the resulting Core module (consisting of
1119 -- the module name, type declarations, and function declarations) if
1120 -- successful.
1121 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1122 compileToCoreModule = compileCore False
1123
1124 -- | Like compileToCoreModule, but invokes the simplifier, so
1125 -- as to return simplified and tidied Core.
1126 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1127 compileToCoreSimplified = compileCore True
1128 {-
1129 -- | Provided for backwards-compatibility: compileToCore returns just the Core
1130 -- bindings, but for most purposes, you probably want to call
1131 -- compileToCoreModule.
1132 compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
1133 compileToCore fn = do
1134 mod <- compileToCoreModule session fn
1135 return $ cm_binds mod
1136 -}
1137 -- | Takes a CoreModule and compiles the bindings therein
1138 -- to object code. The first argument is a bool flag indicating
1139 -- whether to run the simplifier.
1140 -- The resulting .o, .hi, and executable files, if any, are stored in the
1141 -- current directory, and named according to the module name.
1142 -- This has only so far been tested with a single self-contained module.
1143 compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
1144 compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
1145 dflags <- getSessionDynFlags
1146 currentTime <- liftIO $ getClockTime
1147 cwd <- liftIO $ getCurrentDirectory
1148 modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
1149 ((moduleNameSlashes . moduleName) mName)
1150
1151 let modSummary = ModSummary { ms_mod = mName,
1152 ms_hsc_src = ExtCoreFile,
1153 ms_location = modLocation,
1154 -- By setting the object file timestamp to Nothing,
1155 -- we always force recompilation, which is what we
1156 -- want. (Thus it doesn't matter what the timestamp
1157 -- for the (nonexistent) source file is.)
1158 ms_hs_date = currentTime,
1159 ms_obj_date = Nothing,
1160 -- Only handling the single-module case for now, so no imports.
1161 ms_srcimps = [],
1162 ms_imps = [],
1163 -- No source file
1164 ms_hspp_file = "",
1165 ms_hspp_opts = dflags,
1166 ms_hspp_buf = Nothing
1167 }
1168
1169 let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
1170 | otherwise = return mod_guts
1171 guts <- maybe_simplify (mkModGuts cm)
1172 (iface, changed, _details, cgguts)
1173 <- hscNormalIface guts Nothing
1174 hscWriteIface iface changed modSummary
1175 _ <- hscGenHardCode cgguts modSummary
1176 return ()
1177
1178 -- Makes a "vanilla" ModGuts.
1179 mkModGuts :: CoreModule -> ModGuts
1180 mkModGuts coreModule = ModGuts {
1181 mg_module = cm_module coreModule,
1182 mg_boot = False,
1183 mg_exports = [],
1184 mg_deps = noDependencies,
1185 mg_dir_imps = emptyModuleEnv,
1186 mg_used_names = emptyNameSet,
1187 mg_rdr_env = emptyGlobalRdrEnv,
1188 mg_fix_env = emptyFixityEnv,
1189 mg_types = emptyTypeEnv,
1190 mg_insts = [],
1191 mg_fam_insts = [],
1192 mg_rules = [],
1193 mg_binds = cm_binds coreModule,
1194 mg_foreign = NoStubs,
1195 mg_warns = NoWarnings,
1196 mg_anns = [],
1197 mg_hpc_info = emptyHpcInfo False,
1198 mg_modBreaks = emptyModBreaks,
1199 mg_vect_info = noVectInfo,
1200 mg_inst_env = emptyInstEnv,
1201 mg_fam_inst_env = emptyFamInstEnv
1202 }
1203
1204 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1205 compileCore simplify fn = do
1206 -- First, set the target to the desired filename
1207 target <- guessTarget fn Nothing
1208 addTarget target
1209 _ <- load LoadAllTargets
1210 -- Then find dependencies
1211 modGraph <- depanal [] True
1212 case find ((== fn) . msHsFilePath) modGraph of
1213 Just modSummary -> do
1214 -- Now we have the module name;
1215 -- parse, typecheck and desugar the module
1216 mod_guts <- coreModule `fmap`
1217 -- TODO: space leaky: call hsc* directly?
1218 (desugarModule =<< typecheckModule =<< parseModule modSummary)
1219 liftM gutsToCoreModule $
1220 if simplify
1221 then do
1222 -- If simplify is true: simplify (hscSimplify), then tidy
1223 -- (tidyProgram).
1224 hsc_env <- getSession
1225 simpl_guts <- hscSimplify mod_guts
1226 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1227 return $ Left tidy_guts
1228 else
1229 return $ Right mod_guts
1230
1231 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1232 module dependency graph"
1233 where -- two versions, based on whether we simplify (thus run tidyProgram,
1234 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1235 -- we just have a ModGuts.
1236 gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
1237 gutsToCoreModule (Left (cg, md)) = CoreModule {
1238 cm_module = cg_module cg, cm_types = md_types md,
1239 cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
1240 }
1241 gutsToCoreModule (Right mg) = CoreModule {
1242 cm_module = mg_module mg, cm_types = mg_types mg,
1243 cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
1244 }
1245
1246 -- ---------------------------------------------------------------------------
1247 -- Unloading
1248
1249 unload :: HscEnv -> [Linkable] -> IO ()
1250 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
1251 = case ghcLink (hsc_dflags hsc_env) of
1252 #ifdef GHCI
1253 LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
1254 #else
1255 LinkInMemory -> panic "unload: no interpreter"
1256 -- urgh. avoid warnings:
1257 hsc_env stable_linkables
1258 #endif
1259 _other -> return ()
1260
1261 -- -----------------------------------------------------------------------------
1262
1263 {- |
1264
1265 Stability tells us which modules definitely do not need to be recompiled.
1266 There are two main reasons for having stability:
1267
1268 - avoid doing a complete upsweep of the module graph in GHCi when
1269 modules near the bottom of the tree have not changed.
1270
1271 - to tell GHCi when it can load object code: we can only load object code
1272 for a module when we also load object code fo all of the imports of the
1273 module. So we need to know that we will definitely not be recompiling
1274 any of these modules, and we can use the object code.
1275
1276 The stability check is as follows. Both stableObject and
1277 stableBCO are used during the upsweep phase later.
1278
1279 @
1280 stable m = stableObject m || stableBCO m
1281
1282 stableObject m =
1283 all stableObject (imports m)
1284 && old linkable does not exist, or is == on-disk .o
1285 && date(on-disk .o) > date(.hs)
1286
1287 stableBCO m =
1288 all stable (imports m)
1289 && date(BCO) > date(.hs)
1290 @
1291
1292 These properties embody the following ideas:
1293
1294 - if a module is stable, then:
1295
1296 - if it has been compiled in a previous pass (present in HPT)
1297 then it does not need to be compiled or re-linked.
1298
1299 - if it has not been compiled in a previous pass,
1300 then we only need to read its .hi file from disk and
1301 link it to produce a 'ModDetails'.
1302
1303 - if a modules is not stable, we will definitely be at least
1304 re-linking, and possibly re-compiling it during the 'upsweep'.
1305 All non-stable modules can (and should) therefore be unlinked
1306 before the 'upsweep'.
1307
1308 - Note that objects are only considered stable if they only depend
1309 on other objects. We can't link object code against byte code.
1310 -}
1311
1312 checkStability
1313 :: HomePackageTable -- HPT from last compilation
1314 -> [SCC ModSummary] -- current module graph (cyclic)
1315 -> [ModuleName] -- all home modules
1316 -> ([ModuleName], -- stableObject
1317 [ModuleName]) -- stableBCO
1318
1319 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
1320 where
1321 checkSCC (stable_obj, stable_bco) scc0
1322 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
1323 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
1324 | otherwise = (stable_obj, stable_bco)
1325 where
1326 scc = flattenSCC scc0
1327 scc_mods = map ms_mod_name scc
1328 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
1329
1330 scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
1331 -- all imports outside the current SCC, but in the home pkg
1332
1333 stable_obj_imps = map (`elem` stable_obj) scc_allimps
1334 stable_bco_imps = map (`elem` stable_bco) scc_allimps
1335
1336 stableObjects =
1337 and stable_obj_imps
1338 && all object_ok scc
1339
1340 stableBCOs =
1341 and (zipWith (||) stable_obj_imps stable_bco_imps)
1342 && all bco_ok scc
1343
1344 object_ok ms
1345 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
1346 && same_as_prev t
1347 | otherwise = False
1348 where
1349 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
1350 Just hmi | Just l <- hm_linkable hmi
1351 -> isObjectLinkable l && t == linkableTime l
1352 _other -> True
1353 -- why '>=' rather than '>' above? If the filesystem stores
1354 -- times to the nearset second, we may occasionally find that
1355 -- the object & source have the same modification time,
1356 -- especially if the source was automatically generated
1357 -- and compiled. Using >= is slightly unsafe, but it matches
1358 -- make's behaviour.
1359
1360 bco_ok ms
1361 = case lookupUFM hpt (ms_mod_name ms) of
1362 Just hmi | Just l <- hm_linkable hmi ->
1363 not (isObjectLinkable l) &&
1364 linkableTime l >= ms_hs_date ms
1365 _other -> False
1366
1367 -- -----------------------------------------------------------------------------
1368
1369 -- | Prune the HomePackageTable
1370 --
1371 -- Before doing an upsweep, we can throw away:
1372 --
1373 -- - For non-stable modules:
1374 -- - all ModDetails, all linked code
1375 -- - all unlinked code that is out of date with respect to
1376 -- the source file
1377 --
1378 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
1379 -- space at the end of the upsweep, because the topmost ModDetails of the
1380 -- old HPT holds on to the entire type environment from the previous
1381 -- compilation.
1382
1383 pruneHomePackageTable
1384 :: HomePackageTable
1385 -> [ModSummary]
1386 -> ([ModuleName],[ModuleName])
1387 -> HomePackageTable
1388
1389 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
1390 = mapUFM prune hpt
1391 where prune hmi
1392 | is_stable modl = hmi'
1393 | otherwise = hmi'{ hm_details = emptyModDetails }
1394 where
1395 modl = moduleName (mi_module (hm_iface hmi))
1396 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1397 = hmi{ hm_linkable = Nothing }
1398 | otherwise
1399 = hmi
1400 where ms = expectJust "prune" (lookupUFM ms_map modl)
1401
1402 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1403
1404 is_stable m = m `elem` stable_obj || m `elem` stable_bco
1405
1406 -- -----------------------------------------------------------------------------
1407
1408 -- Return (names of) all those in modsDone who are part of a cycle
1409 -- as defined by theGraph.
1410 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1411 findPartiallyCompletedCycles modsDone theGraph
1412 = chew theGraph
1413 where
1414 chew [] = []
1415 chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
1416 chew ((CyclicSCC vs):rest)
1417 = let names_in_this_cycle = nub (map ms_mod vs)
1418 mods_in_this_cycle
1419 = nub ([done | done <- modsDone,
1420 done `elem` names_in_this_cycle])
1421 chewed_rest = chew rest
1422 in
1423 if notNull mods_in_this_cycle
1424 && length mods_in_this_cycle < length names_in_this_cycle
1425 then mods_in_this_cycle ++ chewed_rest
1426 else chewed_rest
1427
1428 -- -----------------------------------------------------------------------------
1429
1430 -- | The upsweep
1431 --
1432 -- This is where we compile each module in the module graph, in a pass
1433 -- from the bottom to the top of the graph.
1434 --
1435 -- There better had not be any cyclic groups here -- we check for them.
1436
1437 upsweep
1438 :: GhcMonad m =>
1439 HscEnv -- ^ Includes initially-empty HPT
1440 -> HomePackageTable -- ^ HPT from last time round (pruned)
1441 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1442 -> IO () -- ^ How to clean up unwanted tmp files
1443 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1444 -> m (SuccessFlag,
1445 HscEnv,
1446 [ModSummary])
1447 -- ^ Returns:
1448 --
1449 -- 1. A flag whether the complete upsweep was successful.
1450 -- 2. The 'HscEnv' with an updated HPT
1451 -- 3. A list of modules which succeeded loading.
1452
1453 upsweep hsc_env old_hpt stable_mods cleanup sccs = do
1454 (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
1455 return (res, hsc_env, reverse done)
1456 where
1457
1458 upsweep' hsc_env _old_hpt done
1459 [] _ _
1460 = return (Succeeded, hsc_env, done)
1461
1462 upsweep' hsc_env _old_hpt done
1463 (CyclicSCC ms:_) _ _
1464 = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1465 return (Failed, hsc_env, done)
1466
1467 upsweep' hsc_env old_hpt done
1468 (AcyclicSCC mod:mods) mod_index nmods
1469 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1470 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1471 -- (moduleEnvElts (hsc_HPT hsc_env)))
1472 let logger = reportModuleCompilationResult (hsc_callbacks hsc_env)
1473
1474 mb_mod_info
1475 <- handleSourceError
1476 (\err -> do logger mod (Just err); return Nothing) $ do
1477 mod_info <- upsweep_mod hsc_env old_hpt stable_mods
1478 mod mod_index nmods
1479 logger mod Nothing -- log warnings
1480 return (Just mod_info)
1481
1482 liftIO cleanup -- Remove unwanted tmp files between compilations
1483
1484 case mb_mod_info of
1485 Nothing -> return (Failed, hsc_env, done)
1486 Just mod_info -> do
1487 let this_mod = ms_mod_name mod
1488
1489 -- Add new info to hsc_env
1490 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1491 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1492
1493 -- Space-saving: delete the old HPT entry
1494 -- for mod BUT if mod is a hs-boot
1495 -- node, don't delete it. For the
1496 -- interface, the HPT entry is probaby for the
1497 -- main Haskell source file. Deleting it
1498 -- would force the real module to be recompiled
1499 -- every time.
1500 old_hpt1 | isBootSummary mod = old_hpt
1501 | otherwise = delFromUFM old_hpt this_mod
1502
1503 done' = mod:done
1504
1505 -- fixup our HomePackageTable after we've finished compiling
1506 -- a mutually-recursive loop. See reTypecheckLoop, below.
1507 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
1508
1509 upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
1510
1511 -- | Compile a single module. Always produce a Linkable for it if
1512 -- successful. If no compilation happened, return the old Linkable.
1513 upsweep_mod :: GhcMonad m =>
1514 HscEnv
1515 -> HomePackageTable
1516 -> ([ModuleName],[ModuleName])
1517 -> ModSummary
1518 -> Int -- index of module
1519 -> Int -- total number of modules
1520 -> m HomeModInfo
1521
1522 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1523 = let
1524 this_mod_name = ms_mod_name summary
1525 this_mod = ms_mod summary
1526 mb_obj_date = ms_obj_date summary
1527 obj_fn = ml_obj_file (ms_location summary)
1528 hs_date = ms_hs_date summary
1529
1530 is_stable_obj = this_mod_name `elem` stable_obj
1531 is_stable_bco = this_mod_name `elem` stable_bco
1532
1533 old_hmi = lookupUFM old_hpt this_mod_name
1534
1535 -- We're using the dflags for this module now, obtained by
1536 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1537 dflags = ms_hspp_opts summary
1538 prevailing_target = hscTarget (hsc_dflags hsc_env)
1539 local_target = hscTarget dflags
1540
1541 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
1542 -- we don't do anything dodgy: these should only work to change
1543 -- from -fvia-C to -fasm and vice-versa, otherwise we could
1544 -- end up trying to link object code to byte code.
1545 target = if prevailing_target /= local_target
1546 && (not (isObjectTarget prevailing_target)
1547 || not (isObjectTarget local_target))
1548 then prevailing_target
1549 else local_target
1550
1551 -- store the corrected hscTarget into the summary
1552 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1553
1554 -- The old interface is ok if
1555 -- a) we're compiling a source file, and the old HPT
1556 -- entry is for a source file
1557 -- b) we're compiling a hs-boot file
1558 -- Case (b) allows an hs-boot file to get the interface of its
1559 -- real source file on the second iteration of the compilation
1560 -- manager, but that does no harm. Otherwise the hs-boot file
1561 -- will always be recompiled
1562
1563 mb_old_iface
1564 = case old_hmi of
1565 Nothing -> Nothing
1566 Just hm_info | isBootSummary summary -> Just iface
1567 | not (mi_boot iface) -> Just iface
1568 | otherwise -> Nothing
1569 where
1570 iface = hm_iface hm_info
1571
1572 compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo
1573 compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
1574
1575 compile_it_discard_iface :: GhcMonad m =>
1576 Maybe Linkable -> m HomeModInfo
1577 compile_it_discard_iface
1578 = compile hsc_env summary' mod_index nmods Nothing
1579
1580 -- With the HscNothing target we create empty linkables to avoid
1581 -- recompilation. We have to detect these to recompile anyway if
1582 -- the target changed since the last compile.
1583 is_fake_linkable
1584 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
1585 null (linkableUnlinked l)
1586 | otherwise =
1587 -- we have no linkable, so it cannot be fake
1588 False
1589
1590 implies False _ = True
1591 implies True x = x
1592
1593 in
1594 case () of
1595 _
1596 -- Regardless of whether we're generating object code or
1597 -- byte code, we can always use an existing object file
1598 -- if it is *stable* (see checkStability).
1599 | is_stable_obj, Just hmi <- old_hmi -> do
1600 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1601 (text "skipping stable obj mod:" <+> ppr this_mod_name)
1602 return hmi
1603 -- object is stable, and we have an entry in the
1604 -- old HPT: nothing to do
1605
1606 | is_stable_obj, isNothing old_hmi -> do
1607 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1608 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
1609 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1610 (expectJust "upsweep1" mb_obj_date)
1611 compile_it (Just linkable)
1612 -- object is stable, but we need to load the interface
1613 -- off disk to make a HMI.
1614
1615 | not (isObjectTarget target), is_stable_bco,
1616 (target /= HscNothing) `implies` not is_fake_linkable ->
1617 ASSERT(isJust old_hmi) -- must be in the old_hpt
1618 let Just hmi = old_hmi in do
1619 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1620 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
1621 return hmi
1622 -- BCO is stable: nothing to do
1623
1624 | not (isObjectTarget target),
1625 Just hmi <- old_hmi,
1626 Just l <- hm_linkable hmi,
1627 not (isObjectLinkable l),
1628 (target /= HscNothing) `implies` not is_fake_linkable,
1629 linkableTime l >= ms_hs_date summary -> do
1630 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1631 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
1632 compile_it (Just l)
1633 -- we have an old BCO that is up to date with respect
1634 -- to the source: do a recompilation check as normal.
1635
1636 -- When generating object code, if there's an up-to-date
1637 -- object file on the disk, then we can use it.
1638 -- However, if the object file is new (compared to any
1639 -- linkable we had from a previous compilation), then we
1640 -- must discard any in-memory interface, because this
1641 -- means the user has compiled the source file
1642 -- separately and generated a new interface, that we must
1643 -- read from the disk.
1644 --
1645 | isObjectTarget target,
1646 Just obj_date <- mb_obj_date,
1647 obj_date >= hs_date -> do
1648 case old_hmi of
1649 Just hmi
1650 | Just l <- hm_linkable hmi,
1651 isObjectLinkable l && linkableTime l == obj_date -> do
1652 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1653 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
1654 compile_it (Just l)
1655 _otherwise -> do
1656 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1657 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
1658 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1659 compile_it_discard_iface (Just linkable)
1660
1661 _otherwise -> do
1662 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1663 (text "compiling mod:" <+> ppr this_mod_name)
1664 compile_it Nothing
1665
1666
1667
1668 -- Filter modules in the HPT
1669 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1670 retainInTopLevelEnvs keep_these hpt
1671 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1672 | mod <- keep_these
1673 , let mb_mod_info = lookupUFM hpt mod
1674 , isJust mb_mod_info ]
1675
1676 -- ---------------------------------------------------------------------------
1677 -- Typecheck module loops
1678
1679 {-
1680 See bug #930. This code fixes a long-standing bug in --make. The
1681 problem is that when compiling the modules *inside* a loop, a data
1682 type that is only defined at the top of the loop looks opaque; but
1683 after the loop is done, the structure of the data type becomes
1684 apparent.
1685
1686 The difficulty is then that two different bits of code have
1687 different notions of what the data type looks like.
1688
1689 The idea is that after we compile a module which also has an .hs-boot
1690 file, we re-generate the ModDetails for each of the modules that
1691 depends on the .hs-boot file, so that everyone points to the proper
1692 TyCons, Ids etc. defined by the real module, not the boot module.
1693 Fortunately re-generating a ModDetails from a ModIface is easy: the
1694 function TcIface.typecheckIface does exactly that.
1695
1696 Picking the modules to re-typecheck is slightly tricky. Starting from
1697 the module graph consisting of the modules that have already been
1698 compiled, we reverse the edges (so they point from the imported module
1699 to the importing module), and depth-first-search from the .hs-boot
1700 node. This gives us all the modules that depend transitively on the
1701 .hs-boot module, and those are exactly the modules that we need to
1702 re-typecheck.
1703
1704 Following this fix, GHC can compile itself with --make -O2.
1705 -}
1706
1707 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1708 reTypecheckLoop hsc_env ms graph
1709 | not (isBootSummary ms) &&
1710 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
1711 = do
1712 let mss = reachableBackwards (ms_mod_name ms) graph
1713 non_boot = filter (not.isBootSummary) mss
1714 debugTraceMsg (hsc_dflags hsc_env) 2 $
1715 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
1716 typecheckLoop hsc_env (map ms_mod_name non_boot)
1717 | otherwise
1718 = return hsc_env
1719 where
1720 this_mod = ms_mod ms
1721
1722 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
1723 typecheckLoop hsc_env mods = do
1724 new_hpt <-
1725 fixIO $ \new_hpt -> do
1726 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1727 mds <- initIfaceCheck new_hsc_env $
1728 mapM (typecheckIface . hm_iface) hmis
1729 let new_hpt = addListToUFM old_hpt
1730 (zip mods [ hmi{ hm_details = details }
1731 | (hmi,details) <- zip hmis mds ])
1732 return new_hpt
1733 return hsc_env{ hsc_HPT = new_hpt }
1734 where
1735 old_hpt = hsc_HPT hsc_env
1736 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
1737
1738 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1739 reachableBackwards mod summaries
1740 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
1741 where -- the rest just sets up the graph:
1742 (graph, lookup_node) = moduleGraphNodes False summaries
1743 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1744
1745 -- ---------------------------------------------------------------------------
1746 -- Topological sort of the module graph
1747
1748 type SummaryNode = (ModSummary, Int, [Int])
1749
1750 topSortModuleGraph
1751 :: Bool
1752 -- ^ Drop hi-boot nodes? (see below)
1753 -> [ModSummary]
1754 -> Maybe ModuleName
1755 -- ^ Root module name. If @Nothing@, use the full graph.
1756 -> [SCC ModSummary]
1757 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1758 -- The resulting list of strongly-connected-components is in topologically
1759 -- sorted order, starting with the module(s) at the bottom of the
1760 -- dependency graph (ie compile them first) and ending with the ones at
1761 -- the top.
1762 --
1763 -- Drop hi-boot nodes (first boolean arg)?
1764 --
1765 -- - @False@: treat the hi-boot summaries as nodes of the graph,
1766 -- so the graph must be acyclic
1767 --
1768 -- - @True@: eliminate the hi-boot nodes, and instead pretend
1769 -- the a source-import of Foo is an import of Foo
1770 -- The resulting graph has no hi-boot nodes, but can be cyclic
1771
1772 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
1773 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1774 where
1775 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
1776
1777 initial_graph = case mb_root_mod of
1778 Nothing -> graph
1779 Just root_mod ->
1780 -- restrict the graph to just those modules reachable from
1781 -- the specified module. We do this by building a graph with
1782 -- the full set of nodes, and determining the reachable set from
1783 -- the specified node.
1784 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
1785 | otherwise = ghcError (ProgramError "module does not exist")
1786 in graphFromEdgedVertices (seq root (reachableG graph root))
1787
1788 summaryNodeKey :: SummaryNode -> Int
1789 summaryNodeKey (_, k, _) = k
1790
1791 summaryNodeSummary :: SummaryNode -> ModSummary
1792 summaryNodeSummary (s, _, _) = s
1793
1794 moduleGraphNodes :: Bool -> [ModSummary]
1795 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1796 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
1797 where
1798 numbered_summaries = zip summaries [1..]
1799
1800 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1801 lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
1802
1803 lookup_key :: HscSource -> ModuleName -> Maybe Int
1804 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1805
1806 node_map :: NodeMap SummaryNode
1807 node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
1808 | node@(s, _, _) <- nodes ]
1809
1810 -- We use integers as the keys for the SCC algorithm
1811 nodes :: [SummaryNode]
1812 nodes = [ (s, key, out_keys)
1813 | (s, key) <- numbered_summaries
1814 -- Drop the hi-boot ones if told to do so
1815 , not (isBootSummary s && drop_hs_boot_nodes)
1816 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1817 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1818 (-- see [boot-edges] below
1819 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1820 then []
1821 else case lookup_key HsBootFile (ms_mod_name s) of
1822 Nothing -> []
1823 Just k -> [k]) ]
1824
1825 -- [boot-edges] if this is a .hs and there is an equivalent
1826 -- .hs-boot, add a link from the former to the latter. This
1827 -- has the effect of detecting bogus cases where the .hs-boot
1828 -- depends on the .hs, by introducing a cycle. Additionally,
1829 -- it ensures that we will always process the .hs-boot before
1830 -- the .hs, and so the HomePackageTable will always have the
1831 -- most up to date information.
1832
1833 -- Drop hs-boot nodes by using HsSrcFile as the key
1834 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1835 | otherwise = HsBootFile
1836
1837 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1838 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1839 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1840 -- the IsBootInterface parameter True; else False
1841
1842
1843 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1844 type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs
1845
1846 msKey :: ModSummary -> NodeKey
1847 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1848
1849 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1850 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1851
1852 nodeMapElts :: NodeMap a -> [a]
1853 nodeMapElts = Map.elems
1854
1855 -- | If there are {-# SOURCE #-} imports between strongly connected
1856 -- components in the topological sort, then those imports can
1857 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1858 -- were necessary, then the edge would be part of a cycle.
1859 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1860 warnUnnecessarySourceImports sccs =
1861 logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
1862 where check ms =
1863 let mods_in_this_cycle = map ms_mod_name ms in
1864 [ warn i | m <- ms, i <- ms_home_srcimps m,
1865 unLoc i `notElem` mods_in_this_cycle ]
1866
1867 warn :: Located ModuleName -> WarnMsg
1868 warn (L loc mod) =
1869 mkPlainErrMsg loc
1870 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1871 <+> quotes (ppr mod))
1872
1873 -----------------------------------------------------------------------------
1874 -- Downsweep (dependency analysis)
1875
1876 -- Chase downwards from the specified root set, returning summaries
1877 -- for all home modules encountered. Only follow source-import
1878 -- links.
1879
1880 -- We pass in the previous collection of summaries, which is used as a
1881 -- cache to avoid recalculating a module summary if the source is
1882 -- unchanged.
1883 --
1884 -- The returned list of [ModSummary] nodes has one node for each home-package
1885 -- module, plus one for any hs-boot files. The imports of these nodes
1886 -- are all there, including the imports of non-home-package modules.
1887
1888 downsweep :: GhcMonad m =>
1889 HscEnv
1890 -> [ModSummary] -- Old summaries
1891 -> [ModuleName] -- Ignore dependencies on these; treat
1892 -- them as if they were package modules
1893 -> Bool -- True <=> allow multiple targets to have
1894 -- the same module name; this is
1895 -- very useful for ghc -M
1896 -> m [ModSummary]
1897 -- The elts of [ModSummary] all have distinct
1898 -- (Modules, IsBoot) identifiers, unless the Bool is true
1899 -- in which case there can be repeats
1900 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1901 = do -- catch error messages and return them
1902 --handleErrMsg -- should be covered by GhcMonad now
1903 -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1904 rootSummaries <- mapM getRootSummary roots
1905 let root_map = mkRootMap rootSummaries
1906 checkDuplicates root_map
1907 summs <- loop (concatMap msDeps rootSummaries) root_map
1908 return summs
1909 where
1910 roots = hsc_targets hsc_env
1911
1912 old_summary_map :: NodeMap ModSummary
1913 old_summary_map = mkNodeMap old_summaries
1914
1915 getRootSummary :: GhcMonad m => Target -> m ModSummary
1916 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1917 = do exists <- liftIO $ doesFileExist file
1918 if exists
1919 then summariseFile hsc_env old_summaries file mb_phase
1920 obj_allowed maybe_buf
1921 else throwOneError $ mkPlainErrMsg noSrcSpan $
1922 text "can't find file:" <+> text file
1923 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1924 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1925 (L rootLoc modl) obj_allowed
1926 maybe_buf excl_mods
1927 case maybe_summary of
1928 Nothing -> packageModErr modl
1929 Just s -> return s
1930
1931 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1932
1933 -- In a root module, the filename is allowed to diverge from the module
1934 -- name, so we have to check that there aren't multiple root files
1935 -- defining the same module (otherwise the duplicates will be silently
1936 -- ignored, leading to confusing behaviour).
1937 checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m ()
1938 checkDuplicates root_map
1939 | allow_dup_roots = return ()
1940 | null dup_roots = return ()
1941 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1942 where
1943 dup_roots :: [[ModSummary]] -- Each at least of length 2
1944 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1945
1946 loop :: GhcMonad m =>
1947 [(Located ModuleName,IsBootInterface)]
1948 -- Work list: process these modules
1949 -> NodeMap [ModSummary]
1950 -- Visited set; the range is a list because
1951 -- the roots can have the same module names
1952 -- if allow_dup_roots is True
1953 -> m [ModSummary]
1954 -- The result includes the worklist, except
1955 -- for those mentioned in the visited set
1956 loop [] done = return (concat (nodeMapElts done))
1957 loop ((wanted_mod, is_boot) : ss) done
1958 | Just summs <- Map.lookup key done
1959 = if isSingleton summs then
1960 loop ss done
1961 else
1962 do { liftIO $ multiRootsErr summs; return [] }
1963 | otherwise
1964 = do mb_s <- summariseModule hsc_env old_summary_map
1965 is_boot wanted_mod True
1966 Nothing excl_mods
1967 case mb_s of
1968 Nothing -> loop ss done
1969 Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
1970 where
1971 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1972
1973 -- XXX Does the (++) here need to be flipped?
1974 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1975 mkRootMap summaries = Map.insertListWith (flip (++))
1976 [ (msKey s, [s]) | s <- summaries ]
1977 Map.empty
1978
1979 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1980 -- (msDeps s) returns the dependencies of the ModSummary s.
1981 -- A wrinkle is that for a {-# SOURCE #-} import we return
1982 -- *both* the hs-boot file
1983 -- *and* the source file
1984 -- as "dependencies". That ensures that the list of all relevant
1985 -- modules always contains B.hs if it contains B.hs-boot.
1986 -- Remember, this pass isn't doing the topological sort. It's
1987 -- just gathering the list of all relevant ModSummaries
1988 msDeps s =
1989 concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
1990 ++ [ (m,False) | m <- ms_home_imps s ]
1991
1992 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
1993 home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
1994 where isLocal Nothing = True
1995 isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
1996 isLocal _ = False
1997
1998 ms_home_allimps :: ModSummary -> [ModuleName]
1999 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
2000
2001 ms_home_srcimps :: ModSummary -> [Located ModuleName]
2002 ms_home_srcimps = home_imps . ms_srcimps
2003
2004 ms_home_imps :: ModSummary -> [Located ModuleName]
2005 ms_home_imps = home_imps . ms_imps
2006
2007 -----------------------------------------------------------------------------
2008 -- Summarising modules
2009
2010 -- We have two types of summarisation:
2011 --
2012 -- * Summarise a file. This is used for the root module(s) passed to
2013 -- cmLoadModules. The file is read, and used to determine the root
2014 -- module name. The module name may differ from the filename.
2015 --
2016 -- * Summarise a module. We are given a module name, and must provide
2017 -- a summary. The finder is used to locate the file in which the module
2018 -- resides.
2019
2020 summariseFile
2021 :: GhcMonad m =>
2022 HscEnv
2023 -> [ModSummary] -- old summaries
2024 -> FilePath -- source file name
2025 -> Maybe Phase -- start phase
2026 -> Bool -- object code allowed?
2027 -> Maybe (StringBuffer,ClockTime)
2028 -> m ModSummary
2029
2030 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
2031 -- we can use a cached summary if one is available and the
2032 -- source file hasn't changed, But we have to look up the summary
2033 -- by source file, rather than module name as we do in summarise.
2034 | Just old_summary <- findSummaryBySourceFile old_summaries file
2035 = do
2036 let location = ms_location old_summary
2037
2038 -- return the cached summary if the source didn't change
2039 src_timestamp <- case maybe_buf of
2040 Just (_,t) -> return t
2041 Nothing -> liftIO $ getModificationTime file
2042 -- The file exists; we checked in getRootSummary above.
2043 -- If it gets removed subsequently, then this
2044 -- getModificationTime may fail, but that's the right
2045 -- behaviour.
2046
2047 if ms_hs_date old_summary == src_timestamp
2048 then do -- update the object-file timestamp
2049 obj_timestamp <-
2050 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2051 || obj_allowed -- bug #1205
2052 then liftIO $ getObjTimestamp location False
2053 else return Nothing
2054 return old_summary{ ms_obj_date = obj_timestamp }
2055 else
2056 new_summary
2057
2058 | otherwise
2059 = new_summary
2060 where
2061 new_summary = do
2062 let dflags = hsc_dflags hsc_env
2063
2064 (dflags', hspp_fn, buf)
2065 <- preprocessFile hsc_env file mb_phase maybe_buf
2066
2067 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
2068
2069 -- Make a ModLocation for this file
2070 location <- liftIO $ mkHomeModLocation dflags mod_name file
2071
2072 -- Tell the Finder cache where it is, so that subsequent calls
2073 -- to findModule will find it, even if it's not on any search path
2074 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
2075
2076 src_timestamp <- case maybe_buf of
2077 Just (_,t) -> return t
2078 Nothing -> liftIO $ getModificationTime file
2079 -- getMofificationTime may fail
2080
2081 -- when the user asks to load a source file by name, we only
2082 -- use an object file if -fobject-code is on. See #1205.
2083 obj_timestamp <-
2084 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2085 || obj_allowed -- bug #1205
2086 then liftIO $ modificationTimeIfExists (ml_obj_file location)
2087 else return Nothing
2088
2089 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
2090 ms_location = location,
2091 ms_hspp_file = hspp_fn,
2092 ms_hspp_opts = dflags',
2093 ms_hspp_buf = Just buf,
2094 ms_srcimps = srcimps, ms_imps = the_imps,
2095 ms_hs_date = src_timestamp,
2096 ms_obj_date = obj_timestamp })
2097
2098 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
2099 findSummaryBySourceFile summaries file
2100 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
2101 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
2102 [] -> Nothing
2103 (x:_) -> Just x
2104
2105 -- Summarise a module, and pick up source and timestamp.
2106 summariseModule
2107 :: GhcMonad m =>
2108 HscEnv
2109 -> NodeMap ModSummary -- Map of old summaries
2110 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
2111 -> Located ModuleName -- Imported module to be summarised
2112 -> Bool -- object code allowed?
2113 -> Maybe (StringBuffer, ClockTime)
2114 -> [ModuleName] -- Modules to exclude
2115 -> m (Maybe ModSummary) -- Its new summary
2116
2117 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
2118 obj_allowed maybe_buf excl_mods
2119 | wanted_mod `elem` excl_mods
2120 = return Nothing
2121
2122 | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
2123 = do -- Find its new timestamp; all the
2124 -- ModSummaries in the old map have valid ml_hs_files
2125 let location = ms_location old_summary
2126 src_fn = expectJust "summariseModule" (ml_hs_file location)
2127
2128 -- check the modification time on the source file, and
2129 -- return the cached summary if it hasn't changed. If the
2130 -- file has disappeared, we need to call the Finder again.
2131 case maybe_buf of
2132 Just (_,t) -> check_timestamp old_summary location src_fn t
2133 Nothing -> do
2134 m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
2135 case m of
2136 Right t -> check_timestamp old_summary location src_fn t
2137 Left e | isDoesNotExistError e -> find_it
2138 | otherwise -> liftIO $ ioError e
2139
2140 | otherwise = find_it
2141 where
2142 dflags = hsc_dflags hsc_env
2143
2144 hsc_src = if is_boot then HsBootFile else HsSrcFile
2145
2146 check_timestamp old_summary location src_fn src_timestamp
2147 | ms_hs_date old_summary == src_timestamp = do
2148 -- update the object-file timestamp
2149 obj_timestamp <- liftIO $
2150 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2151 || obj_allowed -- bug #1205
2152 then getObjTimestamp location is_boot
2153 else return Nothing
2154 return (Just old_summary{ ms_obj_date = obj_timestamp })
2155 | otherwise =
2156 -- source changed: re-summarise.
2157 new_summary location (ms_mod old_summary) src_fn src_timestamp
2158
2159 find_it = do
2160 -- Don't use the Finder's cache this time. If the module was
2161 -- previously a package module, it may have now appeared on the
2162 -- search path, so we want to consider it to be a home module. If
2163 -- the module was previously a home module, it may have moved.
2164 liftIO $ uncacheModule hsc_env wanted_mod
2165 found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
2166 case found of
2167 Found location mod
2168 | isJust (ml_hs_file location) ->
2169 -- Home package
2170 just_found location mod
2171 | otherwise ->
2172 -- Drop external-pkg
2173 ASSERT(modulePackageId mod /= thisPackage dflags)
2174 return Nothing
2175
2176 err -> liftIO $ noModError dflags loc wanted_mod err
2177 -- Not found
2178
2179 just_found location mod = do
2180 -- Adjust location to point to the hs-boot source file,
2181 -- hi file, object file, when is_boot says so
2182 let location' | is_boot = addBootSuffixLocn location
2183 | otherwise = location
2184 src_fn = expectJust "summarise2" (ml_hs_file location')
2185
2186 -- Check that it exists
2187 -- It might have been deleted since the Finder last found it
2188 maybe_t <- liftIO $ modificationTimeIfExists src_fn
2189 case maybe_t of
2190 Nothing -> noHsFileErr loc src_fn
2191 Just t -> new_summary location' mod src_fn t
2192
2193
2194 new_summary location mod src_fn src_timestamp
2195 = do
2196 -- Preprocess the source file and get its imports
2197 -- The dflags' contains the OPTIONS pragmas
2198 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2199 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
2200
2201 when (mod_name /= wanted_mod) $
2202 throwOneError $ mkPlainErrMsg mod_loc $
2203 text "File name does not match module name:"
2204 $$ text "Saw:" <+> quotes (ppr mod_name)
2205 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2206
2207 -- Find the object timestamp, and return the summary
2208 obj_timestamp <- liftIO $
2209 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2210 || obj_allowed -- bug #1205
2211 then getObjTimestamp location is_boot
2212 else return Nothing
2213
2214 return (Just (ModSummary { ms_mod = mod,
2215 ms_hsc_src = hsc_src,
2216 ms_location = location,
2217 ms_hspp_file = hspp_fn,
2218 ms_hspp_opts = dflags',
2219 ms_hspp_buf = Just buf,
2220 ms_srcimps = srcimps,
2221 ms_imps = the_imps,
2222 ms_hs_date = src_timestamp,
2223 ms_obj_date = obj_timestamp }))
2224
2225
2226 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
2227 getObjTimestamp location is_boot
2228 = if is_boot then return Nothing
2229 else modificationTimeIfExists (ml_obj_file location)
2230
2231
2232 preprocessFile :: GhcMonad m =>
2233 HscEnv
2234 -> FilePath
2235 -> Maybe Phase -- ^ Starting phase
2236 -> Maybe (StringBuffer,ClockTime)
2237 -> m (DynFlags, FilePath, StringBuffer)
2238 preprocessFile hsc_env src_fn mb_phase Nothing
2239 = do
2240 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2241 buf <- liftIO $ hGetStringBuffer hspp_fn
2242 return (dflags', hspp_fn, buf)
2243
2244 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2245 = do
2246 let dflags = hsc_dflags hsc_env
2247 -- case we bypass the preprocessing stage?
2248 let
2249 local_opts = getOptions dflags buf src_fn
2250 --
2251 (dflags', leftovers, warns)
2252 <- parseDynamicNoPackageFlags dflags local_opts
2253 checkProcessArgsResult leftovers
2254 handleFlagWarnings dflags' warns
2255
2256 let
2257 needs_preprocessing
2258 | Just (Unlit _) <- mb_phase = True
2259 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2260 -- note: local_opts is only required if there's no Unlit phase
2261 | xopt Opt_Cpp dflags' = True
2262 | dopt Opt_Pp dflags' = True
2263 | otherwise = False
2264
2265 when needs_preprocessing $
2266 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
2267
2268 return (dflags', src_fn, buf)
2269
2270
2271 -----------------------------------------------------------------------------
2272 -- Error messages
2273 -----------------------------------------------------------------------------
2274
2275 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
2276 -- ToDo: we don't have a proper line number for this error
2277 noModError dflags loc wanted_mod err
2278 = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
2279
2280 noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
2281 noHsFileErr loc path
2282 = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
2283
2284 packageModErr :: GhcMonad m => ModuleName -> m a
2285 packageModErr mod
2286 = throwOneError $ mkPlainErrMsg noSrcSpan $
2287 text "module" <+> quotes (ppr mod) <+> text "is a package module"
2288
2289 multiRootsErr :: [ModSummary] -> IO ()
2290 multiRootsErr [] = panic "multiRootsErr"
2291 multiRootsErr summs@(summ1:_)
2292 = throwOneError $ mkPlainErrMsg noSrcSpan $
2293 text "module" <+> quotes (ppr mod) <+>
2294 text "is defined in multiple files:" <+>
2295 sep (map text files)
2296 where
2297 mod = ms_mod summ1
2298 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2299
2300 cyclicModuleErr :: [ModSummary] -> SDoc
2301 cyclicModuleErr ms
2302 = hang (ptext (sLit "Module imports form a cycle for modules:"))
2303 2 (vcat (map show_one ms))
2304 where
2305 mods_in_cycle = map ms_mod_name ms
2306 imp_modname = unLoc . ideclName . unLoc
2307 just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
2308
2309 show_one ms =
2310 vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
2311 maybe empty (parens . text) (ml_hs_file (ms_location ms)),
2312 nest 2 $ ptext (sLit "imports:") <+> vcat [
2313 pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
2314 pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]
2315 ]
2316 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
2317 pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
2318
2319
2320 -- | Inform GHC that the working directory has changed. GHC will flush
2321 -- its cache of module locations, since it may no longer be valid.
2322 --
2323 -- Note: Before changing the working directory make sure all threads running
2324 -- in the same session have stopped. If you change the working directory,
2325 -- you should also unload the current program (set targets to empty,
2326 -- followed by load).
2327 workingDirectoryChanged :: GhcMonad m => m ()
2328 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
2329
2330 -- -----------------------------------------------------------------------------
2331 -- inspecting the session
2332
2333 -- | Get the module dependency graph.
2334 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
2335 getModuleGraph = liftM hsc_mod_graph getSession
2336
2337 -- | Determines whether a set of modules requires Template Haskell.
2338 --
2339 -- Note that if the session's 'DynFlags' enabled Template Haskell when
2340 -- 'depanal' was called, then each module in the returned module graph will
2341 -- have Template Haskell enabled whether it is actually needed or not.
2342 needsTemplateHaskell :: ModuleGraph -> Bool
2343 needsTemplateHaskell ms =
2344 any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
2345
2346 -- | Return @True@ <==> module is loaded.
2347 isLoaded :: GhcMonad m => ModuleName -> m Bool
2348 isLoaded m = withSession $ \hsc_env ->
2349 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
2350
2351 -- | Return the bindings for the current interactive session.
2352 getBindings :: GhcMonad m => m [TyThing]
2353 getBindings = withSession $ \hsc_env ->
2354 -- we have to implement the shadowing behaviour of ic_tmp_ids here
2355 -- (see InteractiveContext) and the quickest way is to use an OccEnv.
2356 let
2357 occ_env = mkOccEnv [ (nameOccName (idName id), AnId id)
2358 | id <- ic_tmp_ids (hsc_IC hsc_env) ]
2359 in
2360 return (occEnvElts occ_env)
2361
2362 getPrintUnqual :: GhcMonad m => m PrintUnqualified
2363 getPrintUnqual = withSession $ \hsc_env ->
2364 return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
2365
2366 -- | Container for information about a 'Module'.
2367 data ModuleInfo = ModuleInfo {
2368 minf_type_env :: TypeEnv,
2369 minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
2370 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
2371 minf_instances :: [Instance]
2372 #ifdef GHCI
2373 ,minf_modBreaks :: ModBreaks
2374 #endif
2375 -- ToDo: this should really contain the ModIface too
2376 }
2377 -- We don't want HomeModInfo here, because a ModuleInfo applies
2378 -- to package modules too.
2379
2380 -- | Request information about a loaded 'Module'
2381 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
2382 getModuleInfo mdl = withSession $ \hsc_env -> do
2383 let mg = hsc_mod_graph hsc_env
2384 if mdl `elem` map ms_mod mg
2385 then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
2386 else do
2387 {- if isHomeModule (hsc_dflags hsc_env) mdl
2388 then return Nothing
2389 else -} liftIO $ getPackageModuleInfo hsc_env mdl
2390 -- getPackageModuleInfo will attempt to find the interface, so
2391 -- we don't want to call it for a home module, just in case there
2392 -- was a problem loading the module and the interface doesn't
2393 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
2394
2395 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
2396 #ifdef GHCI
2397 getPackageModuleInfo hsc_env mdl = do
2398 (_msgs, mb_avails) <- getModuleExports hsc_env mdl
2399 case mb_avails of
2400 Nothing -> return Nothing
2401 Just avails -> do
2402 eps <- readIORef (hsc_EPS hsc_env)
2403 let
2404 names = availsToNameSet avails
2405 pte = eps_PTE eps
2406 tys = [ ty | name <- concatMap availNames avails,
2407 Just ty <- [lookupTypeEnv pte name] ]
2408 --
2409 return (Just (ModuleInfo {
2410 minf_type_env = mkTypeEnv tys,
2411 minf_exports = names,
2412 minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
2413 minf_instances = error "getModuleInfo: instances for package module unimplemented",
2414 minf_modBreaks = emptyModBreaks
2415 }))
2416 #else
2417 getPackageModuleInfo _hsc_env _mdl = do
2418 -- bogusly different for non-GHCI (ToDo)
2419 return Nothing
2420 #endif
2421
2422 getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
2423 getHomeModuleInfo hsc_env mdl =
2424 case lookupUFM (hsc_HPT hsc_env) mdl of
2425 Nothing -> return Nothing
2426 Just hmi -> do
2427 let details = hm_details hmi
2428 return (Just (ModuleInfo {
2429 minf_type_env = md_types details,
2430 minf_exports = availsToNameSet (md_exports details),
2431 minf_rdr_env = mi_globals $! hm_iface hmi,
2432 minf_instances = md_insts details
2433 #ifdef GHCI
2434 ,minf_modBreaks = getModBreaks hmi
2435 #endif
2436 }))
2437
2438 -- | The list of top-level entities defined in a module
2439 modInfoTyThings :: ModuleInfo -> [TyThing]
2440 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
2441
2442 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
2443 modInfoTopLevelScope minf
2444 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
2445
2446 modInfoExports :: ModuleInfo -> [Name]
2447 modInfoExports minf = nameSetToList $! minf_exports minf
2448
2449 -- | Returns the instances defined by the specified module.
2450 -- Warning: currently unimplemented for package modules.
2451 modInfoInstances :: ModuleInfo -> [Instance]
2452 modInfoInstances = minf_instances
2453
2454 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
2455 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
2456
2457 mkPrintUnqualifiedForModule :: GhcMonad m =>
2458 ModuleInfo
2459 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
2460 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
2461 return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
2462
2463 modInfoLookupName :: GhcMonad m =>
2464 ModuleInfo -> Name
2465 -> m (Maybe TyThing) -- XXX: returns a Maybe X
2466 modInfoLookupName minf name = withSession $ \hsc_env -> do
2467 case lookupTypeEnv (minf_type_env minf) name of
2468 Just tyThing -> return (Just tyThing)
2469 Nothing -> do
2470 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2471 return $! lookupType (hsc_dflags hsc_env)
2472 (hsc_HPT hsc_env) (eps_PTE eps) name
2473
2474 #ifdef GHCI
2475 modInfoModBreaks :: ModuleInfo -> ModBreaks
2476 modInfoModBreaks = minf_modBreaks
2477 #endif
2478
2479 isDictonaryId :: Id -> Bool
2480 isDictonaryId id
2481 = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
2482
2483 -- | Looks up a global name: that is, any top-level name in any
2484 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
2485 -- the interactive context, and therefore does not require a preceding
2486 -- 'setContext'.
2487 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
2488 lookupGlobalName name = withSession $ \hsc_env -> do
2489 liftIO $ lookupTypeHscEnv hsc_env name
2490
2491 findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
2492 findGlobalAnns deserialize target = withSession $ \hsc_env -> do
2493 ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
2494 return (findAnns deserialize ann_env target)
2495
2496 #ifdef GHCI
2497 -- | get the GlobalRdrEnv for a session
2498 getGRE :: GhcMonad m => m GlobalRdrEnv
2499 getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
2500 #endif
2501
2502 -- -----------------------------------------------------------------------------
2503
2504 -- | Return all /external/ modules available in the package database.
2505 -- Modules from the current session (i.e., from the 'HomePackageTable') are
2506 -- not included.
2507 packageDbModules :: GhcMonad m =>
2508 Bool -- ^ Only consider exposed packages.
2509 -> m [Module]
2510 packageDbModules only_exposed = do
2511 dflags <- getSessionDynFlags
2512 let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
2513 return $
2514 [ mkModule pid modname | p <- pkgs
2515 , not only_exposed || exposed p
2516 , let pid = packageConfigId p
2517 , modname <- exposedModules p ]
2518
2519 -- -----------------------------------------------------------------------------
2520 -- Misc exported utils
2521
2522 dataConType :: DataCon -> Type
2523 dataConType dc = idType (dataConWrapId dc)
2524
2525 -- | print a 'NamedThing', adding parentheses if the name is an operator.
2526 pprParenSymName :: NamedThing a => a -> SDoc
2527 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
2528
2529 -- ----------------------------------------------------------------------------
2530
2531 #if 0
2532
2533 -- ToDo:
2534 -- - Data and Typeable instances for HsSyn.
2535
2536 -- ToDo: check for small transformations that happen to the syntax in
2537 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
2538
2539 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
2540 -- to get from TyCons, Ids etc. to TH syntax (reify).
2541
2542 -- :browse will use either lm_toplev or inspect lm_interface, depending
2543 -- on whether the module is interpreted or not.
2544
2545 #endif
2546
2547 -- Extract the filename, stringbuffer content and dynflags associed to a module
2548 --
2549 -- XXX: Explain pre-conditions
2550 getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
2551 getModuleSourceAndFlags mod = do
2552 m <- getModSummary (moduleName mod)
2553 case ml_hs_file $ ms_location m of
2554 Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
2555 Just sourceFile -> do
2556 source <- liftIO $ hGetStringBuffer sourceFile
2557 return (sourceFile, source, ms_hspp_opts m)
2558
2559
2560 -- | Return module source as token stream, including comments.
2561 --
2562 -- The module must be in the module graph and its source must be available.
2563 -- Throws a 'HscTypes.SourceError' on parse error.
2564 getTokenStream :: GhcMonad m => Module -> m [Located Token]
2565 getTokenStream mod = do
2566 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2567 let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
2568 case lexTokenStream source startLoc flags of
2569 POk _ ts -> return ts
2570 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2571
2572 -- | Give even more information on the source than 'getTokenStream'
2573 -- This function allows reconstructing the source completely with
2574 -- 'showRichTokenStream'.
2575 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
2576 getRichTokenStream mod = do
2577 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2578 let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
2579 case lexTokenStream source startLoc flags of
2580 POk _ ts -> return $ addSourceToTokens startLoc source ts
2581 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2582
2583 -- | Given a source location and a StringBuffer corresponding to this
2584 -- location, return a rich token stream with the source associated to the
2585 -- tokens.
2586 addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
2587 -> [(Located Token, String)]
2588 addSourceToTokens _ _ [] = []
2589 addSourceToTokens loc buf (t@(L span _) : ts)
2590 | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
2591 | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
2592 where
2593 (newLoc, newBuf, str) = go "" loc buf
2594 start = srcSpanStart span
2595 end = srcSpanEnd span
2596 go acc loc buf | loc < start = go acc nLoc nBuf
2597 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
2598 | otherwise = (loc, buf, reverse acc)
2599 where (ch, nBuf) = nextChar buf
2600 nLoc = advanceSrcLoc loc ch
2601
2602
2603 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
2604 -- return source code almost identical to the original code (except for
2605 -- insignificant whitespace.)
2606 showRichTokenStream :: [(Located Token, String)] -> String
2607 showRichTokenStream ts = go startLoc ts ""
2608 where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
2609 startLoc = mkSrcLoc sourceFile 1 1
2610 go _ [] = id
2611 go loc ((L span _, str):ts)
2612 | not (isGoodSrcSpan span) = go loc ts
2613 | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
2614 . (str ++)
2615 . go tokEnd ts
2616 | otherwise = ((replicate (tokLine - locLine) '\n') ++)
2617 . ((replicate tokCol ' ') ++)
2618 . (str ++)
2619 . go tokEnd ts
2620 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
2621 (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
2622 tokEnd = srcSpanEnd span
2623
2624 -- -----------------------------------------------------------------------------
2625 -- Interactive evaluation
2626
2627 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
2628 -- filesystem and package database to find the corresponding 'Module',
2629 -- using the algorithm that is used for an @import@ declaration.
2630 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2631 findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
2632 let
2633 dflags = hsc_dflags hsc_env
2634 this_pkg = thisPackage dflags
2635 --
2636 case maybe_pkg of
2637 Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
2638 res <- findImportedModule hsc_env mod_name maybe_pkg
2639 case res of
2640 Found _ m -> return m
2641 err -> noModError dflags noSrcSpan mod_name err
2642 _otherwise -> do
2643 home <- lookupLoadedHomeModule mod_name
2644 case home of
2645 Just m -> return m
2646 Nothing -> liftIO $ do
2647 res <- findImportedModule hsc_env mod_name maybe_pkg
2648 case res of
2649 Found loc m | modulePackageId m /= this_pkg -> return m
2650 | otherwise -> modNotLoadedError m loc
2651 err -> noModError dflags noSrcSpan mod_name err
2652
2653 modNotLoadedError :: Module -> ModLocation -> IO a
2654 modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
2655 text "module is not loaded:" <+>
2656 quotes (ppr (moduleName m)) <+>
2657 parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
2658
2659 -- | Like 'findModule', but differs slightly when the module refers to
2660 -- a source file, and the file has not been loaded via 'load'. In
2661 -- this case, 'findModule' will throw an error (module not loaded),
2662 -- but 'lookupModule' will check to see whether the module can also be
2663 -- found in a package, and if so, that package 'Module' will be
2664 -- returned. If not, the usual module-not-found error will be thrown.
2665 --
2666 lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2667 lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
2668 lookupModule mod_name Nothing = withSession $ \hsc_env -> do
2669 home <- lookupLoadedHomeModule mod_name
2670 case home of
2671 Just m -> return m
2672 Nothing -> liftIO $ do
2673 res <- findExposedPackageModule hsc_env mod_name Nothing
2674 case res of
2675 Found _ m -> return m
2676 err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
2677
2678 lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
2679 lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
2680 case lookupUFM (hsc_HPT hsc_env) mod_name of
2681 Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
2682 _not_a_home_module -> return Nothing
2683
2684 #ifdef GHCI
2685 getHistorySpan :: GhcMonad m => History -> m SrcSpan
2686 getHistorySpan h = withSession $ \hsc_env ->
2687 return$ InteractiveEval.getHistorySpan hsc_env h
2688
2689 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
2690 obtainTermFromVal bound force ty a =
2691 withSession $ \hsc_env ->
2692 liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
2693
2694 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
2695 obtainTermFromId bound force id =
2696 withSession $ \hsc_env ->
2697 liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
2698
2699 #endif
2700
2701 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
2702 -- entity known to GHC, including 'Name's defined using 'runStmt'.
2703 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
2704 lookupName name = withSession $ \hsc_env -> do
2705 mb_tything <- ioMsg $ tcRnLookupName hsc_env name
2706 return mb_tything
2707 -- XXX: calls panic in some circumstances; is that ok?
2708