Add in `-fwarn-trustworthy-safe` flag.
[ghc.git] / compiler / main / HscMain.hs
1 {-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}
2
3 -------------------------------------------------------------------------------
4 --
5 -- | Main API for compiling plain Haskell source code.
6 --
7 -- This module implements compilation of a Haskell source. It is
8 -- /not/ concerned with preprocessing of source files; this is handled
9 -- in "DriverPipeline".
10 --
11 -- There are various entry points depending on what mode we're in:
12 -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
13 -- "interactive" mode (GHCi). There are also entry points for
14 -- individual passes: parsing, typechecking/renaming, desugaring, and
15 -- simplification.
16 --
17 -- All the functions here take an 'HscEnv' as a parameter, but none of
18 -- them return a new one: 'HscEnv' is treated as an immutable value
19 -- from here on in (although it has mutable components, for the
20 -- caches).
21 --
22 -- Warning messages are dealt with consistently throughout this API:
23 -- during compilation warnings are collected, and before any function
24 -- in @HscMain@ returns, the warnings are either printed, or turned
25 -- into a real compialtion error if the @-Werror@ flag is enabled.
26 --
27 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
28 --
29 -------------------------------------------------------------------------------
30
31 module HscMain
32 (
33 -- * Making an HscEnv
34 newHscEnv
35
36 -- * Compiling complete source files
37 , Messager, batchMsg
38 , HscStatus (..)
39 , hscCompileOneShot
40 , hscCompileCmmFile
41 , hscCompileCore
42
43 , genericHscCompileGetFrontendResult
44
45 , genModDetails
46 , hscSimpleIface
47 , hscWriteIface
48 , hscNormalIface
49 , hscGenHardCode
50 , hscInteractive
51
52 -- * Running passes separately
53 , hscParse
54 , hscTypecheckRename
55 , hscDesugar
56 , makeSimpleIface
57 , makeSimpleDetails
58 , hscSimplify -- ToDo, shouldn't really export this
59
60 -- * Support for interactive evaluation
61 , hscParseIdentifier
62 , hscTcRcLookupName
63 , hscTcRnGetInfo
64 , hscCheckSafe
65 , hscGetSafe
66 #ifdef GHCI
67 , hscIsGHCiMonad
68 , hscGetModuleInterface
69 , hscRnImportDecls
70 , hscTcRnLookupRdrName
71 , hscStmt, hscStmtWithLocation
72 , hscDecls, hscDeclsWithLocation
73 , hscTcExpr, hscImport, hscKcType
74 , hscCompileCoreExpr
75 -- * Low-level exports for hooks
76 , hscCompileCoreExpr'
77 #endif
78 -- We want to make sure that we export enough to be able to redefine
79 -- hscFileFrontEnd in client code
80 , hscParse', hscSimplify', hscDesugar', tcRnModule'
81 , getHscEnv
82 , hscSimpleIface', hscNormalIface'
83 , oneShotMsg
84 , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
85 ) where
86
87 #ifdef GHCI
88 import Id
89 import BasicTypes ( HValue )
90 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
91 import Linker
92 import CoreTidy ( tidyExpr )
93 import Type ( Type )
94 import PrelNames
95 import {- Kind parts of -} Type ( Kind )
96 import CoreMonad ( lintInteractiveExpr )
97 import DsMeta ( templateHaskellNames )
98 import VarEnv ( emptyTidyEnv )
99 import Panic
100
101 import GHC.Exts
102 #endif
103
104 import Module
105 import Packages
106 import RdrName
107 import HsSyn
108 import CoreSyn
109 import StringBuffer
110 import Parser
111 import Lexer
112 import SrcLoc
113 import TcRnDriver
114 import TcIface ( typecheckIface )
115 import TcRnMonad
116 import IfaceEnv ( initNameCache )
117 import LoadIface ( ifaceStats, initExternalPackageState )
118 import PrelInfo
119 import MkIface
120 import Desugar
121 import SimplCore
122 import TidyPgm
123 import CorePrep
124 import CoreToStg ( coreToStg )
125 import qualified StgCmm ( codeGen )
126 import StgSyn
127 import CostCentre
128 import ProfInit
129 import TyCon
130 import Name
131 import SimplStg ( stg2stg )
132 import Cmm
133 import CmmParse ( parseCmmFile )
134 import CmmBuildInfoTables
135 import CmmPipeline
136 import CmmInfo
137 import CodeOutput
138 import NameEnv ( emptyNameEnv )
139 import NameSet ( emptyNameSet )
140 import InstEnv
141 import FamInstEnv
142 import Fingerprint ( Fingerprint )
143 import Hooks
144
145 import DynFlags
146 import ErrUtils
147
148 import Outputable
149 import HscStats ( ppSourceStats )
150 import HscTypes
151 import FastString
152 import UniqFM ( emptyUFM )
153 import UniqSupply
154 import Bag
155 import Exception
156 import qualified Stream
157 import Stream (Stream)
158
159 import Util
160
161 import Data.List
162 import Control.Monad
163 import Data.Maybe
164 import Data.IORef
165 import System.FilePath as FilePath
166 import System.Directory
167
168 #include "HsVersions.h"
169
170
171 {- **********************************************************************
172 %* *
173 Initialisation
174 %* *
175 %********************************************************************* -}
176
177 newHscEnv :: DynFlags -> IO HscEnv
178 newHscEnv dflags = do
179 eps_var <- newIORef initExternalPackageState
180 us <- mkSplitUniqSupply 'r'
181 nc_var <- newIORef (initNameCache us knownKeyNames)
182 fc_var <- newIORef emptyUFM
183 mlc_var <- newIORef emptyModuleEnv
184 return HscEnv { hsc_dflags = dflags,
185 hsc_targets = [],
186 hsc_mod_graph = [],
187 hsc_IC = emptyInteractiveContext dflags,
188 hsc_HPT = emptyHomePackageTable,
189 hsc_EPS = eps_var,
190 hsc_NC = nc_var,
191 hsc_FC = fc_var,
192 hsc_MLC = mlc_var,
193 hsc_type_env_var = Nothing }
194
195
196 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
197 knownKeyNames = -- where templateHaskellNames are defined
198 map getName wiredInThings
199 ++ basicKnownKeyNames
200 #ifdef GHCI
201 ++ templateHaskellNames
202 #endif
203
204 -- -----------------------------------------------------------------------------
205
206 getWarnings :: Hsc WarningMessages
207 getWarnings = Hsc $ \_ w -> return (w, w)
208
209 clearWarnings :: Hsc ()
210 clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
211
212 logWarnings :: WarningMessages -> Hsc ()
213 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
214
215 getHscEnv :: Hsc HscEnv
216 getHscEnv = Hsc $ \e w -> return (e, w)
217
218 handleWarnings :: Hsc ()
219 handleWarnings = do
220 dflags <- getDynFlags
221 w <- getWarnings
222 liftIO $ printOrThrowWarnings dflags w
223 clearWarnings
224
225 -- | log warning in the monad, and if there are errors then
226 -- throw a SourceError exception.
227 logWarningsReportErrors :: Messages -> Hsc ()
228 logWarningsReportErrors (warns,errs) = do
229 logWarnings warns
230 when (not $ isEmptyBag errs) $ throwErrors errs
231
232 -- | Throw some errors.
233 throwErrors :: ErrorMessages -> Hsc a
234 throwErrors = liftIO . throwIO . mkSrcErr
235
236 -- | Deal with errors and warnings returned by a compilation step
237 --
238 -- In order to reduce dependencies to other parts of the compiler, functions
239 -- outside the "main" parts of GHC return warnings and errors as a parameter
240 -- and signal success via by wrapping the result in a 'Maybe' type. This
241 -- function logs the returned warnings and propagates errors as exceptions
242 -- (of type 'SourceError').
243 --
244 -- This function assumes the following invariants:
245 --
246 -- 1. If the second result indicates success (is of the form 'Just x'),
247 -- there must be no error messages in the first result.
248 --
249 -- 2. If there are no error messages, but the second result indicates failure
250 -- there should be warnings in the first result. That is, if the action
251 -- failed, it must have been due to the warnings (i.e., @-Werror@).
252 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
253 ioMsgMaybe ioA = do
254 ((warns,errs), mb_r) <- liftIO ioA
255 logWarnings warns
256 case mb_r of
257 Nothing -> throwErrors errs
258 Just r -> ASSERT( isEmptyBag errs ) return r
259
260 -- | like ioMsgMaybe, except that we ignore error messages and return
261 -- 'Nothing' instead.
262 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
263 ioMsgMaybe' ioA = do
264 ((warns,_errs), mb_r) <- liftIO $ ioA
265 logWarnings warns
266 return mb_r
267
268 -- -----------------------------------------------------------------------------
269 -- | Lookup things in the compiler's environment
270
271 #ifdef GHCI
272 hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
273 hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do
274 hsc_env <- getHscEnv
275 ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
276 #endif
277
278 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
279 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
280 hsc_env <- getHscEnv
281 ioMsgMaybe' $ tcRnLookupName hsc_env name
282 -- ignore errors: the only error we're likely to get is
283 -- "name not found", and the Maybe in the return type
284 -- is used to indicate that.
285
286 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst]))
287 hscTcRnGetInfo hsc_env0 name
288 = runInteractiveHsc hsc_env0 $
289 do { hsc_env <- getHscEnv
290 ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
291
292 #ifdef GHCI
293 hscIsGHCiMonad :: HscEnv -> String -> IO Name
294 hscIsGHCiMonad hsc_env name
295 = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
296
297 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
298 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
299 hsc_env <- getHscEnv
300 ioMsgMaybe $ getModuleInterface hsc_env mod
301
302 -- -----------------------------------------------------------------------------
303 -- | Rename some import declarations
304 hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv
305 hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
306 hsc_env <- getHscEnv
307 ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
308 #endif
309
310 -- -----------------------------------------------------------------------------
311 -- | parse a file, returning the abstract syntax
312
313 hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
314 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
315
316 -- internal version, that doesn't fail due to -Werror
317 hscParse' :: ModSummary -> Hsc HsParsedModule
318 hscParse' mod_summary = do
319 dflags <- getDynFlags
320 let src_filename = ms_hspp_file mod_summary
321 maybe_src_buf = ms_hspp_buf mod_summary
322
323 -------------------------- Parser ----------------
324 liftIO $ showPass dflags "Parser"
325 {-# SCC "Parser" #-} do
326
327 -- sometimes we already have the buffer in memory, perhaps
328 -- because we needed to parse the imports out of it, or get the
329 -- module name.
330 buf <- case maybe_src_buf of
331 Just b -> return b
332 Nothing -> liftIO $ hGetStringBuffer src_filename
333
334 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
335
336 case unP parseModule (mkPState dflags buf loc) of
337 PFailed span err ->
338 liftIO $ throwOneError (mkPlainErrMsg dflags span err)
339
340 POk pst rdr_module -> do
341 logWarningsReportErrors (getMessages pst)
342 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
343 ppr rdr_module
344 liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
345 ppSourceStats False rdr_module
346
347 -- To get the list of extra source files, we take the list
348 -- that the parser gave us,
349 -- - eliminate files beginning with '<'. gcc likes to use
350 -- pseudo-filenames like "<built-in>" and "<command-line>"
351 -- - normalise them (elimiante differences between ./f and f)
352 -- - filter out the preprocessed source file
353 -- - filter out anything beginning with tmpdir
354 -- - remove duplicates
355 -- - filter out the .hs/.lhs source filename if we have one
356 --
357 let n_hspp = FilePath.normalise src_filename
358 srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
359 $ filter (not . (== n_hspp))
360 $ map FilePath.normalise
361 $ filter (not . (isPrefixOf "<"))
362 $ map unpackFS
363 $ srcfiles pst
364 srcs1 = case ml_hs_file (ms_location mod_summary) of
365 Just f -> filter (/= FilePath.normalise f) srcs0
366 Nothing -> srcs0
367
368 -- sometimes we see source files from earlier
369 -- preprocessing stages that cannot be found, so just
370 -- filter them out:
371 srcs2 <- liftIO $ filterM doesFileExist srcs1
372
373 return HsParsedModule {
374 hpm_module = rdr_module,
375 hpm_src_files = srcs2
376 }
377
378 -- XXX: should this really be a Maybe X? Check under which circumstances this
379 -- can become a Nothing and decide whether this should instead throw an
380 -- exception/signal an error.
381 type RenamedStuff =
382 (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
383 Maybe LHsDocString))
384
385 -- | Rename and typecheck a module, additionally returning the renamed syntax
386 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
387 -> IO (TcGblEnv, RenamedStuff)
388 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
389 tc_result <- tcRnModule' hsc_env mod_summary True rdr_module
390
391 -- This 'do' is in the Maybe monad!
392 let rn_info = do decl <- tcg_rn_decls tc_result
393 let imports = tcg_rn_imports tc_result
394 exports = tcg_rn_exports tc_result
395 doc_hdr = tcg_doc_hdr tc_result
396 return (decl,imports,exports,doc_hdr)
397
398 return (tc_result, rn_info)
399
400 -- wrapper around tcRnModule to handle safe haskell extras
401 tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule
402 -> Hsc TcGblEnv
403 tcRnModule' hsc_env sum save_rn_syntax mod = do
404 tcg_res <- {-# SCC "Typecheck-Rename" #-}
405 ioMsgMaybe $
406 tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod
407
408 tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res)
409 dflags <- getDynFlags
410 let allSafeOK = safeInferred dflags && tcSafeOK
411
412 -- end of the safe haskell line, how to respond to user?
413 if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
414 -- if safe Haskell off or safe infer failed, mark unsafe
415 then markUnsafeInfer tcg_res emptyBag
416
417 -- module (could be) safe, throw warning if needed
418 else do
419 tcg_res' <- hscCheckSafeImports tcg_res
420 safe <- liftIO $ readIORef (tcg_safeInfer tcg_res')
421 when safe $ do
422 case wopt Opt_WarnSafe dflags of
423 True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags
424 (warnSafeOnLoc dflags) $ errSafe tcg_res')
425 False | safeHaskell dflags == Sf_Trustworthy &&
426 wopt Opt_WarnTrustworthySafe dflags ->
427 (logWarnings $ unitBag $ mkPlainWarnMsg dflags
428 (trustworthyOnLoc dflags) $ errTwthySafe tcg_res')
429 False -> return ()
430 return tcg_res'
431 where
432 pprMod t = ppr $ moduleName $ tcg_mod t
433 errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
434 errTwthySafe t = quotes (pprMod t)
435 <+> text "is marked as Trustworthy but has been inferred as safe!"
436
437 -- | Convert a typechecked module to Core
438 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
439 hscDesugar hsc_env mod_summary tc_result =
440 runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
441
442 hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
443 hscDesugar' mod_location tc_result = do
444 hsc_env <- getHscEnv
445 r <- ioMsgMaybe $
446 {-# SCC "deSugar" #-}
447 deSugar hsc_env mod_location tc_result
448
449 -- always check -Werror after desugaring, this is the last opportunity for
450 -- warnings to arise before the backend.
451 handleWarnings
452 return r
453
454 -- | Make a 'ModIface' from the results of typechecking. Used when
455 -- not optimising, and the interface doesn't need to contain any
456 -- unfoldings or other cross-module optimisation info.
457 -- ToDo: the old interface is only needed to get the version numbers,
458 -- we should use fingerprint versions instead.
459 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
460 -> IO (ModIface,Bool)
461 makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do
462 safe_mode <- hscGetSafeMode tc_result
463 ioMsgMaybe $ do
464 mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode
465 details tc_result
466
467 -- | Make a 'ModDetails' from the results of typechecking. Used when
468 -- typechecking only, as opposed to full compilation.
469 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
470 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
471
472
473 {- **********************************************************************
474 %* *
475 The main compiler pipeline
476 %* *
477 %********************************************************************* -}
478
479 {-
480 --------------------------------
481 The compilation proper
482 --------------------------------
483
484 It's the task of the compilation proper to compile Haskell, hs-boot and core
485 files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all
486 (the module is still parsed and type-checked. This feature is mostly used by
487 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
488 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
489 mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
490 targets byte-code.
491
492 The modes are kept separate because of their different types and meanings:
493
494 * In 'one-shot' mode, we're only compiling a single file and can therefore
495 discard the new ModIface and ModDetails. This is also the reason it only
496 targets hard-code; compiling to byte-code or nothing doesn't make sense when
497 we discard the result.
498
499 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
500 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
501 return the newly compiled byte-code.
502
503 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
504 kept separate. This is because compiling to nothing is fairly special: We
505 don't output any interface files, we don't run the simplifier and we don't
506 generate any code.
507
508 * 'Interactive' mode is similar to 'batch' mode except that we return the
509 compiled byte-code together with the ModIface and ModDetails.
510
511 Trying to compile a hs-boot file to byte-code will result in a run-time error.
512 This is the only thing that isn't caught by the type-system.
513 -}
514
515
516 type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
517
518 genericHscCompileGetFrontendResult ::
519 Bool -- always do basic recompilation check?
520 -> Maybe TcGblEnv
521 -> Maybe Messager
522 -> HscEnv
523 -> ModSummary
524 -> SourceModified
525 -> Maybe ModIface -- Old interface, if available
526 -> (Int,Int) -- (i,n) = module i of n (for msgs)
527 -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint))
528
529 genericHscCompileGetFrontendResult
530 always_do_basic_recompilation_check m_tc_result
531 mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index
532 = do
533
534 let msg what = case mHscMessage of
535 Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
536 Nothing -> return ()
537
538 skip iface = do
539 msg UpToDate
540 return $ Left iface
541
542 compile mb_old_hash reason = do
543 msg reason
544 tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary
545 return $ Right (tc_result, mb_old_hash)
546
547 stable = case source_modified of
548 SourceUnmodifiedAndStable -> True
549 _ -> False
550
551 case m_tc_result of
552 Just tc_result
553 | not always_do_basic_recompilation_check ->
554 return $ Right (tc_result, Nothing)
555 _ -> do
556 (recomp_reqd, mb_checked_iface)
557 <- {-# SCC "checkOldIface" #-}
558 checkOldIface hsc_env mod_summary
559 source_modified mb_old_iface
560 -- save the interface that comes back from checkOldIface.
561 -- In one-shot mode we don't have the old iface until this
562 -- point, when checkOldIface reads it from the disk.
563 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
564
565 case mb_checked_iface of
566 Just iface | not (recompileRequired recomp_reqd) ->
567 -- If the module used TH splices when it was last
568 -- compiled, then the recompilation check is not
569 -- accurate enough (#481) and we must ignore
570 -- it. However, if the module is stable (none of
571 -- the modules it depends on, directly or
572 -- indirectly, changed), then we *can* skip
573 -- recompilation. This is why the SourceModified
574 -- type contains SourceUnmodifiedAndStable, and
575 -- it's pretty important: otherwise ghc --make
576 -- would always recompile TH modules, even if
577 -- nothing at all has changed. Stability is just
578 -- the same check that make is doing for us in
579 -- one-shot mode.
580 case m_tc_result of
581 Nothing
582 | mi_used_th iface && not stable ->
583 compile mb_old_hash (RecompBecause "TH")
584 _ ->
585 skip iface
586 _ ->
587 case m_tc_result of
588 Nothing -> compile mb_old_hash recomp_reqd
589 Just tc_result ->
590 return $ Right (tc_result, mb_old_hash)
591
592 genericHscFrontend :: ModSummary -> Hsc TcGblEnv
593 genericHscFrontend mod_summary =
594 getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
595
596 genericHscFrontend' :: ModSummary -> Hsc TcGblEnv
597 genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary
598
599 --------------------------------------------------------------
600 -- Compilers
601 --------------------------------------------------------------
602
603 hscCompileOneShot :: HscEnv
604 -> ModSummary
605 -> SourceModified
606 -> IO HscStatus
607 hscCompileOneShot env =
608 lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env
609
610 -- Compile Haskell/boot in OneShot mode.
611 hscCompileOneShot' :: HscEnv
612 -> ModSummary
613 -> SourceModified
614 -> IO HscStatus
615 hscCompileOneShot' hsc_env mod_summary src_changed
616 = do
617 -- One-shot mode needs a knot-tying mutable variable for interface
618 -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
619 type_env_var <- newIORef emptyNameEnv
620 let mod = ms_mod mod_summary
621 hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
622
623 msg what = oneShotMsg hsc_env' what
624
625 skip = do msg UpToDate
626 dumpIfaceStats hsc_env'
627 return HscUpToDate
628
629 compile mb_old_hash reason = runHsc hsc_env' $ do
630 liftIO $ msg reason
631 tc_result <- genericHscFrontend mod_summary
632 guts0 <- hscDesugar' (ms_location mod_summary) tc_result
633 dflags <- getDynFlags
634 case hscTarget dflags of
635 HscNothing -> do
636 when (gopt Opt_WriteInterface dflags) $ liftIO $ do
637 (iface, changed, _details) <- hscSimpleIface hsc_env tc_result mb_old_hash
638 hscWriteIface dflags iface changed mod_summary
639 return HscNotGeneratingCode
640 _ ->
641 case ms_hsc_src mod_summary of
642 t | isHsBootOrSig t ->
643 do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash
644 liftIO $ hscWriteIface dflags iface changed mod_summary
645 return HscUpdateBoot
646 _ ->
647 do guts <- hscSimplify' guts0
648 (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
649 liftIO $ hscWriteIface dflags iface changed mod_summary
650 return $ HscRecomp cgguts mod_summary
651
652 -- XXX This is always False, because in one-shot mode the
653 -- concept of stability does not exist. The driver never
654 -- passes SourceUnmodifiedAndStable in here.
655 stable = case src_changed of
656 SourceUnmodifiedAndStable -> True
657 _ -> False
658
659 (recomp_reqd, mb_checked_iface)
660 <- {-# SCC "checkOldIface" #-}
661 checkOldIface hsc_env' mod_summary src_changed Nothing
662 -- save the interface that comes back from checkOldIface.
663 -- In one-shot mode we don't have the old iface until this
664 -- point, when checkOldIface reads it from the disk.
665 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
666
667 case mb_checked_iface of
668 Just iface | not (recompileRequired recomp_reqd) ->
669 -- If the module used TH splices when it was last compiled,
670 -- then the recompilation check is not accurate enough (#481)
671 -- and we must ignore it. However, if the module is stable
672 -- (none of the modules it depends on, directly or indirectly,
673 -- changed), then we *can* skip recompilation. This is why
674 -- the SourceModified type contains SourceUnmodifiedAndStable,
675 -- and it's pretty important: otherwise ghc --make would
676 -- always recompile TH modules, even if nothing at all has
677 -- changed. Stability is just the same check that make is
678 -- doing for us in one-shot mode.
679 if mi_used_th iface && not stable
680 then compile mb_old_hash (RecompBecause "TH")
681 else skip
682 _ ->
683 compile mb_old_hash recomp_reqd
684
685 --------------------------------------------------------------
686 -- NoRecomp handlers
687 --------------------------------------------------------------
688
689 genModDetails :: HscEnv -> ModIface -> IO ModDetails
690 genModDetails hsc_env old_iface
691 = do
692 new_details <- {-# SCC "tcRnIface" #-}
693 initIfaceCheck hsc_env (typecheckIface old_iface)
694 dumpIfaceStats hsc_env
695 return new_details
696
697 --------------------------------------------------------------
698 -- Progress displayers.
699 --------------------------------------------------------------
700
701 oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
702 oneShotMsg hsc_env recomp =
703 case recomp of
704 UpToDate ->
705 compilationProgressMsg (hsc_dflags hsc_env) $
706 "compilation IS NOT required"
707 _ ->
708 return ()
709
710 batchMsg :: Messager
711 batchMsg hsc_env mod_index recomp mod_summary =
712 case recomp of
713 MustCompile -> showMsg "Compiling " ""
714 UpToDate
715 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
716 | otherwise -> return ()
717 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
718 where
719 dflags = hsc_dflags hsc_env
720 showMsg msg reason =
721 compilationProgressMsg dflags $
722 (showModuleIndex mod_index ++
723 msg ++ showModMsg dflags (hscTarget dflags)
724 (recompileRequired recomp) mod_summary)
725 ++ reason
726
727 --------------------------------------------------------------
728 -- FrontEnds
729 --------------------------------------------------------------
730
731 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
732 hscFileFrontEnd mod_summary = do
733 hpm <- hscParse' mod_summary
734 hsc_env <- getHscEnv
735 tcg_env <- tcRnModule' hsc_env mod_summary False hpm
736 return tcg_env
737
738 --------------------------------------------------------------
739 -- Safe Haskell
740 --------------------------------------------------------------
741
742 -- Note [Safe Haskell Trust Check]
743 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
744 -- Safe Haskell checks that an import is trusted according to the following
745 -- rules for an import of module M that resides in Package P:
746 --
747 -- * If M is recorded as Safe and all its trust dependencies are OK
748 -- then M is considered safe.
749 -- * If M is recorded as Trustworthy and P is considered trusted and
750 -- all M's trust dependencies are OK then M is considered safe.
751 --
752 -- By trust dependencies we mean that the check is transitive. So if
753 -- a module M that is Safe relies on a module N that is trustworthy,
754 -- importing module M will first check (according to the second case)
755 -- that N is trusted before checking M is trusted.
756 --
757 -- This is a minimal description, so please refer to the user guide
758 -- for more details. The user guide is also considered the authoritative
759 -- source in this matter, not the comments or code.
760
761
762 -- Note [Safe Haskell Inference]
763 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
764 -- Safe Haskell does Safe inference on modules that don't have any specific
765 -- safe haskell mode flag. The basic aproach to this is:
766 -- * When deciding if we need to do a Safe language check, treat
767 -- an unmarked module as having -XSafe mode specified.
768 -- * For checks, don't throw errors but return them to the caller.
769 -- * Caller checks if there are errors:
770 -- * For modules explicitly marked -XSafe, we throw the errors.
771 -- * For unmarked modules (inference mode), we drop the errors
772 -- and mark the module as being Unsafe.
773 --
774 -- It used to be that we only did safe inference on modules that had no Safe
775 -- Haskell flags, but now we perform safe inference on all modules as we want
776 -- to allow users to set the `--fwarn-safe`, `--fwarn-unsafe` and
777 -- `--fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a
778 -- user can ensure their assumptions are correct and see reasons for why a
779 -- module is safe or unsafe.
780 --
781 -- This is tricky as we must be careful when we should throw an error compared
782 -- to just warnings. For checking safe imports we manage it as two steps. First
783 -- we check any imports that are required to be safe, then we check all other
784 -- imports to see if we can infer them to be safe.
785
786
787 -- | Check that the safe imports of the module being compiled are valid.
788 -- If not we either issue a compilation error if the module is explicitly
789 -- using Safe Haskell, or mark the module as unsafe if we're in safe
790 -- inference mode.
791 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
792 hscCheckSafeImports tcg_env = do
793 dflags <- getDynFlags
794 tcg_env' <- checkSafeImports dflags tcg_env
795 checkRULES dflags tcg_env'
796
797 where
798 checkRULES dflags tcg_env' = do
799 case safeLanguageOn dflags of
800 True -> do
801 -- XSafe: we nuke user written RULES
802 logWarnings $ warns dflags (tcg_rules tcg_env')
803 return tcg_env' { tcg_rules = [] }
804 False
805 -- SafeInferred: user defined RULES, so not safe
806 | safeInferOn dflags && not (null $ tcg_rules tcg_env')
807 -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
808
809 -- Trustworthy OR SafeInferred: with no RULES
810 | otherwise
811 -> return tcg_env'
812
813 warns dflags rules = listToBag $ map (warnRules dflags) rules
814 warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
815 mkPlainWarnMsg dflags loc $
816 text "Rule \"" <> ftext n <> text "\" ignored" $+$
817 text "User defined rules are disabled under Safe Haskell"
818
819 -- | Validate that safe imported modules are actually safe. For modules in the
820 -- HomePackage (the package the module we are compiling in resides) this just
821 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
822 -- that reside in another package we also must check that the external pacakge
823 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
824 -- information.
825 --
826 -- The code for this is quite tricky as the whole algorithm is done in a few
827 -- distinct phases in different parts of the code base. See
828 -- RnNames.rnImportDecl for where package trust dependencies for a module are
829 -- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
830 -- Transitively] and the Note [RnNames . Trust Own Package].
831 checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
832 checkSafeImports dflags tcg_env
833 = do
834 imps <- mapM condense imports'
835 let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
836
837 -- We want to use the warning state specifically for detecting if safe
838 -- inference has failed, so store and clear any existing warnings.
839 oldErrs <- getWarnings
840 clearWarnings
841
842 -- Check safe imports are correct
843 safePkgs <- mapM checkSafe safeImps
844 safeErrs <- getWarnings
845 clearWarnings
846
847 -- Check non-safe imports are correct if inferring safety
848 -- See the Note [Safe Haskell Inference]
849 (infErrs, infPkgs) <- case (safeInferOn dflags) of
850 False -> return (emptyBag, [])
851 True -> do infPkgs <- mapM checkSafe regImps
852 infErrs <- getWarnings
853 clearWarnings
854 return (infErrs, infPkgs)
855
856 -- restore old errors
857 logWarnings oldErrs
858
859 case (isEmptyBag safeErrs) of
860 -- Failed safe check
861 False -> liftIO . throwIO . mkSrcErr $ safeErrs
862
863 -- Passed safe check
864 True -> do
865 let infPassed = isEmptyBag infErrs
866 tcg_env' <- case (not infPassed) of
867 True -> markUnsafeInfer tcg_env infErrs
868 False -> return tcg_env
869 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs
870 let newTrust = pkgTrustReqs safePkgs infPkgs infPassed
871 return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
872
873 where
874 impInfo = tcg_imports tcg_env -- ImportAvails
875 imports = imp_mods impInfo -- ImportedMods
876 imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
877 pkgReqs = imp_trust_pkgs impInfo -- [PackageKey]
878
879 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
880 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
881 condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
882 return (m, l, s)
883
884 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
885 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
886 cond' v1@(m1,_,l1,s1) (_,_,_,s2)
887 | s1 /= s2
888 = throwErrors $ unitBag $ mkPlainErrMsg dflags l1
889 (text "Module" <+> ppr m1 <+>
890 (text $ "is imported both as a safe and unsafe import!"))
891 | otherwise
892 = return v1
893
894 -- easier interface to work with
895 checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
896
897 -- what pkg's to add to our trust requirements
898 pkgTrustReqs req inf infPassed | safeInferOn dflags
899 && safeHaskell dflags == Sf_None && infPassed
900 = emptyImportAvails {
901 imp_trust_pkgs = catMaybes req ++ catMaybes inf
902 }
903 pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe
904 = emptyImportAvails
905 pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req }
906
907 -- | Check that a module is safe to import.
908 --
909 -- We return True to indicate the import is safe and False otherwise
910 -- although in the False case an exception may be thrown first.
911 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
912 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
913 dflags <- getDynFlags
914 pkgs <- snd `fmap` hscCheckSafe' dflags m l
915 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
916 errs <- getWarnings
917 return $ isEmptyBag errs
918
919 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
920 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageKey])
921 hscGetSafe hsc_env m l = runHsc hsc_env $ do
922 dflags <- getDynFlags
923 (self, pkgs) <- hscCheckSafe' dflags m l
924 good <- isEmptyBag `fmap` getWarnings
925 clearWarnings -- don't want them printed...
926 let pkgs' | Just p <- self = p:pkgs
927 | otherwise = pkgs
928 return (good, pkgs')
929
930 -- | Is a module trusted? If not, throw or log errors depending on the type.
931 -- Return (regardless of trusted or not) if the trust type requires the modules
932 -- own package be trusted and a list of other packages required to be trusted
933 -- (these later ones haven't been checked) but the own package trust has been.
934 hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageKey, [PackageKey])
935 hscCheckSafe' dflags m l = do
936 (tw, pkgs) <- isModSafe m l
937 case tw of
938 False -> return (Nothing, pkgs)
939 True | isHomePkg m -> return (Nothing, pkgs)
940 | otherwise -> return (Just $ modulePackageKey m, pkgs)
941 where
942 isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey])
943 isModSafe m l = do
944 iface <- lookup' m
945 case iface of
946 -- can't load iface to check trust!
947 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
948 $ text "Can't load the interface file for" <+> ppr m
949 <> text ", to check that it can be safely imported"
950
951 -- got iface, check trust
952 Just iface' ->
953 let trust = getSafeMode $ mi_trust iface'
954 trust_own_pkg = mi_trust_pkg iface'
955 -- check module is trusted
956 safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
957 -- check package is trusted
958 safeP = packageTrusted trust trust_own_pkg m
959 -- pkg trust reqs
960 pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
961 -- General errors we throw but Safe errors we log
962 errs = case (safeM, safeP) of
963 (True, True ) -> emptyBag
964 (True, False) -> pkgTrustErr
965 (False, _ ) -> modTrustErr
966 in do
967 logWarnings errs
968 return (trust == Sf_Trustworthy, pkgRs)
969
970 where
971 pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
972 sep [ ppr (moduleName m)
973 <> text ": Can't be safely imported!"
974 , text "The package (" <> ppr (modulePackageKey m)
975 <> text ") the module resides in isn't trusted."
976 ]
977 modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
978 sep [ ppr (moduleName m)
979 <> text ": Can't be safely imported!"
980 , text "The module itself isn't safe." ]
981
982 -- | Check the package a module resides in is trusted. Safe compiled
983 -- modules are trusted without requiring that their package is trusted. For
984 -- trustworthy modules, modules in the home package are trusted but
985 -- otherwise we check the package trust flag.
986 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
987 packageTrusted Sf_None _ _ = False -- shouldn't hit these cases
988 packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness.
989 packageTrusted _ _ _
990 | not (packageTrustOn dflags) = True
991 packageTrusted Sf_Safe False _ = True
992 packageTrusted _ _ m
993 | isHomePkg m = True
994 | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m)
995
996 lookup' :: Module -> Hsc (Maybe ModIface)
997 lookup' m = do
998 hsc_env <- getHscEnv
999 hsc_eps <- liftIO $ hscEPS hsc_env
1000 let pkgIfaceT = eps_PIT hsc_eps
1001 homePkgT = hsc_HPT hsc_env
1002 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
1003 #ifdef GHCI
1004 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
1005 -- as the compiler hasn't filled in the various module tables
1006 -- so we need to call 'getModuleInterface' to load from disk
1007 iface' <- case iface of
1008 Just _ -> return iface
1009 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
1010 return iface'
1011 #else
1012 return iface
1013 #endif
1014
1015
1016 isHomePkg :: Module -> Bool
1017 isHomePkg m
1018 | thisPackage dflags == modulePackageKey m = True
1019 | otherwise = False
1020
1021 -- | Check the list of packages are trusted.
1022 checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc ()
1023 checkPkgTrust dflags pkgs =
1024 case errors of
1025 [] -> return ()
1026 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1027 where
1028 errors = catMaybes $ map go pkgs
1029 go pkg
1030 | trusted $ getPackageDetails dflags pkg
1031 = Nothing
1032 | otherwise
1033 = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
1034 $ text "The package (" <> ppr pkg <> text ") is required" <>
1035 text " to be trusted but it isn't!"
1036
1037 -- | Set module to unsafe and (potentially) wipe trust information.
1038 --
1039 -- Make sure to call this method to set a module to inferred unsafe, it should
1040 -- be a central and single failure method. We only wipe the trust information
1041 -- when we aren't in a specific Safe Haskell mode.
1042 --
1043 -- While we only use this for recording that a module was inferred unsafe, we
1044 -- may call it on modules using Trustworthy or Unsafe flags so as to allow
1045 -- warning flags for safety to function correctly. See Note [Safe Haskell
1046 -- Inference].
1047 markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1048 markUnsafeInfer tcg_env whyUnsafe = do
1049 dflags <- getDynFlags
1050
1051 when (wopt Opt_WarnUnsafe dflags)
1052 (logWarnings $ unitBag $
1053 mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
1054
1055 liftIO $ writeIORef (tcg_safeInfer tcg_env) False
1056 -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other
1057 -- times inference may be on but we are in Trustworthy mode -- so we want
1058 -- to record safe-inference failed but not wipe the trust dependencies.
1059 case safeHaskell dflags == Sf_None of
1060 True -> return $ tcg_env { tcg_imports = wiped_trust }
1061 False -> return tcg_env
1062
1063 where
1064 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
1065 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1066 whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
1067 , text "Reason:"
1068 , nest 4 $ (vcat $ badFlags df) $+$
1069 (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
1070 (vcat $ badInsts $ tcg_insts tcg_env)
1071 ]
1072 badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer
1073 badFlag df (str,loc,on,_)
1074 | on df = [mkLocMessage SevOutput (loc df) $
1075 text str <+> text "is not allowed in Safe Haskell"]
1076 | otherwise = []
1077 badInsts insts = concat $ map badInst insts
1078 badInst ins | overlapMode (is_flag ins) /= NoOverlap
1079 = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
1080 ppr (overlapMode $ is_flag ins) <+>
1081 text "overlap mode isn't allowed in Safe Haskell"]
1082 | otherwise = []
1083
1084
1085 -- | Figure out the final correct safe haskell mode
1086 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
1087 hscGetSafeMode tcg_env = do
1088 dflags <- getDynFlags
1089 liftIO $ finalSafeMode dflags tcg_env
1090
1091 --------------------------------------------------------------
1092 -- Simplifiers
1093 --------------------------------------------------------------
1094
1095 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1096 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1097
1098 hscSimplify' :: ModGuts -> Hsc ModGuts
1099 hscSimplify' ds_result = do
1100 hsc_env <- getHscEnv
1101 {-# SCC "Core2Core" #-}
1102 liftIO $ core2core hsc_env ds_result
1103
1104 --------------------------------------------------------------
1105 -- Interface generators
1106 --------------------------------------------------------------
1107
1108 hscSimpleIface :: HscEnv
1109 -> TcGblEnv
1110 -> Maybe Fingerprint
1111 -> IO (ModIface, Bool, ModDetails)
1112 hscSimpleIface hsc_env tc_result mb_old_iface
1113 = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
1114
1115 hscSimpleIface' :: TcGblEnv
1116 -> Maybe Fingerprint
1117 -> Hsc (ModIface, Bool, ModDetails)
1118 hscSimpleIface' tc_result mb_old_iface = do
1119 hsc_env <- getHscEnv
1120 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1121 safe_mode <- hscGetSafeMode tc_result
1122 (new_iface, no_change)
1123 <- {-# SCC "MkFinalIface" #-}
1124 ioMsgMaybe $
1125 mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
1126 -- And the answer is ...
1127 liftIO $ dumpIfaceStats hsc_env
1128 return (new_iface, no_change, details)
1129
1130 hscNormalIface :: HscEnv
1131 -> ModGuts
1132 -> Maybe Fingerprint
1133 -> IO (ModIface, Bool, ModDetails, CgGuts)
1134 hscNormalIface hsc_env simpl_result mb_old_iface =
1135 runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
1136
1137 hscNormalIface' :: ModGuts
1138 -> Maybe Fingerprint
1139 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1140 hscNormalIface' simpl_result mb_old_iface = do
1141 hsc_env <- getHscEnv
1142 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1143 liftIO $ tidyProgram hsc_env simpl_result
1144
1145 -- BUILD THE NEW ModIface and ModDetails
1146 -- and emit external core if necessary
1147 -- This has to happen *after* code gen so that the back-end
1148 -- info has been set. Not yet clear if it matters waiting
1149 -- until after code output
1150 (new_iface, no_change)
1151 <- {-# SCC "MkFinalIface" #-}
1152 ioMsgMaybe $
1153 mkIface hsc_env mb_old_iface details simpl_result
1154
1155 liftIO $ dumpIfaceStats hsc_env
1156
1157 -- Return the prepared code.
1158 return (new_iface, no_change, details, cg_guts)
1159
1160 --------------------------------------------------------------
1161 -- BackEnd combinators
1162 --------------------------------------------------------------
1163
1164 hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
1165 hscWriteIface dflags iface no_change mod_summary = do
1166 let ifaceFile = ml_hi_file (ms_location mod_summary)
1167 unless no_change $
1168 {-# SCC "writeIface" #-}
1169 writeIfaceFile dflags ifaceFile iface
1170 whenGeneratingDynamicToo dflags $ do
1171 -- TODO: We should do a no_change check for the dynamic
1172 -- interface file too
1173 -- TODO: Should handle the dynamic hi filename properly
1174 let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
1175 dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
1176 dynDflags = dynamicTooMkDynamicDynFlags dflags
1177 writeIfaceFile dynDflags dynIfaceFile' iface
1178
1179 -- | Compile to hard-code.
1180 hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
1181 -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1182 hscGenHardCode hsc_env cgguts mod_summary output_filename = do
1183 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1184 -- From now on, we just use the bits we need.
1185 cg_module = this_mod,
1186 cg_binds = core_binds,
1187 cg_tycons = tycons,
1188 cg_foreign = foreign_stubs0,
1189 cg_dep_pkgs = dependencies,
1190 cg_hpc_info = hpc_info } = cgguts
1191 dflags = hsc_dflags hsc_env
1192 location = ms_location mod_summary
1193 data_tycons = filter isDataTyCon tycons
1194 -- cg_tycons includes newtypes, for the benefit of External Core,
1195 -- but we don't generate any code for newtypes
1196
1197 -------------------
1198 -- PREPARE FOR CODE GENERATION
1199 -- Do saturation and convert to A-normal form
1200 prepd_binds <- {-# SCC "CorePrep" #-}
1201 corePrepPgm dflags hsc_env core_binds data_tycons ;
1202 ----------------- Convert to STG ------------------
1203 (stg_binds, cost_centre_info)
1204 <- {-# SCC "CoreToStg" #-}
1205 myCoreToStg dflags this_mod prepd_binds
1206
1207 let prof_init = profilingInitCode this_mod cost_centre_info
1208 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1209
1210 ------------------ Code generation ------------------
1211
1212 -- The back-end is streamed: each top-level function goes
1213 -- from Stg all the way to asm before dealing with the next
1214 -- top-level function, so showPass isn't very useful here.
1215 -- Hence we have one showPass for the whole backend, the
1216 -- next showPass after this will be "Assembler".
1217 showPass dflags "CodeGen"
1218
1219 cmms <- {-# SCC "StgCmm" #-}
1220 doCodeGen hsc_env this_mod data_tycons
1221 cost_centre_info
1222 stg_binds hpc_info
1223
1224 ------------------ Code output -----------------------
1225 rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
1226 cmmToRawCmm dflags cmms
1227
1228 let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
1229 (ppr a)
1230 return a
1231 rawcmms1 = Stream.mapM dump rawcmms0
1232
1233 (output_filename, (_stub_h_exists, stub_c_exists))
1234 <- {-# SCC "codeOutput" #-}
1235 codeOutput dflags this_mod output_filename location
1236 foreign_stubs dependencies rawcmms1
1237 return (output_filename, stub_c_exists)
1238
1239
1240 hscInteractive :: HscEnv
1241 -> CgGuts
1242 -> ModSummary
1243 -> IO (Maybe FilePath, CompiledByteCode, ModBreaks)
1244 #ifdef GHCI
1245 hscInteractive hsc_env cgguts mod_summary = do
1246 let dflags = hsc_dflags hsc_env
1247 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1248 -- From now on, we just use the bits we need.
1249 cg_module = this_mod,
1250 cg_binds = core_binds,
1251 cg_tycons = tycons,
1252 cg_foreign = foreign_stubs,
1253 cg_modBreaks = mod_breaks } = cgguts
1254
1255 location = ms_location mod_summary
1256 data_tycons = filter isDataTyCon tycons
1257 -- cg_tycons includes newtypes, for the benefit of External Core,
1258 -- but we don't generate any code for newtypes
1259
1260 -------------------
1261 -- PREPARE FOR CODE GENERATION
1262 -- Do saturation and convert to A-normal form
1263 prepd_binds <- {-# SCC "CorePrep" #-}
1264 corePrepPgm dflags hsc_env core_binds data_tycons
1265 ----------------- Generate byte code ------------------
1266 comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
1267 ------------------ Create f-x-dynamic C-side stuff ---
1268 (_istub_h_exists, istub_c_exists)
1269 <- outputForeignStubs dflags this_mod location foreign_stubs
1270 return (istub_c_exists, comp_bc, mod_breaks)
1271 #else
1272 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1273 #endif
1274
1275 ------------------------------
1276
1277 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
1278 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
1279 let dflags = hsc_dflags hsc_env
1280 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1281 liftIO $ do
1282 us <- mkSplitUniqSupply 'S'
1283 let initTopSRT = initUs_ us emptySRT
1284 dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm)
1285 (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
1286 rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
1287 _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms
1288 return ()
1289 where
1290 no_mod = panic "hscCmmFile: no_mod"
1291 no_loc = ModLocation{ ml_hs_file = Just filename,
1292 ml_hi_file = panic "hscCmmFile: no hi file",
1293 ml_obj_file = panic "hscCmmFile: no obj file" }
1294
1295 -------------------- Stuff for new code gen ---------------------
1296
1297 doCodeGen :: HscEnv -> Module -> [TyCon]
1298 -> CollectedCCs
1299 -> [StgBinding]
1300 -> HpcInfo
1301 -> IO (Stream IO CmmGroup ())
1302 -- Note we produce a 'Stream' of CmmGroups, so that the
1303 -- backend can be run incrementally. Otherwise it generates all
1304 -- the C-- up front, which has a significant space cost.
1305 doCodeGen hsc_env this_mod data_tycons
1306 cost_centre_info stg_binds hpc_info = do
1307 let dflags = hsc_dflags hsc_env
1308
1309 let cmm_stream :: Stream IO CmmGroup ()
1310 cmm_stream = {-# SCC "StgCmm" #-}
1311 StgCmm.codeGen dflags this_mod data_tycons
1312 cost_centre_info stg_binds hpc_info
1313
1314 -- codegen consumes a stream of CmmGroup, and produces a new
1315 -- stream of CmmGroup (not necessarily synchronised: one
1316 -- CmmGroup on input may produce many CmmGroups on output due
1317 -- to proc-point splitting).
1318
1319 let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
1320 "Cmm produced by new codegen" (ppr a)
1321 return a
1322
1323 ppr_stream1 = Stream.mapM dump1 cmm_stream
1324
1325 -- We are building a single SRT for the entire module, so
1326 -- we must thread it through all the procedures as we cps-convert them.
1327 us <- mkSplitUniqSupply 'S'
1328
1329 -- When splitting, we generate one SRT per split chunk, otherwise
1330 -- we generate one SRT for the whole module.
1331 let
1332 pipeline_stream
1333 | gopt Opt_SplitObjs dflags
1334 = {-# SCC "cmmPipeline" #-}
1335 let run_pipeline us cmmgroup = do
1336 let (topSRT', us') = initUs us emptySRT
1337 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
1338 let srt | isEmptySRT topSRT = []
1339 | otherwise = srtToData topSRT
1340 return (us', srt ++ cmmgroup)
1341
1342 in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
1343 return ()
1344
1345 | otherwise
1346 = {-# SCC "cmmPipeline" #-}
1347 let initTopSRT = initUs_ us emptySRT
1348 run_pipeline = cmmPipeline hsc_env
1349 in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
1350 Stream.yield (srtToData topSRT)
1351
1352 let
1353 dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a
1354 return a
1355
1356 ppr_stream2 = Stream.mapM dump2 pipeline_stream
1357
1358 return ppr_stream2
1359
1360
1361
1362 myCoreToStg :: DynFlags -> Module -> CoreProgram
1363 -> IO ( [StgBinding] -- output program
1364 , CollectedCCs) -- cost centre info (declared and used)
1365 myCoreToStg dflags this_mod prepd_binds = do
1366 stg_binds
1367 <- {-# SCC "Core2Stg" #-}
1368 coreToStg dflags this_mod prepd_binds
1369
1370 (stg_binds2, cost_centre_info)
1371 <- {-# SCC "Stg2Stg" #-}
1372 stg2stg dflags this_mod stg_binds
1373
1374 return (stg_binds2, cost_centre_info)
1375
1376
1377 {- **********************************************************************
1378 %* *
1379 \subsection{Compiling a do-statement}
1380 %* *
1381 %********************************************************************* -}
1382
1383 {-
1384 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1385 you run it you get a list of HValues that should be the same length as the list
1386 of names; add them to the ClosureEnv.
1387
1388 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1389 IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
1390 -}
1391
1392 #ifdef GHCI
1393 -- | Compile a stmt all the way to an HValue, but don't run it
1394 --
1395 -- We return Nothing to indicate an empty statement (or comment only), not a
1396 -- parse error.
1397 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1398 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1399
1400 -- | Compile a stmt all the way to an HValue, but don't run it
1401 --
1402 -- We return Nothing to indicate an empty statement (or comment only), not a
1403 -- parse error.
1404 hscStmtWithLocation :: HscEnv
1405 -> String -- ^ The statement
1406 -> String -- ^ The source
1407 -> Int -- ^ Starting line
1408 -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1409 hscStmtWithLocation hsc_env0 stmt source linenumber =
1410 runInteractiveHsc hsc_env0 $ do
1411 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1412 case maybe_stmt of
1413 Nothing -> return Nothing
1414
1415 Just parsed_stmt -> do
1416 -- Rename and typecheck it
1417 hsc_env <- getHscEnv
1418 (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt
1419
1420 -- Desugar it
1421 ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
1422 liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
1423 handleWarnings
1424
1425 -- Then code-gen, and link it
1426 -- It's important NOT to have package 'interactive' as thisPackageKey
1427 -- for linking, else we try to link 'main' and can't find it.
1428 -- Whereas the linker already knows to ignore 'interactive'
1429 let src_span = srcLocSpan interactiveSrcLoc
1430 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1431 let hval_io = unsafeCoerce# hval :: IO [HValue]
1432
1433 return $ Just (ids, hval_io, fix_env)
1434
1435 -- | Compile a decls
1436 hscDecls :: HscEnv
1437 -> String -- ^ The statement
1438 -> IO ([TyThing], InteractiveContext)
1439 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1440
1441 -- | Compile a decls
1442 hscDeclsWithLocation :: HscEnv
1443 -> String -- ^ The statement
1444 -> String -- ^ The source
1445 -> Int -- ^ Starting line
1446 -> IO ([TyThing], InteractiveContext)
1447 hscDeclsWithLocation hsc_env0 str source linenumber =
1448 runInteractiveHsc hsc_env0 $ do
1449 L _ (HsModule{ hsmodDecls = decls }) <-
1450 hscParseThingWithLocation source linenumber parseModule str
1451
1452 {- Rename and typecheck it -}
1453 hsc_env <- getHscEnv
1454 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
1455
1456 {- Grab the new instances -}
1457 -- We grab the whole environment because of the overlapping that may have
1458 -- been done. See the notes at the definition of InteractiveContext
1459 -- (ic_instances) for more details.
1460 let finsts = tcg_fam_insts tc_gblenv
1461 insts = tcg_insts tc_gblenv
1462
1463 let defaults = tcg_default tc_gblenv
1464
1465 {- Desugar it -}
1466 -- We use a basically null location for iNTERACTIVE
1467 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1468 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1469 ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
1470 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1471
1472 {- Simplify -}
1473 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1474
1475 {- Tidy -}
1476 (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1477
1478 let dflags = hsc_dflags hsc_env
1479 !CgGuts{ cg_module = this_mod,
1480 cg_binds = core_binds,
1481 cg_tycons = tycons,
1482 cg_modBreaks = mod_breaks } = tidy_cg
1483 data_tycons = filter isDataTyCon tycons
1484
1485 {- Prepare For Code Generation -}
1486 -- Do saturation and convert to A-normal form
1487 prepd_binds <- {-# SCC "CorePrep" #-}
1488 liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons
1489
1490 {- Generate byte code -}
1491 cbc <- liftIO $ byteCodeGen dflags this_mod
1492 prepd_binds data_tycons mod_breaks
1493
1494 let src_span = srcLocSpan interactiveSrcLoc
1495 liftIO $ linkDecls hsc_env src_span cbc
1496
1497 let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
1498
1499 ext_ids = [ id | id <- bindersOfBinds core_binds
1500 , isExternalName (idName id)
1501 , not (isDFunId id || isImplicitId id) ]
1502 -- We only need to keep around the external bindings
1503 -- (as decided by TidyPgm), since those are the only ones
1504 -- that might be referenced elsewhere.
1505 -- The DFunIds are in 'insts' (see Note [ic_tythings] in HscTypes
1506 -- Implicit Ids are implicit in tcs
1507
1508 tythings = map AnId ext_ids ++ map ATyCon tcs
1509
1510 let icontext = hsc_IC hsc_env
1511 ictxt1 = extendInteractiveContext icontext tythings
1512 ictxt = ictxt1 { ic_instances = (insts, finsts)
1513 , ic_default = defaults }
1514
1515 return (tythings, ictxt)
1516
1517 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1518 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1519 (L _ (HsModule{hsmodImports=is})) <-
1520 hscParseThing parseModule str
1521 case is of
1522 [i] -> return (unLoc i)
1523 _ -> liftIO $ throwOneError $
1524 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
1525 ptext (sLit "parse error in import declaration")
1526
1527 -- | Typecheck an expression (but don't run it)
1528 -- Returns its most general type
1529 hscTcExpr :: HscEnv
1530 -> String -- ^ The expression
1531 -> IO Type
1532 hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
1533 hsc_env <- getHscEnv
1534 maybe_stmt <- hscParseStmt expr
1535 case maybe_stmt of
1536 Just (L _ (BodyStmt expr _ _ _)) ->
1537 ioMsgMaybe $ tcRnExpr hsc_env expr
1538 _ ->
1539 throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
1540 (text "not an expression:" <+> quotes (text expr))
1541
1542 -- | Find the kind of a type
1543 -- Currently this does *not* generalise the kinds of the type
1544 hscKcType
1545 :: HscEnv
1546 -> Bool -- ^ Normalise the type
1547 -> String -- ^ The type as a string
1548 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1549 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1550 hsc_env <- getHscEnv
1551 ty <- hscParseType str
1552 ioMsgMaybe $ tcRnType hsc_env normalise ty
1553
1554 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
1555 hscParseStmt = hscParseThing parseStmt
1556
1557 hscParseStmtWithLocation :: String -> Int -> String
1558 -> Hsc (Maybe (GhciLStmt RdrName))
1559 hscParseStmtWithLocation source linenumber stmt =
1560 hscParseThingWithLocation source linenumber parseStmt stmt
1561
1562 hscParseType :: String -> Hsc (LHsType RdrName)
1563 hscParseType = hscParseThing parseType
1564 #endif
1565
1566 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1567 hscParseIdentifier hsc_env str =
1568 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1569
1570 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1571 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1572
1573 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1574 -> Lexer.P thing -> String -> Hsc thing
1575 hscParseThingWithLocation source linenumber parser str
1576 = {-# SCC "Parser" #-} do
1577 dflags <- getDynFlags
1578 liftIO $ showPass dflags "Parser"
1579
1580 let buf = stringToStringBuffer str
1581 loc = mkRealSrcLoc (fsLit source) linenumber 1
1582
1583 case unP parser (mkPState dflags buf loc) of
1584 PFailed span err -> do
1585 let msg = mkPlainErrMsg dflags span err
1586 throwErrors $ unitBag msg
1587
1588 POk pst thing -> do
1589 logWarningsReportErrors (getMessages pst)
1590 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1591 return thing
1592
1593 hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
1594 -> CoreProgram -> FilePath -> IO ()
1595 hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename
1596 = runHsc hsc_env $ do
1597 guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
1598 (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing
1599 liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary
1600 _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename
1601 return ()
1602
1603 where
1604 maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1605 | otherwise = return mod_guts
1606
1607 -- Makes a "vanilla" ModGuts.
1608 mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts
1609 mkModGuts mod safe binds =
1610 ModGuts {
1611 mg_module = mod,
1612 mg_boot = False,
1613 mg_exports = [],
1614 mg_deps = noDependencies,
1615 mg_dir_imps = emptyModuleEnv,
1616 mg_used_names = emptyNameSet,
1617 mg_used_th = False,
1618 mg_rdr_env = emptyGlobalRdrEnv,
1619 mg_fix_env = emptyFixityEnv,
1620 mg_tcs = [],
1621 mg_insts = [],
1622 mg_fam_insts = [],
1623 mg_patsyns = [],
1624 mg_rules = [],
1625 mg_vect_decls = [],
1626 mg_binds = binds,
1627 mg_foreign = NoStubs,
1628 mg_warns = NoWarnings,
1629 mg_anns = [],
1630 mg_hpc_info = emptyHpcInfo False,
1631 mg_modBreaks = emptyModBreaks,
1632 mg_vect_info = noVectInfo,
1633 mg_inst_env = emptyInstEnv,
1634 mg_fam_inst_env = emptyFamInstEnv,
1635 mg_safe_haskell = safe,
1636 mg_trust_pkg = False,
1637 mg_dependent_files = []
1638 }
1639
1640
1641 {- **********************************************************************
1642 %* *
1643 Desugar, simplify, convert to bytecode, and link an expression
1644 %* *
1645 %********************************************************************* -}
1646
1647 #ifdef GHCI
1648 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1649 hscCompileCoreExpr hsc_env =
1650 lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
1651
1652 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1653 hscCompileCoreExpr' hsc_env srcspan ds_expr
1654 | rtsIsProfiled
1655 = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1656 -- Otherwise you get a seg-fault when you run it
1657
1658 | otherwise
1659 = do { let dflags = hsc_dflags hsc_env
1660
1661 {- Simplify it -}
1662 ; simpl_expr <- simplifyExpr dflags ds_expr
1663
1664 {- Tidy it (temporary, until coreSat does cloning) -}
1665 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1666
1667 {- Prepare for codegen -}
1668 ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
1669
1670 {- Lint if necessary -}
1671 ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
1672
1673 {- Convert to BCOs -}
1674 ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
1675
1676 {- link it -}
1677 ; hval <- linkExpr hsc_env srcspan bcos
1678
1679 ; return hval }
1680 #endif
1681
1682
1683 {- **********************************************************************
1684 %* *
1685 Statistics on reading interfaces
1686 %* *
1687 %********************************************************************* -}
1688
1689 dumpIfaceStats :: HscEnv -> IO ()
1690 dumpIfaceStats hsc_env = do
1691 eps <- readIORef (hsc_EPS hsc_env)
1692 dumpIfSet dflags (dump_if_trace || dump_rn_stats)
1693 "Interface statistics"
1694 (ifaceStats eps)
1695 where
1696 dflags = hsc_dflags hsc_env
1697 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1698 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1699
1700
1701 {- **********************************************************************
1702 %* *
1703 Progress Messages: Module i of n
1704 %* *
1705 %********************************************************************* -}
1706
1707 showModuleIndex :: (Int, Int) -> String
1708 showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1709 where
1710 n_str = show n
1711 i_str = show i
1712 padded = replicate (length n_str - length i_str) ' ' ++ i_str