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