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