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