Fix #10963 and #11975 by adding new cmds to GHCi.
[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, TcRnExprMode(..), 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 (FrontendTypecheck tc_result, mb_old_hash) -> do
669 (status, hmi, no_change) <-
670 if hscTarget dflags /= HscNothing &&
671 ms_hsc_src mod_summary == HsSrcFile
672 then finish hsc_env mod_summary tc_result mb_old_hash
673 else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash
674 liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary
675 return (status, hmi)
676
677 -- Generates and writes out the final interface for a typecheck.
678 finishTypecheckOnly :: HscEnv
679 -> ModSummary
680 -> TcGblEnv
681 -> Maybe Fingerprint
682 -> Hsc (HscStatus, HomeModInfo, Bool)
683 finishTypecheckOnly hsc_env summary tc_result mb_old_hash = do
684 let dflags = hsc_dflags hsc_env
685 (iface, changed, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash
686 let hsc_status =
687 case (hscTarget dflags, ms_hsc_src summary) of
688 (HscNothing, _) -> HscNotGeneratingCode
689 (_, HsBootFile) -> HscUpdateBoot
690 (_, HsigFile) -> HscUpdateSig
691 _ -> panic "finishTypecheckOnly"
692 return (hsc_status,
693 HomeModInfo{ hm_details = details,
694 hm_iface = iface,
695 hm_linkable = Nothing },
696 changed)
697
698 -- Runs the post-typechecking frontend (desugar and simplify),
699 -- and then generates and writes out the final interface. We want
700 -- to write the interface AFTER simplification so we can get
701 -- as up-to-date and good unfoldings and other info as possible
702 -- in the interface file. This is only ever run for HsSrcFile,
703 -- and NOT for HscNothing.
704 finish :: HscEnv
705 -> ModSummary
706 -> TcGblEnv
707 -> Maybe Fingerprint
708 -> Hsc (HscStatus, HomeModInfo, Bool)
709 finish hsc_env summary tc_result mb_old_hash = do
710 let dflags = hsc_dflags hsc_env
711 MASSERT( ms_hsc_src summary == HsSrcFile )
712 MASSERT( hscTarget dflags /= HscNothing )
713 guts0 <- hscDesugar' (ms_location summary) tc_result
714 guts <- hscSimplify' guts0
715 (iface, changed, details, cgguts) <- liftIO $ hscNormalIface hsc_env guts mb_old_hash
716
717 return (HscRecomp cgguts summary,
718 HomeModInfo{ hm_details = details,
719 hm_iface = iface,
720 hm_linkable = Nothing },
721 changed)
722
723 hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
724 hscMaybeWriteIface dflags iface changed summary =
725 let force_write_interface = gopt Opt_WriteInterface dflags
726 write_interface = case hscTarget dflags of
727 HscNothing -> False
728 HscInterpreted -> False
729 _ -> True
730 in when (write_interface || force_write_interface) $
731 hscWriteIface dflags iface changed summary
732
733 --------------------------------------------------------------
734 -- NoRecomp handlers
735 --------------------------------------------------------------
736
737 genModDetails :: HscEnv -> ModIface -> IO ModDetails
738 genModDetails hsc_env old_iface
739 = do
740 new_details <- {-# SCC "tcRnIface" #-}
741 initIfaceCheck hsc_env (typecheckIface old_iface)
742 dumpIfaceStats hsc_env
743 return new_details
744
745 --------------------------------------------------------------
746 -- Progress displayers.
747 --------------------------------------------------------------
748
749 oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
750 oneShotMsg hsc_env recomp =
751 case recomp of
752 UpToDate ->
753 compilationProgressMsg (hsc_dflags hsc_env) $
754 "compilation IS NOT required"
755 _ ->
756 return ()
757
758 batchMsg :: Messager
759 batchMsg hsc_env mod_index recomp mod_summary =
760 case recomp of
761 MustCompile -> showMsg "Compiling " ""
762 UpToDate
763 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
764 | otherwise -> return ()
765 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
766 where
767 dflags = hsc_dflags hsc_env
768 showMsg msg reason =
769 compilationProgressMsg dflags $
770 (showModuleIndex mod_index ++
771 msg ++ showModMsg dflags (hscTarget dflags)
772 (recompileRequired recomp) mod_summary)
773 ++ reason
774
775 --------------------------------------------------------------
776 -- FrontEnds
777 --------------------------------------------------------------
778
779 -- | Given a 'ModSummary', parses and typechecks it, returning the
780 -- 'TcGblEnv' resulting from type-checking.
781 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
782 hscFileFrontEnd mod_summary = do
783 hpm <- hscParse' mod_summary
784 hsc_env <- getHscEnv
785 tcg_env <- tcRnModule' hsc_env mod_summary False hpm
786 return tcg_env
787
788 --------------------------------------------------------------
789 -- Safe Haskell
790 --------------------------------------------------------------
791
792 -- Note [Safe Haskell Trust Check]
793 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
794 -- Safe Haskell checks that an import is trusted according to the following
795 -- rules for an import of module M that resides in Package P:
796 --
797 -- * If M is recorded as Safe and all its trust dependencies are OK
798 -- then M is considered safe.
799 -- * If M is recorded as Trustworthy and P is considered trusted and
800 -- all M's trust dependencies are OK then M is considered safe.
801 --
802 -- By trust dependencies we mean that the check is transitive. So if
803 -- a module M that is Safe relies on a module N that is trustworthy,
804 -- importing module M will first check (according to the second case)
805 -- that N is trusted before checking M is trusted.
806 --
807 -- This is a minimal description, so please refer to the user guide
808 -- for more details. The user guide is also considered the authoritative
809 -- source in this matter, not the comments or code.
810
811
812 -- Note [Safe Haskell Inference]
813 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
814 -- Safe Haskell does Safe inference on modules that don't have any specific
815 -- safe haskell mode flag. The basic approach to this is:
816 -- * When deciding if we need to do a Safe language check, treat
817 -- an unmarked module as having -XSafe mode specified.
818 -- * For checks, don't throw errors but return them to the caller.
819 -- * Caller checks if there are errors:
820 -- * For modules explicitly marked -XSafe, we throw the errors.
821 -- * For unmarked modules (inference mode), we drop the errors
822 -- and mark the module as being Unsafe.
823 --
824 -- It used to be that we only did safe inference on modules that had no Safe
825 -- Haskell flags, but now we perform safe inference on all modules as we want
826 -- to allow users to set the `-Wsafe`, `-Wunsafe` and
827 -- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a
828 -- user can ensure their assumptions are correct and see reasons for why a
829 -- module is safe or unsafe.
830 --
831 -- This is tricky as we must be careful when we should throw an error compared
832 -- to just warnings. For checking safe imports we manage it as two steps. First
833 -- we check any imports that are required to be safe, then we check all other
834 -- imports to see if we can infer them to be safe.
835
836
837 -- | Check that the safe imports of the module being compiled are valid.
838 -- If not we either issue a compilation error if the module is explicitly
839 -- using Safe Haskell, or mark the module as unsafe if we're in safe
840 -- inference mode.
841 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
842 hscCheckSafeImports tcg_env = do
843 dflags <- getDynFlags
844 tcg_env' <- checkSafeImports dflags tcg_env
845 checkRULES dflags tcg_env'
846
847 where
848 checkRULES dflags tcg_env' = do
849 case safeLanguageOn dflags of
850 True -> do
851 -- XSafe: we nuke user written RULES
852 logWarnings $ warns dflags (tcg_rules tcg_env')
853 return tcg_env' { tcg_rules = [] }
854 False
855 -- SafeInferred: user defined RULES, so not safe
856 | safeInferOn dflags && not (null $ tcg_rules tcg_env')
857 -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
858
859 -- Trustworthy OR SafeInferred: with no RULES
860 | otherwise
861 -> return tcg_env'
862
863 warns dflags rules = listToBag $ map (warnRules dflags) rules
864 warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
865 mkPlainWarnMsg dflags loc $
866 text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
867 text "User defined rules are disabled under Safe Haskell"
868
869 -- | Validate that safe imported modules are actually safe. For modules in the
870 -- HomePackage (the package the module we are compiling in resides) this just
871 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
872 -- that reside in another package we also must check that the external pacakge
873 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
874 -- information.
875 --
876 -- The code for this is quite tricky as the whole algorithm is done in a few
877 -- distinct phases in different parts of the code base. See
878 -- RnNames.rnImportDecl for where package trust dependencies for a module are
879 -- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
880 -- Transitively] and the Note [RnNames . Trust Own Package].
881 checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
882 checkSafeImports dflags tcg_env
883 = do
884 imps <- mapM condense imports'
885 let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
886
887 -- We want to use the warning state specifically for detecting if safe
888 -- inference has failed, so store and clear any existing warnings.
889 oldErrs <- getWarnings
890 clearWarnings
891
892 -- Check safe imports are correct
893 safePkgs <- mapM checkSafe safeImps
894 safeErrs <- getWarnings
895 clearWarnings
896
897 -- Check non-safe imports are correct if inferring safety
898 -- See the Note [Safe Haskell Inference]
899 (infErrs, infPkgs) <- case (safeInferOn dflags) of
900 False -> return (emptyBag, [])
901 True -> do infPkgs <- mapM checkSafe regImps
902 infErrs <- getWarnings
903 clearWarnings
904 return (infErrs, infPkgs)
905
906 -- restore old errors
907 logWarnings oldErrs
908
909 case (isEmptyBag safeErrs) of
910 -- Failed safe check
911 False -> liftIO . throwIO . mkSrcErr $ safeErrs
912
913 -- Passed safe check
914 True -> do
915 let infPassed = isEmptyBag infErrs
916 tcg_env' <- case (not infPassed) of
917 True -> markUnsafeInfer tcg_env infErrs
918 False -> return tcg_env
919 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs
920 let newTrust = pkgTrustReqs safePkgs infPkgs infPassed
921 return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
922
923 where
924 impInfo = tcg_imports tcg_env -- ImportAvails
925 imports = imp_mods impInfo -- ImportedMods
926 imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
927 pkgReqs = imp_trust_pkgs impInfo -- [UnitId]
928
929 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
930 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
931 condense (m, x:xs) = do imv <- foldlM cond' x xs
932 return (m, imv_span imv, imv_is_safe imv)
933
934 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
935 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
936 cond' v1 v2
937 | imv_is_safe v1 /= imv_is_safe v2
938 = throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
939 (text "Module" <+> ppr (imv_name v1) <+>
940 (text $ "is imported both as a safe and unsafe import!"))
941 | otherwise
942 = return v1
943
944 -- easier interface to work with
945 checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
946
947 -- what pkg's to add to our trust requirements
948 pkgTrustReqs req inf infPassed | safeInferOn dflags
949 && safeHaskell dflags == Sf_None && infPassed
950 = emptyImportAvails {
951 imp_trust_pkgs = catMaybes req ++ catMaybes inf
952 }
953 pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe
954 = emptyImportAvails
955 pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req }
956
957 -- | Check that a module is safe to import.
958 --
959 -- We return True to indicate the import is safe and False otherwise
960 -- although in the False case an exception may be thrown first.
961 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
962 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
963 dflags <- getDynFlags
964 pkgs <- snd `fmap` hscCheckSafe' dflags m l
965 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
966 errs <- getWarnings
967 return $ isEmptyBag errs
968
969 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
970 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [UnitId])
971 hscGetSafe hsc_env m l = runHsc hsc_env $ do
972 dflags <- getDynFlags
973 (self, pkgs) <- hscCheckSafe' dflags m l
974 good <- isEmptyBag `fmap` getWarnings
975 clearWarnings -- don't want them printed...
976 let pkgs' | Just p <- self = p:pkgs
977 | otherwise = pkgs
978 return (good, pkgs')
979
980 -- | Is a module trusted? If not, throw or log errors depending on the type.
981 -- Return (regardless of trusted or not) if the trust type requires the modules
982 -- own package be trusted and a list of other packages required to be trusted
983 -- (these later ones haven't been checked) but the own package trust has been.
984 hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe UnitId, [UnitId])
985 hscCheckSafe' dflags m l = do
986 (tw, pkgs) <- isModSafe m l
987 case tw of
988 False -> return (Nothing, pkgs)
989 True | isHomePkg m -> return (Nothing, pkgs)
990 | otherwise -> return (Just $ moduleUnitId m, pkgs)
991 where
992 isModSafe :: Module -> SrcSpan -> Hsc (Bool, [UnitId])
993 isModSafe m l = do
994 iface <- lookup' m
995 case iface of
996 -- can't load iface to check trust!
997 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
998 $ text "Can't load the interface file for" <+> ppr m
999 <> text ", to check that it can be safely imported"
1000
1001 -- got iface, check trust
1002 Just iface' ->
1003 let trust = getSafeMode $ mi_trust iface'
1004 trust_own_pkg = mi_trust_pkg iface'
1005 -- check module is trusted
1006 safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
1007 -- check package is trusted
1008 safeP = packageTrusted trust trust_own_pkg m
1009 -- pkg trust reqs
1010 pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
1011 -- General errors we throw but Safe errors we log
1012 errs = case (safeM, safeP) of
1013 (True, True ) -> emptyBag
1014 (True, False) -> pkgTrustErr
1015 (False, _ ) -> modTrustErr
1016 in do
1017 logWarnings errs
1018 return (trust == Sf_Trustworthy, pkgRs)
1019
1020 where
1021 pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
1022 sep [ ppr (moduleName m)
1023 <> text ": Can't be safely imported!"
1024 , text "The package (" <> ppr (moduleUnitId m)
1025 <> text ") the module resides in isn't trusted."
1026 ]
1027 modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
1028 sep [ ppr (moduleName m)
1029 <> text ": Can't be safely imported!"
1030 , text "The module itself isn't safe." ]
1031
1032 -- | Check the package a module resides in is trusted. Safe compiled
1033 -- modules are trusted without requiring that their package is trusted. For
1034 -- trustworthy modules, modules in the home package are trusted but
1035 -- otherwise we check the package trust flag.
1036 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
1037 packageTrusted Sf_None _ _ = False -- shouldn't hit these cases
1038 packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness.
1039 packageTrusted _ _ _
1040 | not (packageTrustOn dflags) = True
1041 packageTrusted Sf_Safe False _ = True
1042 packageTrusted _ _ m
1043 | isHomePkg m = True
1044 | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
1045
1046 lookup' :: Module -> Hsc (Maybe ModIface)
1047 lookup' m = do
1048 hsc_env <- getHscEnv
1049 hsc_eps <- liftIO $ hscEPS hsc_env
1050 let pkgIfaceT = eps_PIT hsc_eps
1051 homePkgT = hsc_HPT hsc_env
1052 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
1053 #ifdef GHCI
1054 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
1055 -- as the compiler hasn't filled in the various module tables
1056 -- so we need to call 'getModuleInterface' to load from disk
1057 iface' <- case iface of
1058 Just _ -> return iface
1059 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
1060 return iface'
1061 #else
1062 return iface
1063 #endif
1064
1065
1066 isHomePkg :: Module -> Bool
1067 isHomePkg m
1068 | thisPackage dflags == moduleUnitId m = True
1069 | otherwise = False
1070
1071 -- | Check the list of packages are trusted.
1072 checkPkgTrust :: DynFlags -> [UnitId] -> Hsc ()
1073 checkPkgTrust dflags pkgs =
1074 case errors of
1075 [] -> return ()
1076 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1077 where
1078 errors = catMaybes $ map go pkgs
1079 go pkg
1080 | trusted $ getPackageDetails dflags pkg
1081 = Nothing
1082 | otherwise
1083 = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
1084 $ text "The package (" <> ppr pkg <> text ") is required" <>
1085 text " to be trusted but it isn't!"
1086
1087 -- | Set module to unsafe and (potentially) wipe trust information.
1088 --
1089 -- Make sure to call this method to set a module to inferred unsafe, it should
1090 -- be a central and single failure method. We only wipe the trust information
1091 -- when we aren't in a specific Safe Haskell mode.
1092 --
1093 -- While we only use this for recording that a module was inferred unsafe, we
1094 -- may call it on modules using Trustworthy or Unsafe flags so as to allow
1095 -- warning flags for safety to function correctly. See Note [Safe Haskell
1096 -- Inference].
1097 markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1098 markUnsafeInfer tcg_env whyUnsafe = do
1099 dflags <- getDynFlags
1100
1101 when (wopt Opt_WarnUnsafe dflags)
1102 (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $
1103 mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
1104
1105 liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
1106 -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other
1107 -- times inference may be on but we are in Trustworthy mode -- so we want
1108 -- to record safe-inference failed but not wipe the trust dependencies.
1109 case safeHaskell dflags == Sf_None of
1110 True -> return $ tcg_env { tcg_imports = wiped_trust }
1111 False -> return tcg_env
1112
1113 where
1114 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
1115 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1116 whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
1117 , text "Reason:"
1118 , nest 4 $ (vcat $ badFlags df) $+$
1119 (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
1120 (vcat $ badInsts $ tcg_insts tcg_env)
1121 ]
1122 badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer
1123 badFlag df (str,loc,on,_)
1124 | on df = [mkLocMessage SevOutput (loc df) $
1125 text str <+> text "is not allowed in Safe Haskell"]
1126 | otherwise = []
1127 badInsts insts = concat $ map badInst insts
1128
1129 checkOverlap (NoOverlap _) = False
1130 checkOverlap _ = True
1131
1132 badInst ins | checkOverlap (overlapMode (is_flag ins))
1133 = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
1134 ppr (overlapMode $ is_flag ins) <+>
1135 text "overlap mode isn't allowed in Safe Haskell"]
1136 | otherwise = []
1137
1138
1139 -- | Figure out the final correct safe haskell mode
1140 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
1141 hscGetSafeMode tcg_env = do
1142 dflags <- getDynFlags
1143 liftIO $ finalSafeMode dflags tcg_env
1144
1145 --------------------------------------------------------------
1146 -- Simplifiers
1147 --------------------------------------------------------------
1148
1149 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1150 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1151
1152 hscSimplify' :: ModGuts -> Hsc ModGuts
1153 hscSimplify' ds_result = do
1154 hsc_env <- getHscEnv
1155 {-# SCC "Core2Core" #-}
1156 liftIO $ core2core hsc_env ds_result
1157
1158 --------------------------------------------------------------
1159 -- Interface generators
1160 --------------------------------------------------------------
1161
1162 hscSimpleIface :: HscEnv
1163 -> TcGblEnv
1164 -> Maybe Fingerprint
1165 -> IO (ModIface, Bool, ModDetails)
1166 hscSimpleIface hsc_env tc_result mb_old_iface
1167 = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
1168
1169 hscSimpleIface' :: TcGblEnv
1170 -> Maybe Fingerprint
1171 -> Hsc (ModIface, Bool, ModDetails)
1172 hscSimpleIface' tc_result mb_old_iface = do
1173 hsc_env <- getHscEnv
1174 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1175 safe_mode <- hscGetSafeMode tc_result
1176 (new_iface, no_change)
1177 <- {-# SCC "MkFinalIface" #-}
1178 liftIO $
1179 mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
1180 -- And the answer is ...
1181 liftIO $ dumpIfaceStats hsc_env
1182 return (new_iface, no_change, details)
1183
1184 hscNormalIface :: HscEnv
1185 -> ModGuts
1186 -> Maybe Fingerprint
1187 -> IO (ModIface, Bool, ModDetails, CgGuts)
1188 hscNormalIface hsc_env simpl_result mb_old_iface =
1189 runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
1190
1191 hscNormalIface' :: ModGuts
1192 -> Maybe Fingerprint
1193 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1194 hscNormalIface' simpl_result mb_old_iface = do
1195 hsc_env <- getHscEnv
1196 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1197 liftIO $ tidyProgram hsc_env simpl_result
1198
1199 -- BUILD THE NEW ModIface and ModDetails
1200 -- and emit external core if necessary
1201 -- This has to happen *after* code gen so that the back-end
1202 -- info has been set. Not yet clear if it matters waiting
1203 -- until after code output
1204 (new_iface, no_change)
1205 <- {-# SCC "MkFinalIface" #-}
1206 liftIO $
1207 mkIface hsc_env mb_old_iface details simpl_result
1208
1209 liftIO $ dumpIfaceStats hsc_env
1210
1211 -- Return the prepared code.
1212 return (new_iface, no_change, details, cg_guts)
1213
1214 --------------------------------------------------------------
1215 -- BackEnd combinators
1216 --------------------------------------------------------------
1217
1218 hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
1219 hscWriteIface dflags iface no_change mod_summary = do
1220 let ifaceFile = ml_hi_file (ms_location mod_summary)
1221 unless no_change $
1222 {-# SCC "writeIface" #-}
1223 writeIfaceFile dflags ifaceFile iface
1224 whenGeneratingDynamicToo dflags $ do
1225 -- TODO: We should do a no_change check for the dynamic
1226 -- interface file too
1227 -- TODO: Should handle the dynamic hi filename properly
1228 let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
1229 dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
1230 dynDflags = dynamicTooMkDynamicDynFlags dflags
1231 writeIfaceFile dynDflags dynIfaceFile' iface
1232
1233 -- | Compile to hard-code.
1234 hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
1235 -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1236 hscGenHardCode hsc_env cgguts mod_summary output_filename = do
1237 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1238 -- From now on, we just use the bits we need.
1239 cg_module = this_mod,
1240 cg_binds = core_binds,
1241 cg_tycons = tycons,
1242 cg_foreign = foreign_stubs0,
1243 cg_dep_pkgs = dependencies,
1244 cg_hpc_info = hpc_info } = cgguts
1245 dflags = hsc_dflags hsc_env
1246 location = ms_location mod_summary
1247 data_tycons = filter isDataTyCon tycons
1248 -- cg_tycons includes newtypes, for the benefit of External Core,
1249 -- but we don't generate any code for newtypes
1250
1251 -------------------
1252 -- PREPARE FOR CODE GENERATION
1253 -- Do saturation and convert to A-normal form
1254 prepd_binds <- {-# SCC "CorePrep" #-}
1255 corePrepPgm hsc_env this_mod location
1256 core_binds data_tycons
1257 ----------------- Convert to STG ------------------
1258 (stg_binds, cost_centre_info)
1259 <- {-# SCC "CoreToStg" #-}
1260 myCoreToStg dflags this_mod prepd_binds
1261
1262 let prof_init = profilingInitCode this_mod cost_centre_info
1263 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1264
1265 ------------------ Code generation ------------------
1266
1267 -- The back-end is streamed: each top-level function goes
1268 -- from Stg all the way to asm before dealing with the next
1269 -- top-level function, so showPass isn't very useful here.
1270 -- Hence we have one showPass for the whole backend, the
1271 -- next showPass after this will be "Assembler".
1272 withTiming (pure dflags)
1273 (text "CodeGen"<+>brackets (ppr this_mod))
1274 (const ()) $ do
1275 cmms <- {-# SCC "StgCmm" #-}
1276 doCodeGen hsc_env this_mod data_tycons
1277 cost_centre_info
1278 stg_binds hpc_info
1279
1280 ------------------ Code output -----------------------
1281 rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
1282 cmmToRawCmm dflags cmms
1283
1284 let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
1285 (ppr a)
1286 return a
1287 rawcmms1 = Stream.mapM dump rawcmms0
1288
1289 (output_filename, (_stub_h_exists, stub_c_exists))
1290 <- {-# SCC "codeOutput" #-}
1291 codeOutput dflags this_mod output_filename location
1292 foreign_stubs dependencies rawcmms1
1293 return (output_filename, stub_c_exists)
1294
1295
1296 hscInteractive :: HscEnv
1297 -> CgGuts
1298 -> ModSummary
1299 -> IO (Maybe FilePath, CompiledByteCode)
1300 #ifdef GHCI
1301 hscInteractive hsc_env cgguts mod_summary = do
1302 let dflags = hsc_dflags hsc_env
1303 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1304 -- From now on, we just use the bits we need.
1305 cg_module = this_mod,
1306 cg_binds = core_binds,
1307 cg_tycons = tycons,
1308 cg_foreign = foreign_stubs,
1309 cg_modBreaks = mod_breaks } = cgguts
1310
1311 location = ms_location mod_summary
1312 data_tycons = filter isDataTyCon tycons
1313 -- cg_tycons includes newtypes, for the benefit of External Core,
1314 -- but we don't generate any code for newtypes
1315
1316 -------------------
1317 -- PREPARE FOR CODE GENERATION
1318 -- Do saturation and convert to A-normal form
1319 prepd_binds <- {-# SCC "CorePrep" #-}
1320 corePrepPgm hsc_env this_mod location core_binds data_tycons
1321 ----------------- Generate byte code ------------------
1322 comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
1323 ------------------ Create f-x-dynamic C-side stuff ---
1324 (_istub_h_exists, istub_c_exists)
1325 <- outputForeignStubs dflags this_mod location foreign_stubs
1326 return (istub_c_exists, comp_bc)
1327 #else
1328 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1329 #endif
1330
1331 ------------------------------
1332
1333 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
1334 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
1335 let dflags = hsc_dflags hsc_env
1336 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1337 liftIO $ do
1338 us <- mkSplitUniqSupply 'S'
1339 let initTopSRT = initUs_ us emptySRT
1340 dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm)
1341 (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
1342 rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
1343 _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms
1344 return ()
1345 where
1346 no_mod = panic "hscCmmFile: no_mod"
1347 no_loc = ModLocation{ ml_hs_file = Just filename,
1348 ml_hi_file = panic "hscCmmFile: no hi file",
1349 ml_obj_file = panic "hscCmmFile: no obj file" }
1350
1351 -------------------- Stuff for new code gen ---------------------
1352
1353 doCodeGen :: HscEnv -> Module -> [TyCon]
1354 -> CollectedCCs
1355 -> [StgBinding]
1356 -> HpcInfo
1357 -> IO (Stream IO CmmGroup ())
1358 -- Note we produce a 'Stream' of CmmGroups, so that the
1359 -- backend can be run incrementally. Otherwise it generates all
1360 -- the C-- up front, which has a significant space cost.
1361 doCodeGen hsc_env this_mod data_tycons
1362 cost_centre_info stg_binds hpc_info = do
1363 let dflags = hsc_dflags hsc_env
1364
1365 let cmm_stream :: Stream IO CmmGroup ()
1366 cmm_stream = {-# SCC "StgCmm" #-}
1367 StgCmm.codeGen dflags this_mod data_tycons
1368 cost_centre_info stg_binds hpc_info
1369
1370 -- codegen consumes a stream of CmmGroup, and produces a new
1371 -- stream of CmmGroup (not necessarily synchronised: one
1372 -- CmmGroup on input may produce many CmmGroups on output due
1373 -- to proc-point splitting).
1374
1375 let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
1376 "Cmm produced by new codegen" (ppr a)
1377 return a
1378
1379 ppr_stream1 = Stream.mapM dump1 cmm_stream
1380
1381 -- We are building a single SRT for the entire module, so
1382 -- we must thread it through all the procedures as we cps-convert them.
1383 us <- mkSplitUniqSupply 'S'
1384
1385 -- When splitting, we generate one SRT per split chunk, otherwise
1386 -- we generate one SRT for the whole module.
1387 let
1388 pipeline_stream
1389 | gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags
1390 = {-# SCC "cmmPipeline" #-}
1391 let run_pipeline us cmmgroup = do
1392 let (topSRT', us') = initUs us emptySRT
1393 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
1394 let srt | isEmptySRT topSRT = []
1395 | otherwise = srtToData topSRT
1396 return (us', srt ++ cmmgroup)
1397
1398 in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
1399 return ()
1400
1401 | otherwise
1402 = {-# SCC "cmmPipeline" #-}
1403 let initTopSRT = initUs_ us emptySRT
1404 run_pipeline = cmmPipeline hsc_env
1405 in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
1406 Stream.yield (srtToData topSRT)
1407
1408 let
1409 dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a
1410 return a
1411
1412 ppr_stream2 = Stream.mapM dump2 pipeline_stream
1413
1414 return ppr_stream2
1415
1416
1417
1418 myCoreToStg :: DynFlags -> Module -> CoreProgram
1419 -> IO ( [StgBinding] -- output program
1420 , CollectedCCs) -- cost centre info (declared and used)
1421 myCoreToStg dflags this_mod prepd_binds = do
1422 let stg_binds
1423 = {-# SCC "Core2Stg" #-}
1424 coreToStg dflags this_mod prepd_binds
1425
1426 (stg_binds2, cost_centre_info)
1427 <- {-# SCC "Stg2Stg" #-}
1428 stg2stg dflags this_mod stg_binds
1429
1430 return (stg_binds2, cost_centre_info)
1431
1432
1433 {- **********************************************************************
1434 %* *
1435 \subsection{Compiling a do-statement}
1436 %* *
1437 %********************************************************************* -}
1438
1439 {-
1440 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1441 you run it you get a list of HValues that should be the same length as the list
1442 of names; add them to the ClosureEnv.
1443
1444 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1445 IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
1446 -}
1447
1448 #ifdef GHCI
1449 -- | Compile a stmt all the way to an HValue, but don't run it
1450 --
1451 -- We return Nothing to indicate an empty statement (or comment only), not a
1452 -- parse error.
1453 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
1454 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1455
1456 -- | Compile a stmt all the way to an HValue, but don't run it
1457 --
1458 -- We return Nothing to indicate an empty statement (or comment only), not a
1459 -- parse error.
1460 hscStmtWithLocation :: HscEnv
1461 -> String -- ^ The statement
1462 -> String -- ^ The source
1463 -> Int -- ^ Starting line
1464 -> IO ( Maybe ([Id]
1465 , ForeignHValue {- IO [HValue] -}
1466 , FixityEnv))
1467 hscStmtWithLocation hsc_env0 stmt source linenumber =
1468 runInteractiveHsc hsc_env0 $ do
1469 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1470 case maybe_stmt of
1471 Nothing -> return Nothing
1472
1473 Just parsed_stmt -> do
1474 hsc_env <- getHscEnv
1475 liftIO $ hscParsedStmt hsc_env parsed_stmt
1476
1477 hscParsedStmt :: HscEnv
1478 -> GhciLStmt RdrName -- ^ The parsed statement
1479 -> IO ( Maybe ([Id]
1480 , ForeignHValue {- IO [HValue] -}
1481 , FixityEnv))
1482 hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
1483 -- Rename and typecheck it
1484 (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
1485
1486 -- Desugar it
1487 ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
1488 liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
1489 handleWarnings
1490
1491 -- Then code-gen, and link it
1492 -- It's important NOT to have package 'interactive' as thisUnitId
1493 -- for linking, else we try to link 'main' and can't find it.
1494 -- Whereas the linker already knows to ignore 'interactive'
1495 let src_span = srcLocSpan interactiveSrcLoc
1496 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1497
1498 return $ Just (ids, hval, fix_env)
1499
1500 -- | Compile a decls
1501 hscDecls :: HscEnv
1502 -> String -- ^ The statement
1503 -> IO ([TyThing], InteractiveContext)
1504 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1505
1506 -- | Compile a decls
1507 hscDeclsWithLocation :: HscEnv
1508 -> String -- ^ The statement
1509 -> String -- ^ The source
1510 -> Int -- ^ Starting line
1511 -> IO ([TyThing], InteractiveContext)
1512 hscDeclsWithLocation hsc_env0 str source linenumber =
1513 runInteractiveHsc hsc_env0 $ do
1514 L _ (HsModule{ hsmodDecls = decls }) <-
1515 hscParseThingWithLocation source linenumber parseModule str
1516
1517 {- Rename and typecheck it -}
1518 hsc_env <- getHscEnv
1519 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
1520
1521 {- Grab the new instances -}
1522 -- We grab the whole environment because of the overlapping that may have
1523 -- been done. See the notes at the definition of InteractiveContext
1524 -- (ic_instances) for more details.
1525 let defaults = tcg_default tc_gblenv
1526
1527 {- Desugar it -}
1528 -- We use a basically null location for iNTERACTIVE
1529 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1530 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1531 ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
1532 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1533
1534 {- Simplify -}
1535 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1536
1537 {- Tidy -}
1538 (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1539
1540 let !CgGuts{ cg_module = this_mod,
1541 cg_binds = core_binds,
1542 cg_tycons = tycons,
1543 cg_modBreaks = mod_breaks } = tidy_cg
1544
1545 !ModDetails { md_insts = cls_insts
1546 , md_fam_insts = fam_insts } = mod_details
1547 -- Get the *tidied* cls_insts and fam_insts
1548
1549 data_tycons = filter isDataTyCon tycons
1550
1551 {- Prepare For Code Generation -}
1552 -- Do saturation and convert to A-normal form
1553 prepd_binds <- {-# SCC "CorePrep" #-}
1554 liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
1555
1556 {- Generate byte code -}
1557 cbc <- liftIO $ byteCodeGen hsc_env this_mod
1558 prepd_binds data_tycons mod_breaks
1559
1560 let src_span = srcLocSpan interactiveSrcLoc
1561 liftIO $ linkDecls hsc_env src_span cbc
1562
1563 let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
1564 patsyns = mg_patsyns simpl_mg
1565
1566 ext_ids = [ id | id <- bindersOfBinds core_binds
1567 , isExternalName (idName id)
1568 , not (isDFunId id || isImplicitId id) ]
1569 -- We only need to keep around the external bindings
1570 -- (as decided by TidyPgm), since those are the only ones
1571 -- that might later be looked up by name. But we can exclude
1572 -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
1573 -- - Implicit Ids, which are implicit in tcs
1574 -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv
1575
1576 new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
1577 ictxt = hsc_IC hsc_env
1578 -- See Note [Fixity declarations in GHCi]
1579 fix_env = tcg_fix_env tc_gblenv
1580 new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
1581 fam_insts defaults fix_env
1582 return (new_tythings, new_ictxt)
1583
1584
1585 {-
1586 Note [Fixity declarations in GHCi]
1587 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1588
1589 To support fixity declarations on types defined within GHCi (as requested
1590 in #10018) we record the fixity environment in InteractiveContext.
1591 When we want to evaluate something TcRnDriver.runTcInteractive pulls out this
1592 fixity environment and uses it to initialize the global typechecker environment.
1593 After the typechecker has finished its business, an updated fixity environment
1594 (reflecting whatever fixity declarations were present in the statements we
1595 passed it) will be returned from hscParsedStmt. This is passed to
1596 updateFixityEnv, which will stuff it back into InteractiveContext, to be
1597 used in evaluating the next statement.
1598
1599 -}
1600
1601 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1602 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1603 (L _ (HsModule{hsmodImports=is})) <-
1604 hscParseThing parseModule str
1605 case is of
1606 [L _ i] -> return i
1607 _ -> liftIO $ throwOneError $
1608 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
1609 text "parse error in import declaration"
1610
1611 -- | Typecheck an expression (but don't run it)
1612 hscTcExpr :: HscEnv
1613 -> TcRnExprMode
1614 -> String -- ^ The expression
1615 -> IO Type
1616 hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
1617 hsc_env <- getHscEnv
1618 parsed_expr <- hscParseExpr expr
1619 ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
1620
1621 -- | Find the kind of a type
1622 -- Currently this does *not* generalise the kinds of the type
1623 hscKcType
1624 :: HscEnv
1625 -> Bool -- ^ Normalise the type
1626 -> String -- ^ The type as a string
1627 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1628 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1629 hsc_env <- getHscEnv
1630 ty <- hscParseType str
1631 ioMsgMaybe $ tcRnType hsc_env normalise ty
1632
1633 hscParseExpr :: String -> Hsc (LHsExpr RdrName)
1634 hscParseExpr expr = do
1635 hsc_env <- getHscEnv
1636 maybe_stmt <- hscParseStmt expr
1637 case maybe_stmt of
1638 Just (L _ (BodyStmt expr _ _ _)) -> return expr
1639 _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
1640 (text "not an expression:" <+> quotes (text expr))
1641
1642 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
1643 hscParseStmt = hscParseThing parseStmt
1644
1645 hscParseStmtWithLocation :: String -> Int -> String
1646 -> Hsc (Maybe (GhciLStmt RdrName))
1647 hscParseStmtWithLocation source linenumber stmt =
1648 hscParseThingWithLocation source linenumber parseStmt stmt
1649
1650 hscParseType :: String -> Hsc (LHsType RdrName)
1651 hscParseType = hscParseThing parseType
1652 #endif
1653
1654 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1655 hscParseIdentifier hsc_env str =
1656 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1657
1658 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1659 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1660
1661 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1662 -> Lexer.P thing -> String -> Hsc thing
1663 hscParseThingWithLocation source linenumber parser str
1664 = withTiming getDynFlags
1665 (text "Parser [source]")
1666 (const ()) $ {-# SCC "Parser" #-} do
1667 dflags <- getDynFlags
1668
1669 let buf = stringToStringBuffer str
1670 loc = mkRealSrcLoc (fsLit source) linenumber 1
1671
1672 case unP parser (mkPState dflags buf loc) of
1673 PFailed span err -> do
1674 let msg = mkPlainErrMsg dflags span err
1675 throwErrors $ unitBag msg
1676
1677 POk pst thing -> do
1678 logWarningsReportErrors (getMessages pst dflags)
1679 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1680 return thing
1681
1682
1683 {- **********************************************************************
1684 %* *
1685 Desugar, simplify, convert to bytecode, and link an expression
1686 %* *
1687 %********************************************************************* -}
1688
1689 #ifdef GHCI
1690 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
1691 hscCompileCoreExpr hsc_env =
1692 lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
1693
1694 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
1695 hscCompileCoreExpr' hsc_env srcspan ds_expr
1696 = do { let dflags = hsc_dflags hsc_env
1697
1698 {- Simplify it -}
1699 ; simpl_expr <- simplifyExpr dflags ds_expr
1700
1701 {- Tidy it (temporary, until coreSat does cloning) -}
1702 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1703
1704 {- Prepare for codegen -}
1705 ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
1706
1707 {- Lint if necessary -}
1708 ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
1709
1710 {- Convert to BCOs -}
1711 ; bcos <- coreExprToBCOs hsc_env
1712 (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
1713
1714 {- link it -}
1715 ; hval <- linkExpr hsc_env srcspan bcos
1716
1717 ; return hval }
1718 #endif
1719
1720
1721 {- **********************************************************************
1722 %* *
1723 Statistics on reading interfaces
1724 %* *
1725 %********************************************************************* -}
1726
1727 dumpIfaceStats :: HscEnv -> IO ()
1728 dumpIfaceStats hsc_env = do
1729 eps <- readIORef (hsc_EPS hsc_env)
1730 dumpIfSet dflags (dump_if_trace || dump_rn_stats)
1731 "Interface statistics"
1732 (ifaceStats eps)
1733 where
1734 dflags = hsc_dflags hsc_env
1735 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1736 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1737
1738
1739 {- **********************************************************************
1740 %* *
1741 Progress Messages: Module i of n
1742 %* *
1743 %********************************************************************* -}
1744
1745 showModuleIndex :: (Int, Int) -> String
1746 showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1747 where
1748 n_str = show n
1749 i_str = show i
1750 padded = replicate (length n_str - length i_str) ' ' ++ i_str