Refactor tuple constraints
[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 CoreLint ( lintInteractiveExpr )
97 import VarEnv ( emptyTidyEnv )
98 import Panic
99 import ConLike
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 UniqSupply
153 import Bag
154 import Exception
155 import qualified Stream
156 import Stream (Stream)
157
158 import Util
159
160 import Data.List
161 import Control.Monad
162 import Data.Maybe
163 import Data.IORef
164 import System.FilePath as FilePath
165 import System.Directory
166 import qualified Data.Map as Map
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 emptyModuleEnv
183 return HscEnv { hsc_dflags = dflags,
184 hsc_targets = [],
185 hsc_mod_graph = [],
186 hsc_IC = emptyInteractiveContext dflags,
187 hsc_HPT = emptyHomePackageTable,
188 hsc_EPS = eps_var,
189 hsc_NC = nc_var,
190 hsc_FC = fc_var,
191 hsc_type_env_var = Nothing }
192
193
194 -- -----------------------------------------------------------------------------
195
196 getWarnings :: Hsc WarningMessages
197 getWarnings = Hsc $ \_ w -> return (w, w)
198
199 clearWarnings :: Hsc ()
200 clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
201
202 logWarnings :: WarningMessages -> Hsc ()
203 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
204
205 getHscEnv :: Hsc HscEnv
206 getHscEnv = Hsc $ \e w -> return (e, w)
207
208 handleWarnings :: Hsc ()
209 handleWarnings = do
210 dflags <- getDynFlags
211 w <- getWarnings
212 liftIO $ printOrThrowWarnings dflags w
213 clearWarnings
214
215 -- | log warning in the monad, and if there are errors then
216 -- throw a SourceError exception.
217 logWarningsReportErrors :: Messages -> Hsc ()
218 logWarningsReportErrors (warns,errs) = do
219 logWarnings warns
220 when (not $ isEmptyBag errs) $ throwErrors errs
221
222 -- | Throw some errors.
223 throwErrors :: ErrorMessages -> Hsc a
224 throwErrors = liftIO . throwIO . mkSrcErr
225
226 -- | Deal with errors and warnings returned by a compilation step
227 --
228 -- In order to reduce dependencies to other parts of the compiler, functions
229 -- outside the "main" parts of GHC return warnings and errors as a parameter
230 -- and signal success via by wrapping the result in a 'Maybe' type. This
231 -- function logs the returned warnings and propagates errors as exceptions
232 -- (of type 'SourceError').
233 --
234 -- This function assumes the following invariants:
235 --
236 -- 1. If the second result indicates success (is of the form 'Just x'),
237 -- there must be no error messages in the first result.
238 --
239 -- 2. If there are no error messages, but the second result indicates failure
240 -- there should be warnings in the first result. That is, if the action
241 -- failed, it must have been due to the warnings (i.e., @-Werror@).
242 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
243 ioMsgMaybe ioA = do
244 ((warns,errs), mb_r) <- liftIO ioA
245 logWarnings warns
246 case mb_r of
247 Nothing -> throwErrors errs
248 Just r -> ASSERT( isEmptyBag errs ) return r
249
250 -- | like ioMsgMaybe, except that we ignore error messages and return
251 -- 'Nothing' instead.
252 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
253 ioMsgMaybe' ioA = do
254 ((warns,_errs), mb_r) <- liftIO $ ioA
255 logWarnings warns
256 return mb_r
257
258 -- -----------------------------------------------------------------------------
259 -- | Lookup things in the compiler's environment
260
261 #ifdef GHCI
262 hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
263 hscTcRnLookupRdrName hsc_env0 rdr_name
264 = runInteractiveHsc hsc_env0 $
265 do { hsc_env <- getHscEnv
266 ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
267 #endif
268
269 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
270 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
271 hsc_env <- getHscEnv
272 ioMsgMaybe' $ tcRnLookupName hsc_env name
273 -- ignore errors: the only error we're likely to get is
274 -- "name not found", and the Maybe in the return type
275 -- is used to indicate that.
276
277 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst]))
278 hscTcRnGetInfo hsc_env0 name
279 = runInteractiveHsc hsc_env0 $
280 do { hsc_env <- getHscEnv
281 ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
282
283 #ifdef GHCI
284 hscIsGHCiMonad :: HscEnv -> String -> IO Name
285 hscIsGHCiMonad hsc_env name
286 = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
287
288 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
289 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
290 hsc_env <- getHscEnv
291 ioMsgMaybe $ getModuleInterface hsc_env mod
292
293 -- -----------------------------------------------------------------------------
294 -- | Rename some import declarations
295 hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv
296 hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
297 hsc_env <- getHscEnv
298 ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
299 #endif
300
301 -- -----------------------------------------------------------------------------
302 -- | parse a file, returning the abstract syntax
303
304 hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
305 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
306
307 -- internal version, that doesn't fail due to -Werror
308 hscParse' :: ModSummary -> Hsc HsParsedModule
309 hscParse' mod_summary = do
310 dflags <- getDynFlags
311 let src_filename = ms_hspp_file mod_summary
312 maybe_src_buf = ms_hspp_buf mod_summary
313
314 -------------------------- Parser ----------------
315 liftIO $ showPass dflags "Parser"
316 {-# SCC "Parser" #-} do
317
318 -- sometimes we already have the buffer in memory, perhaps
319 -- because we needed to parse the imports out of it, or get the
320 -- module name.
321 buf <- case maybe_src_buf of
322 Just b -> return b
323 Nothing -> liftIO $ hGetStringBuffer src_filename
324
325 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
326
327 case unP parseModule (mkPState dflags buf loc) of
328 PFailed span err ->
329 liftIO $ throwOneError (mkPlainErrMsg dflags span err)
330
331 POk pst rdr_module -> do
332 logWarningsReportErrors (getMessages pst)
333 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
334 ppr rdr_module
335 liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
336 ppSourceStats False rdr_module
337
338 -- To get the list of extra source files, we take the list
339 -- that the parser gave us,
340 -- - eliminate files beginning with '<'. gcc likes to use
341 -- pseudo-filenames like "<built-in>" and "<command-line>"
342 -- - normalise them (elimiante differences between ./f and f)
343 -- - filter out the preprocessed source file
344 -- - filter out anything beginning with tmpdir
345 -- - remove duplicates
346 -- - filter out the .hs/.lhs source filename if we have one
347 --
348 let n_hspp = FilePath.normalise src_filename
349 srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
350 $ filter (not . (== n_hspp))
351 $ map FilePath.normalise
352 $ filter (not . (isPrefixOf "<"))
353 $ map unpackFS
354 $ srcfiles pst
355 srcs1 = case ml_hs_file (ms_location mod_summary) of
356 Just f -> filter (/= FilePath.normalise f) srcs0
357 Nothing -> srcs0
358
359 -- sometimes we see source files from earlier
360 -- preprocessing stages that cannot be found, so just
361 -- filter them out:
362 srcs2 <- liftIO $ filterM doesFileExist srcs1
363
364 return HsParsedModule {
365 hpm_module = rdr_module,
366 hpm_src_files = srcs2,
367 hpm_annotations
368 = (Map.fromListWith (++) $ annotations pst,
369 Map.fromList $ ((noSrcSpan,comment_q pst)
370 :(annotations_comments pst)))
371 }
372
373 -- XXX: should this really be a Maybe X? Check under which circumstances this
374 -- can become a Nothing and decide whether this should instead throw an
375 -- exception/signal an error.
376 type RenamedStuff =
377 (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
378 Maybe LHsDocString))
379
380 -- | Rename and typecheck a module, additionally returning the renamed syntax
381 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
382 -> IO (TcGblEnv, RenamedStuff)
383 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
384 tc_result <- tcRnModule' hsc_env mod_summary True rdr_module
385
386 -- This 'do' is in the Maybe monad!
387 let rn_info = do decl <- tcg_rn_decls tc_result
388 let imports = tcg_rn_imports tc_result
389 exports = tcg_rn_exports tc_result
390 doc_hdr = tcg_doc_hdr tc_result
391 return (decl,imports,exports,doc_hdr)
392
393 return (tc_result, rn_info)
394
395 -- wrapper around tcRnModule to handle safe haskell extras
396 tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule
397 -> Hsc TcGblEnv
398 tcRnModule' hsc_env sum save_rn_syntax mod = do
399 tcg_res <- {-# SCC "Typecheck-Rename" #-}
400 ioMsgMaybe $
401 tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod
402
403 -- See Note [Safe Haskell Overlapping Instances Implementation]
404 -- although this is used for more than just that failure case.
405 (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
406 dflags <- getDynFlags
407 let allSafeOK = safeInferred dflags && tcSafeOK
408
409 -- end of the safe haskell line, how to respond to user?
410 if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
411 -- if safe Haskell off or safe infer failed, mark unsafe
412 then markUnsafeInfer tcg_res whyUnsafe
413
414 -- module (could be) safe, throw warning if needed
415 else do
416 tcg_res' <- hscCheckSafeImports tcg_res
417 safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
418 when safe $ do
419 case wopt Opt_WarnSafe dflags of
420 True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags
421 (warnSafeOnLoc dflags) $ errSafe tcg_res')
422 False | safeHaskell dflags == Sf_Trustworthy &&
423 wopt Opt_WarnTrustworthySafe dflags ->
424 (logWarnings $ unitBag $ mkPlainWarnMsg dflags
425 (trustworthyOnLoc dflags) $ errTwthySafe tcg_res')
426 False -> return ()
427 return tcg_res'
428 where
429 pprMod t = ppr $ moduleName $ tcg_mod t
430 errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
431 errTwthySafe t = quotes (pprMod t)
432 <+> text "is marked as Trustworthy but has been inferred as safe!"
433
434 -- | Convert a typechecked module to Core
435 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
436 hscDesugar hsc_env mod_summary tc_result =
437 runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
438
439 hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
440 hscDesugar' mod_location tc_result = do
441 hsc_env <- getHscEnv
442 r <- ioMsgMaybe $
443 {-# SCC "deSugar" #-}
444 deSugar hsc_env mod_location tc_result
445
446 -- always check -Werror after desugaring, this is the last opportunity for
447 -- warnings to arise before the backend.
448 handleWarnings
449 return r
450
451 -- | Make a 'ModIface' from the results of typechecking. Used when
452 -- not optimising, and the interface doesn't need to contain any
453 -- unfoldings or other cross-module optimisation info.
454 -- ToDo: the old interface is only needed to get the version numbers,
455 -- we should use fingerprint versions instead.
456 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
457 -> IO (ModIface,Bool)
458 makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do
459 safe_mode <- hscGetSafeMode tc_result
460 ioMsgMaybe $ do
461 mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode
462 details tc_result
463
464 -- | Make a 'ModDetails' from the results of typechecking. Used when
465 -- typechecking only, as opposed to full compilation.
466 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
467 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
468
469
470 {- **********************************************************************
471 %* *
472 The main compiler pipeline
473 %* *
474 %********************************************************************* -}
475
476 {-
477 --------------------------------
478 The compilation proper
479 --------------------------------
480
481 It's the task of the compilation proper to compile Haskell, hs-boot and core
482 files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all
483 (the module is still parsed and type-checked. This feature is mostly used by
484 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
485 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
486 mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
487 targets byte-code.
488
489 The modes are kept separate because of their different types and meanings:
490
491 * In 'one-shot' mode, we're only compiling a single file and can therefore
492 discard the new ModIface and ModDetails. This is also the reason it only
493 targets hard-code; compiling to byte-code or nothing doesn't make sense when
494 we discard the result.
495
496 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
497 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
498 return the newly compiled byte-code.
499
500 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
501 kept separate. This is because compiling to nothing is fairly special: We
502 don't output any interface files, we don't run the simplifier and we don't
503 generate any code.
504
505 * 'Interactive' mode is similar to 'batch' mode except that we return the
506 compiled byte-code together with the ModIface and ModDetails.
507
508 Trying to compile a hs-boot file to byte-code will result in a run-time error.
509 This is the only thing that isn't caught by the type-system.
510 -}
511
512
513 type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
514
515 genericHscCompileGetFrontendResult ::
516 Bool -- always do basic recompilation check?
517 -> Maybe TcGblEnv
518 -> Maybe Messager
519 -> HscEnv
520 -> ModSummary
521 -> SourceModified
522 -> Maybe ModIface -- Old interface, if available
523 -> (Int,Int) -- (i,n) = module i of n (for msgs)
524 -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint))
525
526 genericHscCompileGetFrontendResult
527 always_do_basic_recompilation_check m_tc_result
528 mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index
529 = do
530
531 let msg what = case mHscMessage of
532 Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
533 Nothing -> return ()
534
535 skip iface = do
536 msg UpToDate
537 return $ Left iface
538
539 compile mb_old_hash reason = do
540 msg reason
541 tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary
542 return $ Right (tc_result, mb_old_hash)
543
544 stable = case source_modified of
545 SourceUnmodifiedAndStable -> True
546 _ -> False
547
548 case m_tc_result of
549 Just tc_result
550 | not always_do_basic_recompilation_check ->
551 return $ Right (tc_result, Nothing)
552 _ -> do
553 (recomp_reqd, mb_checked_iface)
554 <- {-# SCC "checkOldIface" #-}
555 checkOldIface hsc_env mod_summary
556 source_modified mb_old_iface
557 -- save the interface that comes back from checkOldIface.
558 -- In one-shot mode we don't have the old iface until this
559 -- point, when checkOldIface reads it from the disk.
560 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
561
562 case mb_checked_iface of
563 Just iface | not (recompileRequired recomp_reqd) ->
564 -- If the module used TH splices when it was last
565 -- compiled, then the recompilation check is not
566 -- accurate enough (#481) and we must ignore
567 -- it. However, if the module is stable (none of
568 -- the modules it depends on, directly or
569 -- indirectly, changed), then we *can* skip
570 -- recompilation. This is why the SourceModified
571 -- type contains SourceUnmodifiedAndStable, and
572 -- it's pretty important: otherwise ghc --make
573 -- would always recompile TH modules, even if
574 -- nothing at all has changed. Stability is just
575 -- the same check that make is doing for us in
576 -- one-shot mode.
577 case m_tc_result of
578 Nothing
579 | mi_used_th iface && not stable ->
580 compile mb_old_hash (RecompBecause "TH")
581 _ ->
582 skip iface
583 _ ->
584 case m_tc_result of
585 Nothing -> compile mb_old_hash recomp_reqd
586 Just tc_result ->
587 return $ Right (tc_result, mb_old_hash)
588
589 genericHscFrontend :: ModSummary -> Hsc TcGblEnv
590 genericHscFrontend mod_summary =
591 getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
592
593 genericHscFrontend' :: ModSummary -> Hsc TcGblEnv
594 genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary
595
596 --------------------------------------------------------------
597 -- Compilers
598 --------------------------------------------------------------
599
600 hscCompileOneShot :: HscEnv
601 -> ModSummary
602 -> SourceModified
603 -> IO HscStatus
604 hscCompileOneShot env =
605 lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env
606
607 -- Compile Haskell/boot in OneShot mode.
608 hscCompileOneShot' :: HscEnv
609 -> ModSummary
610 -> SourceModified
611 -> IO HscStatus
612 hscCompileOneShot' hsc_env mod_summary src_changed
613 = do
614 -- One-shot mode needs a knot-tying mutable variable for interface
615 -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
616 type_env_var <- newIORef emptyNameEnv
617 let mod = ms_mod mod_summary
618 hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
619
620 msg what = oneShotMsg hsc_env' what
621
622 skip = do msg UpToDate
623 dumpIfaceStats hsc_env'
624 return HscUpToDate
625
626 compile mb_old_hash reason = runHsc hsc_env' $ do
627 liftIO $ msg reason
628 tc_result <- genericHscFrontend mod_summary
629 guts0 <- hscDesugar' (ms_location mod_summary) tc_result
630 dflags <- getDynFlags
631 case hscTarget dflags of
632 HscNothing -> do
633 when (gopt Opt_WriteInterface dflags) $ liftIO $ do
634 (iface, changed, _details) <- hscSimpleIface hsc_env tc_result mb_old_hash
635 hscWriteIface dflags iface changed mod_summary
636 return HscNotGeneratingCode
637 _ ->
638 case ms_hsc_src mod_summary of
639 t | isHsBootOrSig t ->
640 do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash
641 liftIO $ hscWriteIface dflags iface changed mod_summary
642 return (case t of
643 HsBootFile -> HscUpdateBoot
644 HsigFile -> HscUpdateSig
645 HsSrcFile -> panic "hscCompileOneShot Src")
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 (unLoc 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, whyUnsafe)
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
1079 checkOverlap (NoOverlap _) = False
1080 checkOverlap _ = True
1081
1082 badInst ins | checkOverlap (overlapMode (is_flag ins))
1083 = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
1084 ppr (overlapMode $ is_flag ins) <+>
1085 text "overlap mode isn't allowed in Safe Haskell"]
1086 | otherwise = []
1087
1088
1089 -- | Figure out the final correct safe haskell mode
1090 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
1091 hscGetSafeMode tcg_env = do
1092 dflags <- getDynFlags
1093 liftIO $ finalSafeMode dflags tcg_env
1094
1095 --------------------------------------------------------------
1096 -- Simplifiers
1097 --------------------------------------------------------------
1098
1099 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1100 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1101
1102 hscSimplify' :: ModGuts -> Hsc ModGuts
1103 hscSimplify' ds_result = do
1104 hsc_env <- getHscEnv
1105 {-# SCC "Core2Core" #-}
1106 liftIO $ core2core hsc_env ds_result
1107
1108 --------------------------------------------------------------
1109 -- Interface generators
1110 --------------------------------------------------------------
1111
1112 hscSimpleIface :: HscEnv
1113 -> TcGblEnv
1114 -> Maybe Fingerprint
1115 -> IO (ModIface, Bool, ModDetails)
1116 hscSimpleIface hsc_env tc_result mb_old_iface
1117 = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
1118
1119 hscSimpleIface' :: TcGblEnv
1120 -> Maybe Fingerprint
1121 -> Hsc (ModIface, Bool, ModDetails)
1122 hscSimpleIface' tc_result mb_old_iface = do
1123 hsc_env <- getHscEnv
1124 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1125 safe_mode <- hscGetSafeMode tc_result
1126 (new_iface, no_change)
1127 <- {-# SCC "MkFinalIface" #-}
1128 ioMsgMaybe $
1129 mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
1130 -- And the answer is ...
1131 liftIO $ dumpIfaceStats hsc_env
1132 return (new_iface, no_change, details)
1133
1134 hscNormalIface :: HscEnv
1135 -> ModGuts
1136 -> Maybe Fingerprint
1137 -> IO (ModIface, Bool, ModDetails, CgGuts)
1138 hscNormalIface hsc_env simpl_result mb_old_iface =
1139 runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
1140
1141 hscNormalIface' :: ModGuts
1142 -> Maybe Fingerprint
1143 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1144 hscNormalIface' simpl_result mb_old_iface = do
1145 hsc_env <- getHscEnv
1146 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1147 liftIO $ tidyProgram hsc_env simpl_result
1148
1149 -- BUILD THE NEW ModIface and ModDetails
1150 -- and emit external core if necessary
1151 -- This has to happen *after* code gen so that the back-end
1152 -- info has been set. Not yet clear if it matters waiting
1153 -- until after code output
1154 (new_iface, no_change)
1155 <- {-# SCC "MkFinalIface" #-}
1156 ioMsgMaybe $
1157 mkIface hsc_env mb_old_iface details simpl_result
1158
1159 liftIO $ dumpIfaceStats hsc_env
1160
1161 -- Return the prepared code.
1162 return (new_iface, no_change, details, cg_guts)
1163
1164 --------------------------------------------------------------
1165 -- BackEnd combinators
1166 --------------------------------------------------------------
1167
1168 hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
1169 hscWriteIface dflags iface no_change mod_summary = do
1170 let ifaceFile = ml_hi_file (ms_location mod_summary)
1171 unless no_change $
1172 {-# SCC "writeIface" #-}
1173 writeIfaceFile dflags ifaceFile iface
1174 whenGeneratingDynamicToo dflags $ do
1175 -- TODO: We should do a no_change check for the dynamic
1176 -- interface file too
1177 -- TODO: Should handle the dynamic hi filename properly
1178 let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
1179 dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
1180 dynDflags = dynamicTooMkDynamicDynFlags dflags
1181 writeIfaceFile dynDflags dynIfaceFile' iface
1182
1183 -- | Compile to hard-code.
1184 hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
1185 -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1186 hscGenHardCode hsc_env cgguts mod_summary output_filename = do
1187 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1188 -- From now on, we just use the bits we need.
1189 cg_module = this_mod,
1190 cg_binds = core_binds,
1191 cg_tycons = tycons,
1192 cg_foreign = foreign_stubs0,
1193 cg_dep_pkgs = dependencies,
1194 cg_hpc_info = hpc_info } = cgguts
1195 dflags = hsc_dflags hsc_env
1196 location = ms_location mod_summary
1197 data_tycons = filter isDataTyCon tycons
1198 -- cg_tycons includes newtypes, for the benefit of External Core,
1199 -- but we don't generate any code for newtypes
1200
1201 -------------------
1202 -- PREPARE FOR CODE GENERATION
1203 -- Do saturation and convert to A-normal form
1204 prepd_binds <- {-# SCC "CorePrep" #-}
1205 corePrepPgm hsc_env location core_binds data_tycons ;
1206 ----------------- Convert to STG ------------------
1207 (stg_binds, cost_centre_info)
1208 <- {-# SCC "CoreToStg" #-}
1209 myCoreToStg dflags this_mod prepd_binds
1210
1211 let prof_init = profilingInitCode this_mod cost_centre_info
1212 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1213
1214 ------------------ Code generation ------------------
1215
1216 -- The back-end is streamed: each top-level function goes
1217 -- from Stg all the way to asm before dealing with the next
1218 -- top-level function, so showPass isn't very useful here.
1219 -- Hence we have one showPass for the whole backend, the
1220 -- next showPass after this will be "Assembler".
1221 showPass dflags "CodeGen"
1222
1223 cmms <- {-# SCC "StgCmm" #-}
1224 doCodeGen hsc_env this_mod data_tycons
1225 cost_centre_info
1226 stg_binds hpc_info
1227
1228 ------------------ Code output -----------------------
1229 rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
1230 cmmToRawCmm dflags cmms
1231
1232 let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
1233 (ppr a)
1234 return a
1235 rawcmms1 = Stream.mapM dump rawcmms0
1236
1237 (output_filename, (_stub_h_exists, stub_c_exists))
1238 <- {-# SCC "codeOutput" #-}
1239 codeOutput dflags this_mod output_filename location
1240 foreign_stubs dependencies rawcmms1
1241 return (output_filename, stub_c_exists)
1242
1243
1244 hscInteractive :: HscEnv
1245 -> CgGuts
1246 -> ModSummary
1247 -> IO (Maybe FilePath, CompiledByteCode, ModBreaks)
1248 #ifdef GHCI
1249 hscInteractive hsc_env cgguts mod_summary = do
1250 let dflags = hsc_dflags hsc_env
1251 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1252 -- From now on, we just use the bits we need.
1253 cg_module = this_mod,
1254 cg_binds = core_binds,
1255 cg_tycons = tycons,
1256 cg_foreign = foreign_stubs,
1257 cg_modBreaks = mod_breaks } = cgguts
1258
1259 location = ms_location mod_summary
1260 data_tycons = filter isDataTyCon tycons
1261 -- cg_tycons includes newtypes, for the benefit of External Core,
1262 -- but we don't generate any code for newtypes
1263
1264 -------------------
1265 -- PREPARE FOR CODE GENERATION
1266 -- Do saturation and convert to A-normal form
1267 prepd_binds <- {-# SCC "CorePrep" #-}
1268 corePrepPgm hsc_env location core_binds data_tycons
1269 ----------------- Generate byte code ------------------
1270 comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
1271 ------------------ Create f-x-dynamic C-side stuff ---
1272 (_istub_h_exists, istub_c_exists)
1273 <- outputForeignStubs dflags this_mod location foreign_stubs
1274 return (istub_c_exists, comp_bc, mod_breaks)
1275 #else
1276 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1277 #endif
1278
1279 ------------------------------
1280
1281 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
1282 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
1283 let dflags = hsc_dflags hsc_env
1284 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1285 liftIO $ do
1286 us <- mkSplitUniqSupply 'S'
1287 let initTopSRT = initUs_ us emptySRT
1288 dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm)
1289 (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
1290 rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
1291 _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms
1292 return ()
1293 where
1294 no_mod = panic "hscCmmFile: no_mod"
1295 no_loc = ModLocation{ ml_hs_file = Just filename,
1296 ml_hi_file = panic "hscCmmFile: no hi file",
1297 ml_obj_file = panic "hscCmmFile: no obj file" }
1298
1299 -------------------- Stuff for new code gen ---------------------
1300
1301 doCodeGen :: HscEnv -> Module -> [TyCon]
1302 -> CollectedCCs
1303 -> [StgBinding]
1304 -> HpcInfo
1305 -> IO (Stream IO CmmGroup ())
1306 -- Note we produce a 'Stream' of CmmGroups, so that the
1307 -- backend can be run incrementally. Otherwise it generates all
1308 -- the C-- up front, which has a significant space cost.
1309 doCodeGen hsc_env this_mod data_tycons
1310 cost_centre_info stg_binds hpc_info = do
1311 let dflags = hsc_dflags hsc_env
1312
1313 let cmm_stream :: Stream IO CmmGroup ()
1314 cmm_stream = {-# SCC "StgCmm" #-}
1315 StgCmm.codeGen dflags this_mod data_tycons
1316 cost_centre_info stg_binds hpc_info
1317
1318 -- codegen consumes a stream of CmmGroup, and produces a new
1319 -- stream of CmmGroup (not necessarily synchronised: one
1320 -- CmmGroup on input may produce many CmmGroups on output due
1321 -- to proc-point splitting).
1322
1323 let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
1324 "Cmm produced by new codegen" (ppr a)
1325 return a
1326
1327 ppr_stream1 = Stream.mapM dump1 cmm_stream
1328
1329 -- We are building a single SRT for the entire module, so
1330 -- we must thread it through all the procedures as we cps-convert them.
1331 us <- mkSplitUniqSupply 'S'
1332
1333 -- When splitting, we generate one SRT per split chunk, otherwise
1334 -- we generate one SRT for the whole module.
1335 let
1336 pipeline_stream
1337 | gopt Opt_SplitObjs dflags
1338 = {-# SCC "cmmPipeline" #-}
1339 let run_pipeline us cmmgroup = do
1340 let (topSRT', us') = initUs us emptySRT
1341 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
1342 let srt | isEmptySRT topSRT = []
1343 | otherwise = srtToData topSRT
1344 return (us', srt ++ cmmgroup)
1345
1346 in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
1347 return ()
1348
1349 | otherwise
1350 = {-# SCC "cmmPipeline" #-}
1351 let initTopSRT = initUs_ us emptySRT
1352 run_pipeline = cmmPipeline hsc_env
1353 in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
1354 Stream.yield (srtToData topSRT)
1355
1356 let
1357 dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a
1358 return a
1359
1360 ppr_stream2 = Stream.mapM dump2 pipeline_stream
1361
1362 return ppr_stream2
1363
1364
1365
1366 myCoreToStg :: DynFlags -> Module -> CoreProgram
1367 -> IO ( [StgBinding] -- output program
1368 , CollectedCCs) -- cost centre info (declared and used)
1369 myCoreToStg dflags this_mod prepd_binds = do
1370 stg_binds
1371 <- {-# SCC "Core2Stg" #-}
1372 coreToStg dflags this_mod prepd_binds
1373
1374 (stg_binds2, cost_centre_info)
1375 <- {-# SCC "Stg2Stg" #-}
1376 stg2stg dflags this_mod stg_binds
1377
1378 return (stg_binds2, cost_centre_info)
1379
1380
1381 {- **********************************************************************
1382 %* *
1383 \subsection{Compiling a do-statement}
1384 %* *
1385 %********************************************************************* -}
1386
1387 {-
1388 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1389 you run it you get a list of HValues that should be the same length as the list
1390 of names; add them to the ClosureEnv.
1391
1392 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1393 IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
1394 -}
1395
1396 #ifdef GHCI
1397 -- | Compile a stmt all the way to an HValue, but don't run it
1398 --
1399 -- We return Nothing to indicate an empty statement (or comment only), not a
1400 -- parse error.
1401 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1402 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1403
1404 -- | Compile a stmt all the way to an HValue, but don't run it
1405 --
1406 -- We return Nothing to indicate an empty statement (or comment only), not a
1407 -- parse error.
1408 hscStmtWithLocation :: HscEnv
1409 -> String -- ^ The statement
1410 -> String -- ^ The source
1411 -> Int -- ^ Starting line
1412 -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1413 hscStmtWithLocation hsc_env0 stmt source linenumber =
1414 runInteractiveHsc hsc_env0 $ do
1415 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1416 case maybe_stmt of
1417 Nothing -> return Nothing
1418
1419 Just parsed_stmt -> do
1420 -- Rename and typecheck it
1421 hsc_env <- getHscEnv
1422 (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt
1423
1424 -- Desugar it
1425 ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
1426 liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
1427 handleWarnings
1428
1429 -- Then code-gen, and link it
1430 -- It's important NOT to have package 'interactive' as thisPackageKey
1431 -- for linking, else we try to link 'main' and can't find it.
1432 -- Whereas the linker already knows to ignore 'interactive'
1433 let src_span = srcLocSpan interactiveSrcLoc
1434 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1435 let hval_io = unsafeCoerce# hval :: IO [HValue]
1436
1437 return $ Just (ids, hval_io, fix_env)
1438
1439 -- | Compile a decls
1440 hscDecls :: HscEnv
1441 -> String -- ^ The statement
1442 -> IO ([TyThing], InteractiveContext)
1443 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1444
1445 -- | Compile a decls
1446 hscDeclsWithLocation :: HscEnv
1447 -> String -- ^ The statement
1448 -> String -- ^ The source
1449 -> Int -- ^ Starting line
1450 -> IO ([TyThing], InteractiveContext)
1451 hscDeclsWithLocation hsc_env0 str source linenumber =
1452 runInteractiveHsc hsc_env0 $ do
1453 L _ (HsModule{ hsmodDecls = decls }) <-
1454 hscParseThingWithLocation source linenumber parseModule str
1455
1456 {- Rename and typecheck it -}
1457 hsc_env <- getHscEnv
1458 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
1459
1460 {- Grab the new instances -}
1461 -- We grab the whole environment because of the overlapping that may have
1462 -- been done. See the notes at the definition of InteractiveContext
1463 -- (ic_instances) for more details.
1464 let defaults = tcg_default tc_gblenv
1465
1466 {- Desugar it -}
1467 -- We use a basically null location for iNTERACTIVE
1468 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1469 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1470 ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
1471 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1472
1473 {- Simplify -}
1474 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1475
1476 {- Tidy -}
1477 (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1478
1479 let dflags = hsc_dflags hsc_env
1480 !CgGuts{ cg_module = this_mod,
1481 cg_binds = core_binds,
1482 cg_tycons = tycons,
1483 cg_modBreaks = mod_breaks } = tidy_cg
1484
1485 !ModDetails { md_insts = cls_insts
1486 , md_fam_insts = fam_insts } = mod_details
1487 -- Get the *tidied* cls_insts and fam_insts
1488
1489 data_tycons = filter isDataTyCon tycons
1490
1491 {- Prepare For Code Generation -}
1492 -- Do saturation and convert to A-normal form
1493 prepd_binds <- {-# SCC "CorePrep" #-}
1494 liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons
1495
1496 {- Generate byte code -}
1497 cbc <- liftIO $ byteCodeGen dflags this_mod
1498 prepd_binds data_tycons mod_breaks
1499
1500 let src_span = srcLocSpan interactiveSrcLoc
1501 liftIO $ linkDecls hsc_env src_span cbc
1502
1503 let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
1504 patsyns = mg_patsyns simpl_mg
1505
1506 ext_ids = [ id | id <- bindersOfBinds core_binds
1507 , isExternalName (idName id)
1508 , not (isDFunId id || isImplicitId id) ]
1509 -- We only need to keep around the external bindings
1510 -- (as decided by TidyPgm), since those are the only ones
1511 -- that might be referenced elsewhere.
1512 -- The DFunIds are in 'cls_insts' (see Note [ic_tythings] in HscTypes
1513 -- Implicit Ids are implicit in tcs
1514
1515 tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
1516
1517 let icontext = hsc_IC hsc_env
1518 ictxt = extendInteractiveContext icontext ext_ids tcs
1519 cls_insts fam_insts defaults patsyns
1520 return (tythings, ictxt)
1521
1522 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1523 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1524 (L _ (HsModule{hsmodImports=is})) <-
1525 hscParseThing parseModule str
1526 case is of
1527 [L _ i] -> return i
1528 _ -> liftIO $ throwOneError $
1529 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
1530 ptext (sLit "parse error in import declaration")
1531
1532 -- | Typecheck an expression (but don't run it)
1533 -- Returns its most general type
1534 hscTcExpr :: HscEnv
1535 -> String -- ^ The expression
1536 -> IO Type
1537 hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
1538 hsc_env <- getHscEnv
1539 maybe_stmt <- hscParseStmt expr
1540 case maybe_stmt of
1541 Just (L _ (BodyStmt expr _ _ _)) ->
1542 ioMsgMaybe $ tcRnExpr hsc_env expr
1543 _ ->
1544 throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
1545 (text "not an expression:" <+> quotes (text expr))
1546
1547 -- | Find the kind of a type
1548 -- Currently this does *not* generalise the kinds of the type
1549 hscKcType
1550 :: HscEnv
1551 -> Bool -- ^ Normalise the type
1552 -> String -- ^ The type as a string
1553 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1554 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1555 hsc_env <- getHscEnv
1556 ty <- hscParseType str
1557 ioMsgMaybe $ tcRnType hsc_env normalise ty
1558
1559 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
1560 hscParseStmt = hscParseThing parseStmt
1561
1562 hscParseStmtWithLocation :: String -> Int -> String
1563 -> Hsc (Maybe (GhciLStmt RdrName))
1564 hscParseStmtWithLocation source linenumber stmt =
1565 hscParseThingWithLocation source linenumber parseStmt stmt
1566
1567 hscParseType :: String -> Hsc (LHsType RdrName)
1568 hscParseType = hscParseThing parseType
1569 #endif
1570
1571 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1572 hscParseIdentifier hsc_env str =
1573 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1574
1575 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1576 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1577
1578 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1579 -> Lexer.P thing -> String -> Hsc thing
1580 hscParseThingWithLocation source linenumber parser str
1581 = {-# SCC "Parser" #-} do
1582 dflags <- getDynFlags
1583 liftIO $ showPass dflags "Parser"
1584
1585 let buf = stringToStringBuffer str
1586 loc = mkRealSrcLoc (fsLit source) linenumber 1
1587
1588 case unP parser (mkPState dflags buf loc) of
1589 PFailed span err -> do
1590 let msg = mkPlainErrMsg dflags span err
1591 throwErrors $ unitBag msg
1592
1593 POk pst thing -> do
1594 logWarningsReportErrors (getMessages pst)
1595 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1596 return thing
1597
1598 hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
1599 -> CoreProgram -> FilePath -> IO ()
1600 hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename
1601 = runHsc hsc_env $ do
1602 guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
1603 (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing
1604 liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary
1605 _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename
1606 return ()
1607
1608 where
1609 maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1610 | otherwise = return mod_guts
1611
1612 -- Makes a "vanilla" ModGuts.
1613 mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts
1614 mkModGuts mod safe binds =
1615 ModGuts {
1616 mg_module = mod,
1617 mg_boot = False,
1618 mg_exports = [],
1619 mg_deps = noDependencies,
1620 mg_dir_imps = emptyModuleEnv,
1621 mg_used_names = emptyNameSet,
1622 mg_used_th = False,
1623 mg_rdr_env = emptyGlobalRdrEnv,
1624 mg_fix_env = emptyFixityEnv,
1625 mg_tcs = [],
1626 mg_insts = [],
1627 mg_fam_insts = [],
1628 mg_patsyns = [],
1629 mg_rules = [],
1630 mg_vect_decls = [],
1631 mg_binds = binds,
1632 mg_foreign = NoStubs,
1633 mg_warns = NoWarnings,
1634 mg_anns = [],
1635 mg_hpc_info = emptyHpcInfo False,
1636 mg_modBreaks = emptyModBreaks,
1637 mg_vect_info = noVectInfo,
1638 mg_inst_env = emptyInstEnv,
1639 mg_fam_inst_env = emptyFamInstEnv,
1640 mg_safe_haskell = safe,
1641 mg_trust_pkg = False,
1642 mg_dependent_files = []
1643 }
1644
1645
1646 {- **********************************************************************
1647 %* *
1648 Desugar, simplify, convert to bytecode, and link an expression
1649 %* *
1650 %********************************************************************* -}
1651
1652 #ifdef GHCI
1653 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1654 hscCompileCoreExpr hsc_env =
1655 lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
1656
1657 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1658 hscCompileCoreExpr' hsc_env srcspan ds_expr
1659 | rtsIsProfiled
1660 = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1661 -- Otherwise you get a seg-fault when you run it
1662
1663 | otherwise
1664 = do { let dflags = hsc_dflags hsc_env
1665
1666 {- Simplify it -}
1667 ; simpl_expr <- simplifyExpr dflags ds_expr
1668
1669 {- Tidy it (temporary, until coreSat does cloning) -}
1670 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1671
1672 {- Prepare for codegen -}
1673 ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
1674
1675 {- Lint if necessary -}
1676 ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
1677
1678 {- Convert to BCOs -}
1679 ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
1680
1681 {- link it -}
1682 ; hval <- linkExpr hsc_env srcspan bcos
1683
1684 ; return hval }
1685 #endif
1686
1687
1688 {- **********************************************************************
1689 %* *
1690 Statistics on reading interfaces
1691 %* *
1692 %********************************************************************* -}
1693
1694 dumpIfaceStats :: HscEnv -> IO ()
1695 dumpIfaceStats hsc_env = do
1696 eps <- readIORef (hsc_EPS hsc_env)
1697 dumpIfSet dflags (dump_if_trace || dump_rn_stats)
1698 "Interface statistics"
1699 (ifaceStats eps)
1700 where
1701 dflags = hsc_dflags hsc_env
1702 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1703 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1704
1705
1706 {- **********************************************************************
1707 %* *
1708 Progress Messages: Module i of n
1709 %* *
1710 %********************************************************************* -}
1711
1712 showModuleIndex :: (Int, Int) -> String
1713 showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1714 where
1715 n_str = show n
1716 i_str = show i
1717 padded = replicate (length n_str - length i_str) ' ' ++ i_str