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