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