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