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