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