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