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