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