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