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