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