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