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