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