Annotate initIfaceCheck with usage information.
[ghc.git] / compiler / main / HscMain.hs
1 {-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}
2 {-# OPTIONS_GHC -fprof-auto-top #-}
3
4 -------------------------------------------------------------------------------
5 --
6 -- | Main API for compiling plain Haskell source code.
7 --
8 -- This module implements compilation of a Haskell source. It is
9 -- /not/ concerned with preprocessing of source files; this is handled
10 -- in "DriverPipeline".
11 --
12 -- There are various entry points depending on what mode we're in:
13 -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
14 -- "interactive" mode (GHCi). There are also entry points for
15 -- individual passes: parsing, typechecking/renaming, desugaring, and
16 -- simplification.
17 --
18 -- All the functions here take an 'HscEnv' as a parameter, but none of
19 -- them return a new one: 'HscEnv' is treated as an immutable value
20 -- from here on in (although it has mutable components, for the
21 -- caches).
22 --
23 -- We use the Hsc monad to deal with warning messages consistently:
24 -- specifically, while executing within an Hsc monad, warnings are
25 -- collected. When a Hsc monad returns to an IO monad, the
26 -- warnings are printed, or compilation aborts if the @-Werror@
27 -- flag is enabled.
28 --
29 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
30 --
31 -------------------------------------------------------------------------------
32
33 module HscMain
34 (
35 -- * Making an HscEnv
36 newHscEnv
37
38 -- * Compiling complete source files
39 , Messager, batchMsg
40 , HscStatus (..)
41 , hscIncrementalCompile
42 , hscCompileCmmFile
43
44 , hscGenHardCode
45 , hscInteractive
46
47 -- * Running passes separately
48 , hscParse
49 , hscTypecheckRename
50 , hscDesugar
51 , makeSimpleDetails
52 , hscSimplify -- ToDo, shouldn't really export this
53
54 -- * Safe Haskell
55 , hscCheckSafe
56 , hscGetSafe
57
58 -- * Support for interactive evaluation
59 , hscParseIdentifier
60 , hscTcRcLookupName
61 , hscTcRnGetInfo
62 #ifdef GHCI
63 , hscIsGHCiMonad
64 , hscGetModuleInterface
65 , hscRnImportDecls
66 , hscTcRnLookupRdrName
67 , hscStmt, hscStmtWithLocation, hscParsedStmt
68 , hscDecls, hscDeclsWithLocation
69 , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
70 , hscParseExpr
71 , hscCompileCoreExpr
72 -- * Low-level exports for hooks
73 , hscCompileCoreExpr'
74 #endif
75 -- We want to make sure that we export enough to be able to redefine
76 -- hscFileFrontEnd in client code
77 , hscParse', hscSimplify', hscDesugar', tcRnModule'
78 , getHscEnv
79 , hscSimpleIface', hscNormalIface'
80 , oneShotMsg
81 , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
82 ) where
83
84 #ifdef GHCI
85 import Id
86 import GHCi.RemoteTypes ( ForeignHValue )
87 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
88 import Linker
89 import CoreTidy ( tidyExpr )
90 import Type ( Type )
91 import {- Kind parts of -} Type ( Kind )
92 import CoreLint ( lintInteractiveExpr )
93 import VarEnv ( emptyTidyEnv )
94 import Panic
95 import ConLike
96 import Control.Concurrent
97 #endif
98
99 import THNames ( templateHaskellNames )
100 import Module
101 import Packages
102 import RdrName
103 import HsSyn
104 import CoreSyn
105 import StringBuffer
106 import Parser
107 import Lexer
108 import SrcLoc
109 import TcRnDriver
110 import TcIface ( typecheckIface )
111 import TcRnMonad
112 import IfaceEnv ( initNameCache )
113 import LoadIface ( ifaceStats, initExternalPackageState )
114 import PrelInfo
115 import MkIface
116 import Desugar
117 import SimplCore
118 import TidyPgm
119 import CorePrep
120 import CoreToStg ( coreToStg )
121 import qualified StgCmm ( codeGen )
122 import StgSyn
123 import CostCentre
124 import ProfInit
125 import TyCon
126 import Name
127 import SimplStg ( stg2stg )
128 import Cmm
129 import CmmParse ( parseCmmFile )
130 import CmmBuildInfoTables
131 import CmmPipeline
132 import CmmInfo
133 import CodeOutput
134 import InstEnv
135 import FamInstEnv
136 import Fingerprint ( Fingerprint )
137 import Hooks
138 import Maybes
139
140 import DynFlags
141 import ErrUtils
142
143 import Outputable
144 import UniqFM
145 import NameEnv
146 import HscStats ( ppSourceStats )
147 import HscTypes
148 import FastString
149 import UniqSupply
150 import Bag
151 import Exception
152 import qualified Stream
153 import Stream (Stream)
154
155 import Util
156
157 import Data.List
158 import Control.Monad
159 import Data.IORef
160 import System.FilePath as FilePath
161 import System.Directory
162 import qualified Data.Map as Map
163
164 #include "HsVersions.h"
165
166
167 {- **********************************************************************
168 %* *
169 Initialisation
170 %* *
171 %********************************************************************* -}
172
173 newHscEnv :: DynFlags -> IO HscEnv
174 newHscEnv dflags = do
175 eps_var <- newIORef initExternalPackageState
176 us <- mkSplitUniqSupply 'r'
177 nc_var <- newIORef (initNameCache us allKnownKeyNames)
178 fc_var <- newIORef emptyModuleEnv
179 #ifdef GHCI
180 iserv_mvar <- newMVar Nothing
181 #endif
182 return HscEnv { hsc_dflags = dflags
183 , hsc_targets = []
184 , hsc_mod_graph = []
185 , hsc_IC = emptyInteractiveContext dflags
186 , hsc_HPT = emptyHomePackageTable
187 , hsc_EPS = eps_var
188 , hsc_NC = nc_var
189 , hsc_FC = fc_var
190 , hsc_type_env_var = Nothing
191 #ifdef GHCI
192 , hsc_iserv = iserv_mvar
193 #endif
194 }
195
196
197 allKnownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
198 allKnownKeyNames -- where templateHaskellNames are defined
199 | debugIsOn
200 , not (isNullUFM badNamesEnv)
201 = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)
202 -- NB: We can't use ppr here, because this is sometimes evaluated in a
203 -- context where there are no DynFlags available, leading to a cryptic
204 -- "<<details unavailable>>" error. (This seems to happen only in the
205 -- stage 2 compiler, for reasons I [Richard] have no clue of.)
206
207 | otherwise
208 = all_names
209 where
210 all_names = knownKeyNames
211 ++ templateHaskellNames
212
213 namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
214 emptyUFM all_names
215 badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv
216 badNamesPairs = nonDetUFMToList badNamesEnv
217 -- It's OK to use nonDetUFMToList here because the ordering only affects
218 -- the message when we get a panic
219 badNamesStrs = map pairToStr badNamesPairs
220 badNamesStr = unlines badNamesStrs
221
222 pairToStr (uniq, ns) = " " ++
223 show uniq ++
224 ": [" ++
225 intercalate ", " (map (occNameString . nameOccName) ns) ++
226 "]"
227
228
229 -- -----------------------------------------------------------------------------
230
231 getWarnings :: Hsc WarningMessages
232 getWarnings = Hsc $ \_ w -> return (w, w)
233
234 clearWarnings :: Hsc ()
235 clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
236
237 logWarnings :: WarningMessages -> Hsc ()
238 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
239
240 getHscEnv :: Hsc HscEnv
241 getHscEnv = Hsc $ \e w -> return (e, w)
242
243 handleWarnings :: Hsc ()
244 handleWarnings = do
245 dflags <- getDynFlags
246 w <- getWarnings
247 liftIO $ printOrThrowWarnings dflags w
248 clearWarnings
249
250 -- | log warning in the monad, and if there are errors then
251 -- throw a SourceError exception.
252 logWarningsReportErrors :: Messages -> Hsc ()
253 logWarningsReportErrors (warns,errs) = do
254 logWarnings warns
255 when (not $ isEmptyBag errs) $ throwErrors errs
256
257 -- | Throw some errors.
258 throwErrors :: ErrorMessages -> Hsc a
259 throwErrors = liftIO . throwIO . mkSrcErr
260
261 -- | Deal with errors and warnings returned by a compilation step
262 --
263 -- In order to reduce dependencies to other parts of the compiler, functions
264 -- outside the "main" parts of GHC return warnings and errors as a parameter
265 -- and signal success via by wrapping the result in a 'Maybe' type. This
266 -- function logs the returned warnings and propagates errors as exceptions
267 -- (of type 'SourceError').
268 --
269 -- This function assumes the following invariants:
270 --
271 -- 1. If the second result indicates success (is of the form 'Just x'),
272 -- there must be no error messages in the first result.
273 --
274 -- 2. If there are no error messages, but the second result indicates failure
275 -- there should be warnings in the first result. That is, if the action
276 -- failed, it must have been due to the warnings (i.e., @-Werror@).
277 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
278 ioMsgMaybe ioA = do
279 ((warns,errs), mb_r) <- liftIO ioA
280 logWarnings warns
281 case mb_r of
282 Nothing -> throwErrors errs
283 Just r -> ASSERT( isEmptyBag errs ) return r
284
285 -- | like ioMsgMaybe, except that we ignore error messages and return
286 -- 'Nothing' instead.
287 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
288 ioMsgMaybe' ioA = do
289 ((warns,_errs), mb_r) <- liftIO $ ioA
290 logWarnings warns
291 return mb_r
292
293 -- -----------------------------------------------------------------------------
294 -- | Lookup things in the compiler's environment
295
296 #ifdef GHCI
297 hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
298 hscTcRnLookupRdrName hsc_env0 rdr_name
299 = runInteractiveHsc hsc_env0 $
300 do { hsc_env <- getHscEnv
301 ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
302 #endif
303
304 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
305 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
306 hsc_env <- getHscEnv
307 ioMsgMaybe' $ tcRnLookupName hsc_env name
308 -- ignore errors: the only error we're likely to get is
309 -- "name not found", and the Maybe in the return type
310 -- is used to indicate that.
311
312 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst]))
313 hscTcRnGetInfo hsc_env0 name
314 = runInteractiveHsc hsc_env0 $
315 do { hsc_env <- getHscEnv
316 ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
317
318 #ifdef GHCI
319 hscIsGHCiMonad :: HscEnv -> String -> IO Name
320 hscIsGHCiMonad hsc_env name
321 = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
322
323 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
324 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
325 hsc_env <- getHscEnv
326 ioMsgMaybe $ getModuleInterface hsc_env mod
327
328 -- -----------------------------------------------------------------------------
329 -- | Rename some import declarations
330 hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv
331 hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
332 hsc_env <- getHscEnv
333 ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
334 #endif
335
336 -- -----------------------------------------------------------------------------
337 -- | parse a file, returning the abstract syntax
338
339 hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
340 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
341
342 -- internal version, that doesn't fail due to -Werror
343 hscParse' :: ModSummary -> Hsc HsParsedModule
344 hscParse' mod_summary = {-# SCC "Parser" #-}
345 withTiming getDynFlags
346 (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
347 (const ()) $ do
348 dflags <- getDynFlags
349 let src_filename = ms_hspp_file mod_summary
350 maybe_src_buf = ms_hspp_buf mod_summary
351
352 -------------------------- Parser ----------------
353 -- sometimes we already have the buffer in memory, perhaps
354 -- because we needed to parse the imports out of it, or get the
355 -- module name.
356 buf <- case maybe_src_buf of
357 Just b -> return b
358 Nothing -> liftIO $ hGetStringBuffer src_filename
359
360 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
361
362 case unP parseModule (mkPState dflags buf loc) of
363 PFailed span err ->
364 liftIO $ throwOneError (mkPlainErrMsg dflags span err)
365
366 POk pst rdr_module -> do
367 logWarningsReportErrors (getMessages pst dflags)
368 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
369 ppr rdr_module
370 liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
371 ppSourceStats False rdr_module
372
373 -- To get the list of extra source files, we take the list
374 -- that the parser gave us,
375 -- - eliminate files beginning with '<'. gcc likes to use
376 -- pseudo-filenames like "<built-in>" and "<command-line>"
377 -- - normalise them (elimiante differences between ./f and f)
378 -- - filter out the preprocessed source file
379 -- - filter out anything beginning with tmpdir
380 -- - remove duplicates
381 -- - filter out the .hs/.lhs source filename if we have one
382 --
383 let n_hspp = FilePath.normalise src_filename
384 srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
385 $ filter (not . (== n_hspp))
386 $ map FilePath.normalise
387 $ filter (not . (isPrefixOf "<"))
388 $ map unpackFS
389 $ srcfiles pst
390 srcs1 = case ml_hs_file (ms_location mod_summary) of
391 Just f -> filter (/= FilePath.normalise f) srcs0
392 Nothing -> srcs0
393
394 -- sometimes we see source files from earlier
395 -- preprocessing stages that cannot be found, so just
396 -- filter them out:
397 srcs2 <- liftIO $ filterM doesFileExist srcs1
398
399 return HsParsedModule {
400 hpm_module = rdr_module,
401 hpm_src_files = srcs2,
402 hpm_annotations
403 = (Map.fromListWith (++) $ annotations pst,
404 Map.fromList $ ((noSrcSpan,comment_q pst)
405 :(annotations_comments pst)))
406 }
407
408 -- XXX: should this really be a Maybe X? Check under which circumstances this
409 -- can become a Nothing and decide whether this should instead throw an
410 -- exception/signal an error.
411 type RenamedStuff =
412 (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
413 Maybe LHsDocString))
414
415 -- | Rename and typecheck a module, additionally returning the renamed syntax
416 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
417 -> IO (TcGblEnv, RenamedStuff)
418 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
419 tc_result <- tcRnModule' hsc_env mod_summary True rdr_module
420
421 -- This 'do' is in the Maybe monad!
422 let rn_info = do decl <- tcg_rn_decls tc_result
423 let imports = tcg_rn_imports tc_result
424 exports = tcg_rn_exports tc_result
425 doc_hdr = tcg_doc_hdr tc_result
426 return (decl,imports,exports,doc_hdr)
427
428 return (tc_result, rn_info)
429
430 -- wrapper around tcRnModule to handle safe haskell extras
431 tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule
432 -> Hsc TcGblEnv
433 tcRnModule' hsc_env sum save_rn_syntax mod = do
434 tcg_res <- {-# SCC "Typecheck-Rename" #-}
435 ioMsgMaybe $
436 tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod
437
438 -- See Note [Safe Haskell Overlapping Instances Implementation]
439 -- although this is used for more than just that failure case.
440 (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
441 dflags <- getDynFlags
442 let allSafeOK = safeInferred dflags && tcSafeOK
443
444 -- end of the safe haskell line, how to respond to user?
445 if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
446 -- if safe Haskell off or safe infer failed, mark unsafe
447 then markUnsafeInfer tcg_res whyUnsafe
448
449 -- module (could be) safe, throw warning if needed
450 else do
451 tcg_res' <- hscCheckSafeImports tcg_res
452 safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
453 when safe $ do
454 case wopt Opt_WarnSafe dflags of
455 True -> (logWarnings $ unitBag $
456 makeIntoWarning (Reason Opt_WarnSafe) $
457 mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
458 errSafe tcg_res')
459 False | safeHaskell dflags == Sf_Trustworthy &&
460 wopt Opt_WarnTrustworthySafe dflags ->
461 (logWarnings $ unitBag $
462 makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
463 mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
464 errTwthySafe tcg_res')
465 False -> return ()
466 return tcg_res'
467 where
468 pprMod t = ppr $ moduleName $ tcg_mod t
469 errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
470 errTwthySafe t = quotes (pprMod t)
471 <+> text "is marked as Trustworthy but has been inferred as safe!"
472
473 -- | Convert a typechecked module to Core
474 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
475 hscDesugar hsc_env mod_summary tc_result =
476 runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
477
478 hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
479 hscDesugar' mod_location tc_result = do
480 hsc_env <- getHscEnv
481 r <- ioMsgMaybe $
482 {-# SCC "deSugar" #-}
483 deSugar hsc_env mod_location tc_result
484
485 -- always check -Werror after desugaring, this is the last opportunity for
486 -- warnings to arise before the backend.
487 handleWarnings
488 return r
489
490 -- | Make a 'ModDetails' from the results of typechecking. Used when
491 -- typechecking only, as opposed to full compilation.
492 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
493 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
494
495
496 {- **********************************************************************
497 %* *
498 The main compiler pipeline
499 %* *
500 %********************************************************************* -}
501
502 {-
503 --------------------------------
504 The compilation proper
505 --------------------------------
506
507 It's the task of the compilation proper to compile Haskell, hs-boot and core
508 files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all
509 (the module is still parsed and type-checked. This feature is mostly used by
510 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
511 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
512 mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
513 targets byte-code.
514
515 The modes are kept separate because of their different types and meanings:
516
517 * In 'one-shot' mode, we're only compiling a single file and can therefore
518 discard the new ModIface and ModDetails. This is also the reason it only
519 targets hard-code; compiling to byte-code or nothing doesn't make sense when
520 we discard the result.
521
522 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
523 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
524 return the newly compiled byte-code.
525
526 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
527 kept separate. This is because compiling to nothing is fairly special: We
528 don't output any interface files, we don't run the simplifier and we don't
529 generate any code.
530
531 * 'Interactive' mode is similar to 'batch' mode except that we return the
532 compiled byte-code together with the ModIface and ModDetails.
533
534 Trying to compile a hs-boot file to byte-code will result in a run-time error.
535 This is the only thing that isn't caught by the type-system.
536 -}
537
538
539 type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
540
541 -- | This function runs GHC's frontend with recompilation
542 -- avoidance. Specifically, it checks if recompilation is needed,
543 -- and if it is, it parses and typechecks the input module.
544 -- It does not write out the results of typechecking (See
545 -- compileOne and hscIncrementalCompile).
546 hscIncrementalFrontend :: Bool -- always do basic recompilation check?
547 -> Maybe TcGblEnv
548 -> Maybe Messager
549 -> ModSummary
550 -> SourceModified
551 -> Maybe ModIface -- Old interface, if available
552 -> (Int,Int) -- (i,n) = module i of n (for msgs)
553 -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
554
555 hscIncrementalFrontend
556 always_do_basic_recompilation_check m_tc_result
557 mHscMessage mod_summary source_modified mb_old_iface mod_index
558 = do
559 hsc_env <- getHscEnv
560
561 let msg what = case mHscMessage of
562 Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
563 Nothing -> return ()
564
565 skip iface = do
566 liftIO $ msg UpToDate
567 return $ Left iface
568
569 compile mb_old_hash reason = do
570 liftIO $ msg reason
571 result <- genericHscFrontend mod_summary
572 return $ Right (result, mb_old_hash)
573
574 stable = case source_modified of
575 SourceUnmodifiedAndStable -> True
576 _ -> False
577
578 case m_tc_result of
579 Just tc_result
580 | not always_do_basic_recompilation_check ->
581 return $ Right (FrontendTypecheck tc_result, Nothing)
582 _ -> do
583 (recomp_reqd, mb_checked_iface)
584 <- {-# SCC "checkOldIface" #-}
585 liftIO $ checkOldIface hsc_env mod_summary
586 source_modified mb_old_iface
587 -- save the interface that comes back from checkOldIface.
588 -- In one-shot mode we don't have the old iface until this
589 -- point, when checkOldIface reads it from the disk.
590 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
591
592 case mb_checked_iface of
593 Just iface | not (recompileRequired recomp_reqd) ->
594 -- If the module used TH splices when it was last
595 -- compiled, then the recompilation check is not
596 -- accurate enough (#481) and we must ignore
597 -- it. However, if the module is stable (none of
598 -- the modules it depends on, directly or
599 -- indirectly, changed), then we *can* skip
600 -- recompilation. This is why the SourceModified
601 -- type contains SourceUnmodifiedAndStable, and
602 -- it's pretty important: otherwise ghc --make
603 -- would always recompile TH modules, even if
604 -- nothing at all has changed. Stability is just
605 -- the same check that make is doing for us in
606 -- one-shot mode.
607 case m_tc_result of
608 Nothing
609 | mi_used_th iface && not stable ->
610 compile mb_old_hash (RecompBecause "TH")
611 _ ->
612 skip iface
613 _ ->
614 case m_tc_result of
615 Nothing -> compile mb_old_hash recomp_reqd
616 Just tc_result ->
617 return $ Right (FrontendTypecheck tc_result, mb_old_hash)
618
619 genericHscFrontend :: ModSummary -> Hsc FrontendResult
620 genericHscFrontend mod_summary =
621 getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
622
623 genericHscFrontend' :: ModSummary -> Hsc FrontendResult
624 genericHscFrontend' mod_summary
625 = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary
626
627 --------------------------------------------------------------
628 -- Compilers
629 --------------------------------------------------------------
630
631 -- Compile Haskell/boot in OneShot mode.
632 hscIncrementalCompile :: Bool
633 -> Maybe TcGblEnv
634 -> Maybe Messager
635 -> HscEnv
636 -> ModSummary
637 -> SourceModified
638 -> Maybe ModIface
639 -> (Int,Int)
640 -- HomeModInfo does not contain linkable, since we haven't
641 -- code-genned yet
642 -> IO (HscStatus, HomeModInfo)
643 hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
644 mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
645 = do
646 -- One-shot mode needs a knot-tying mutable variable for interface
647 -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
648 type_env_var <- newIORef emptyNameEnv
649 let mod = ms_mod mod_summary
650 hsc_env = hsc_env'{ hsc_type_env_var = Just (mod, type_env_var) }
651
652 -- NB: enter Hsc monad here so that we don't bail out early with
653 -- -Werror on typechecker warnings; we also want to run the desugarer
654 -- to get those warnings too. (But we'll always exit at that point
655 -- because the desugarer runs ioMsgMaybe.)
656 runHsc hsc_env $ do
657 let dflags = hsc_dflags hsc_env
658
659 e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage
660 mod_summary source_modified mb_old_iface mod_index
661 case e of
662 Left iface -> do
663 details <- liftIO $ genModDetails hsc_env iface
664 return (HscUpToDate, HomeModInfo{
665 hm_details = details,
666 hm_iface = iface,
667 hm_linkable = Nothing
668 })
669 Right (FrontendTypecheck tc_result, mb_old_hash) -> do
670 (status, hmi, no_change) <-
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 (text "genModDetails") 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_verbose "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 "hscCompileCmmFile: no_mod"
1348 no_loc = ModLocation{ ml_hs_file = Just filename,
1349 ml_hi_file = panic "hscCompileCmmFile: no hi file",
1350 ml_obj_file = panic "hscCompileCmmFile: 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_from_stg
1377 "Cmm produced by 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
1411 "Output Cmm" (ppr a)
1412 return a
1413
1414 ppr_stream2 = Stream.mapM dump2 pipeline_stream
1415
1416 return ppr_stream2
1417
1418
1419
1420 myCoreToStg :: DynFlags -> Module -> CoreProgram
1421 -> IO ( [StgBinding] -- output program
1422 , CollectedCCs) -- cost centre info (declared and used)
1423 myCoreToStg dflags this_mod prepd_binds = do
1424 let stg_binds
1425 = {-# SCC "Core2Stg" #-}
1426 coreToStg dflags this_mod prepd_binds
1427
1428 (stg_binds2, cost_centre_info)
1429 <- {-# SCC "Stg2Stg" #-}
1430 stg2stg dflags this_mod stg_binds
1431
1432 return (stg_binds2, cost_centre_info)
1433
1434
1435 {- **********************************************************************
1436 %* *
1437 \subsection{Compiling a do-statement}
1438 %* *
1439 %********************************************************************* -}
1440
1441 {-
1442 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1443 you run it you get a list of HValues that should be the same length as the list
1444 of names; add them to the ClosureEnv.
1445
1446 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1447 IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
1448 -}
1449
1450 #ifdef GHCI
1451 -- | Compile a stmt all the way to an HValue, but don't run it
1452 --
1453 -- We return Nothing to indicate an empty statement (or comment only), not a
1454 -- parse error.
1455 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
1456 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1457
1458 -- | Compile a stmt all the way to an HValue, but don't run it
1459 --
1460 -- We return Nothing to indicate an empty statement (or comment only), not a
1461 -- parse error.
1462 hscStmtWithLocation :: HscEnv
1463 -> String -- ^ The statement
1464 -> String -- ^ The source
1465 -> Int -- ^ Starting line
1466 -> IO ( Maybe ([Id]
1467 , ForeignHValue {- IO [HValue] -}
1468 , FixityEnv))
1469 hscStmtWithLocation hsc_env0 stmt source linenumber =
1470 runInteractiveHsc hsc_env0 $ do
1471 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1472 case maybe_stmt of
1473 Nothing -> return Nothing
1474
1475 Just parsed_stmt -> do
1476 hsc_env <- getHscEnv
1477 liftIO $ hscParsedStmt hsc_env parsed_stmt
1478
1479 hscParsedStmt :: HscEnv
1480 -> GhciLStmt RdrName -- ^ The parsed statement
1481 -> IO ( Maybe ([Id]
1482 , ForeignHValue {- IO [HValue] -}
1483 , FixityEnv))
1484 hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
1485 -- Rename and typecheck it
1486 (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
1487
1488 -- Desugar it
1489 ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
1490 liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
1491 handleWarnings
1492
1493 -- Then code-gen, and link it
1494 -- It's important NOT to have package 'interactive' as thisUnitId
1495 -- for linking, else we try to link 'main' and can't find it.
1496 -- Whereas the linker already knows to ignore 'interactive'
1497 let src_span = srcLocSpan interactiveSrcLoc
1498 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1499
1500 return $ Just (ids, hval, fix_env)
1501
1502 -- | Compile a decls
1503 hscDecls :: HscEnv
1504 -> String -- ^ The statement
1505 -> IO ([TyThing], InteractiveContext)
1506 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1507
1508 -- | Compile a decls
1509 hscDeclsWithLocation :: HscEnv
1510 -> String -- ^ The statement
1511 -> String -- ^ The source
1512 -> Int -- ^ Starting line
1513 -> IO ([TyThing], InteractiveContext)
1514 hscDeclsWithLocation hsc_env0 str source linenumber =
1515 runInteractiveHsc hsc_env0 $ do
1516 L _ (HsModule{ hsmodDecls = decls }) <-
1517 hscParseThingWithLocation source linenumber parseModule str
1518
1519 {- Rename and typecheck it -}
1520 hsc_env <- getHscEnv
1521 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
1522
1523 {- Grab the new instances -}
1524 -- We grab the whole environment because of the overlapping that may have
1525 -- been done. See the notes at the definition of InteractiveContext
1526 -- (ic_instances) for more details.
1527 let defaults = tcg_default tc_gblenv
1528
1529 {- Desugar it -}
1530 -- We use a basically null location for iNTERACTIVE
1531 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1532 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1533 ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
1534 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1535
1536 {- Simplify -}
1537 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1538
1539 {- Tidy -}
1540 (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1541
1542 let !CgGuts{ cg_module = this_mod,
1543 cg_binds = core_binds,
1544 cg_tycons = tycons,
1545 cg_modBreaks = mod_breaks } = tidy_cg
1546
1547 !ModDetails { md_insts = cls_insts
1548 , md_fam_insts = fam_insts } = mod_details
1549 -- Get the *tidied* cls_insts and fam_insts
1550
1551 data_tycons = filter isDataTyCon tycons
1552
1553 {- Prepare For Code Generation -}
1554 -- Do saturation and convert to A-normal form
1555 prepd_binds <- {-# SCC "CorePrep" #-}
1556 liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
1557
1558 {- Generate byte code -}
1559 cbc <- liftIO $ byteCodeGen hsc_env this_mod
1560 prepd_binds data_tycons mod_breaks
1561
1562 let src_span = srcLocSpan interactiveSrcLoc
1563 liftIO $ linkDecls hsc_env src_span cbc
1564
1565 let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
1566 patsyns = mg_patsyns simpl_mg
1567
1568 ext_ids = [ id | id <- bindersOfBinds core_binds
1569 , isExternalName (idName id)
1570 , not (isDFunId id || isImplicitId id) ]
1571 -- We only need to keep around the external bindings
1572 -- (as decided by TidyPgm), since those are the only ones
1573 -- that might later be looked up by name. But we can exclude
1574 -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
1575 -- - Implicit Ids, which are implicit in tcs
1576 -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv
1577
1578 new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
1579 ictxt = hsc_IC hsc_env
1580 -- See Note [Fixity declarations in GHCi]
1581 fix_env = tcg_fix_env tc_gblenv
1582 new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
1583 fam_insts defaults fix_env
1584 return (new_tythings, new_ictxt)
1585
1586
1587 {-
1588 Note [Fixity declarations in GHCi]
1589 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1590
1591 To support fixity declarations on types defined within GHCi (as requested
1592 in #10018) we record the fixity environment in InteractiveContext.
1593 When we want to evaluate something TcRnDriver.runTcInteractive pulls out this
1594 fixity environment and uses it to initialize the global typechecker environment.
1595 After the typechecker has finished its business, an updated fixity environment
1596 (reflecting whatever fixity declarations were present in the statements we
1597 passed it) will be returned from hscParsedStmt. This is passed to
1598 updateFixityEnv, which will stuff it back into InteractiveContext, to be
1599 used in evaluating the next statement.
1600
1601 -}
1602
1603 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1604 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1605 (L _ (HsModule{hsmodImports=is})) <-
1606 hscParseThing parseModule str
1607 case is of
1608 [L _ i] -> return i
1609 _ -> liftIO $ throwOneError $
1610 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
1611 text "parse error in import declaration"
1612
1613 -- | Typecheck an expression (but don't run it)
1614 hscTcExpr :: HscEnv
1615 -> TcRnExprMode
1616 -> String -- ^ The expression
1617 -> IO Type
1618 hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
1619 hsc_env <- getHscEnv
1620 parsed_expr <- hscParseExpr expr
1621 ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
1622
1623 -- | Find the kind of a type
1624 -- Currently this does *not* generalise the kinds of the type
1625 hscKcType
1626 :: HscEnv
1627 -> Bool -- ^ Normalise the type
1628 -> String -- ^ The type as a string
1629 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1630 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1631 hsc_env <- getHscEnv
1632 ty <- hscParseType str
1633 ioMsgMaybe $ tcRnType hsc_env normalise ty
1634
1635 hscParseExpr :: String -> Hsc (LHsExpr RdrName)
1636 hscParseExpr expr = do
1637 hsc_env <- getHscEnv
1638 maybe_stmt <- hscParseStmt expr
1639 case maybe_stmt of
1640 Just (L _ (BodyStmt expr _ _ _)) -> return expr
1641 _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
1642 (text "not an expression:" <+> quotes (text expr))
1643
1644 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
1645 hscParseStmt = hscParseThing parseStmt
1646
1647 hscParseStmtWithLocation :: String -> Int -> String
1648 -> Hsc (Maybe (GhciLStmt RdrName))
1649 hscParseStmtWithLocation source linenumber stmt =
1650 hscParseThingWithLocation source linenumber parseStmt stmt
1651
1652 hscParseType :: String -> Hsc (LHsType RdrName)
1653 hscParseType = hscParseThing parseType
1654 #endif
1655
1656 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1657 hscParseIdentifier hsc_env str =
1658 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1659
1660 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1661 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1662
1663 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1664 -> Lexer.P thing -> String -> Hsc thing
1665 hscParseThingWithLocation source linenumber parser str
1666 = withTiming getDynFlags
1667 (text "Parser [source]")
1668 (const ()) $ {-# SCC "Parser" #-} do
1669 dflags <- getDynFlags
1670
1671 let buf = stringToStringBuffer str
1672 loc = mkRealSrcLoc (fsLit source) linenumber 1
1673
1674 case unP parser (mkPState dflags buf loc) of
1675 PFailed span err -> do
1676 let msg = mkPlainErrMsg dflags span err
1677 throwErrors $ unitBag msg
1678
1679 POk pst thing -> do
1680 logWarningsReportErrors (getMessages pst dflags)
1681 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1682 return thing
1683
1684
1685 {- **********************************************************************
1686 %* *
1687 Desugar, simplify, convert to bytecode, and link an expression
1688 %* *
1689 %********************************************************************* -}
1690
1691 #ifdef GHCI
1692 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
1693 hscCompileCoreExpr hsc_env =
1694 lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
1695
1696 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
1697 hscCompileCoreExpr' hsc_env srcspan ds_expr
1698 = do { let dflags = hsc_dflags hsc_env
1699
1700 {- Simplify it -}
1701 ; simpl_expr <- simplifyExpr dflags ds_expr
1702
1703 {- Tidy it (temporary, until coreSat does cloning) -}
1704 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1705
1706 {- Prepare for codegen -}
1707 ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
1708
1709 {- Lint if necessary -}
1710 ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
1711
1712 {- Convert to BCOs -}
1713 ; bcos <- coreExprToBCOs hsc_env
1714 (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
1715
1716 {- link it -}
1717 ; hval <- linkExpr hsc_env srcspan bcos
1718
1719 ; return hval }
1720 #endif
1721
1722
1723 {- **********************************************************************
1724 %* *
1725 Statistics on reading interfaces
1726 %* *
1727 %********************************************************************* -}
1728
1729 dumpIfaceStats :: HscEnv -> IO ()
1730 dumpIfaceStats hsc_env = do
1731 eps <- readIORef (hsc_EPS hsc_env)
1732 dumpIfSet dflags (dump_if_trace || dump_rn_stats)
1733 "Interface statistics"
1734 (ifaceStats eps)
1735 where
1736 dflags = hsc_dflags hsc_env
1737 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1738 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1739
1740
1741 {- **********************************************************************
1742 %* *
1743 Progress Messages: Module i of n
1744 %* *
1745 %********************************************************************* -}
1746
1747 showModuleIndex :: (Int, Int) -> String
1748 showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1749 where
1750 n_str = show n
1751 i_str = show i
1752 padded = replicate (length n_str - length i_str) ' ' ++ i_str