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