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