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