never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2
3 {-# LANGUAGE NondecreasingIndentation #-}
4 {-# LANGUAGE TupleSections #-}
5 {-# LANGUAGE GADTs #-}
6
7 {-# OPTIONS_GHC -fprof-auto-top #-}
8
9 -------------------------------------------------------------------------------
10 --
11 -- | Main API for compiling plain Haskell source code.
12 --
13 -- This module implements compilation of a Haskell source. It is
14 -- /not/ concerned with preprocessing of source files; this is handled
15 -- in "GHC.Driver.Pipeline"
16 --
17 -- There are various entry points depending on what mode we're in:
18 -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
19 -- "interactive" mode (GHCi). There are also entry points for
20 -- individual passes: parsing, typechecking/renaming, desugaring, and
21 -- simplification.
22 --
23 -- All the functions here take an 'HscEnv' as a parameter, but none of
24 -- them return a new one: 'HscEnv' is treated as an immutable value
25 -- from here on in (although it has mutable components, for the
26 -- caches).
27 --
28 -- We use the Hsc monad to deal with warning messages consistently:
29 -- specifically, while executing within an Hsc monad, warnings are
30 -- collected. When a Hsc monad returns to an IO monad, the
31 -- warnings are printed, or compilation aborts if the @-Werror@
32 -- flag is enabled.
33 --
34 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
35 --
36 -------------------------------------------------------------------------------
37
38 module GHC.Driver.Main
39 (
40 -- * Making an HscEnv
41 newHscEnv
42
43 -- * Compiling complete source files
44 , Messager, batchMsg
45 , HscBackendAction (..), HscRecompStatus (..)
46 , initModDetails
47 , hscMaybeWriteIface
48 , hscCompileCmmFile
49
50 , hscGenHardCode
51 , hscInteractive
52
53 -- * Running passes separately
54 , hscRecompStatus
55 , hscParse
56 , hscTypecheckRename
57 , hscTypecheckAndGetWarnings
58 , hscDesugar
59 , makeSimpleDetails
60 , hscSimplify -- ToDo, shouldn't really export this
61 , hscDesugarAndSimplify
62
63 -- * Safe Haskell
64 , hscCheckSafe
65 , hscGetSafe
66
67 -- * Support for interactive evaluation
68 , hscParseIdentifier
69 , hscTcRcLookupName
70 , hscTcRnGetInfo
71 , hscIsGHCiMonad
72 , hscGetModuleInterface
73 , hscRnImportDecls
74 , hscTcRnLookupRdrName
75 , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
76 , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
77 , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
78 , hscParseExpr
79 , hscParseType
80 , hscCompileCoreExpr
81 -- * Low-level exports for hooks
82 , hscCompileCoreExpr'
83 -- We want to make sure that we export enough to be able to redefine
84 -- hsc_typecheck in client code
85 , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen
86 , getHscEnv
87 , hscSimpleIface'
88 , oneShotMsg
89 , dumpIfaceStats
90 , ioMsgMaybe
91 , showModuleIndex
92 , hscAddSptEntries
93 , writeInterfaceOnlyMode
94 ) where
95
96 import GHC.Prelude
97
98 import GHC.Driver.Plugins
99 import GHC.Driver.Session
100 import GHC.Driver.Backend
101 import GHC.Driver.Env
102 import GHC.Driver.Errors
103 import GHC.Driver.Errors.Types
104 import GHC.Driver.CodeOutput
105 import GHC.Driver.Config.Logger (initLogFlags)
106 import GHC.Driver.Config.Parser (initParserOpts)
107 import GHC.Driver.Config.Diagnostic
108 import GHC.Driver.Hooks
109
110 import GHC.Runtime.Context
111 import GHC.Runtime.Interpreter ( addSptEntry )
112 import GHC.Runtime.Loader ( initializePlugins )
113 import GHCi.RemoteTypes ( ForeignHValue )
114 import GHC.ByteCode.Types
115
116 import GHC.Linker.Loader
117 import GHC.Linker.Types
118
119 import GHC.Hs
120 import GHC.Hs.Dump
121 import GHC.Hs.Stats ( ppSourceStats )
122
123 import GHC.HsToCore
124
125 import GHC.StgToByteCode ( byteCodeGen )
126
127 import GHC.IfaceToCore ( typecheckIface )
128
129 import GHC.Iface.Load ( ifaceStats, writeIface )
130 import GHC.Iface.Make
131 import GHC.Iface.Recomp
132 import GHC.Iface.Tidy
133 import GHC.Iface.Ext.Ast ( mkHieFile )
134 import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
135 import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
136 import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
137
138 import GHC.Core
139 import GHC.Core.Tidy ( tidyExpr )
140 import GHC.Core.Type ( Type, Kind )
141 import GHC.Core.Lint ( lintInteractiveExpr )
142 import GHC.Core.Multiplicity
143 import GHC.Core.Utils ( exprType )
144 import GHC.Core.ConLike
145 import GHC.Core.Opt.Pipeline
146 import GHC.Core.TyCon
147 import GHC.Core.InstEnv
148 import GHC.Core.FamInstEnv
149
150 import GHC.CoreToStg.Prep
151 import GHC.CoreToStg ( coreToStg )
152
153 import GHC.Parser.Errors.Types
154 import GHC.Parser
155 import GHC.Parser.Lexer as Lexer
156
157 import GHC.Tc.Module
158 import GHC.Tc.Utils.Monad
159 import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) )
160
161 import GHC.Stg.Syntax
162 import GHC.Stg.FVs ( annTopBindingsFreeVars )
163 import GHC.Stg.Pipeline ( stg2stg )
164
165 import GHC.Builtin.Utils
166 import GHC.Builtin.Names
167 import GHC.Builtin.Uniques ( mkPseudoUniqueE )
168
169 import qualified GHC.StgToCmm as StgToCmm ( codeGen )
170 import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
171
172 import GHC.Cmm
173 import GHC.Cmm.Parser ( parseCmmFile )
174 import GHC.Cmm.Info.Build
175 import GHC.Cmm.Pipeline
176 import GHC.Cmm.Info
177
178 import GHC.Unit
179 import GHC.Unit.Env
180 import GHC.Unit.Finder
181 import GHC.Unit.External
182 import GHC.Unit.Module.ModDetails
183 import GHC.Unit.Module.ModGuts
184 import GHC.Unit.Module.ModIface
185 import GHC.Unit.Module.ModSummary
186 import GHC.Unit.Module.Graph
187 import GHC.Unit.Module.Imported
188 import GHC.Unit.Module.Deps
189 import GHC.Unit.Module.Status
190 import GHC.Unit.Home.ModInfo
191
192 import GHC.Types.Id
193 import GHC.Types.SourceError
194 import GHC.Types.SafeHaskell
195 import GHC.Types.ForeignStubs
196 import GHC.Types.Var.Env ( emptyTidyEnv )
197 import GHC.Types.Error
198 import GHC.Types.Fixity.Env
199 import GHC.Types.CostCentre
200 import GHC.Types.IPE
201 import GHC.Types.SourceFile
202 import GHC.Types.SrcLoc
203 import GHC.Types.Name
204 import GHC.Types.Name.Cache ( initNameCache )
205 import GHC.Types.Name.Reader
206 import GHC.Types.Name.Ppr
207 import GHC.Types.TyThing
208 import GHC.Types.HpcInfo
209
210 import GHC.Utils.Fingerprint ( Fingerprint )
211 import GHC.Utils.Panic
212 import GHC.Utils.Panic.Plain
213 import GHC.Utils.Error
214 import GHC.Utils.Outputable
215 import GHC.Utils.Misc
216 import GHC.Utils.Logger
217 import GHC.Utils.TmpFs
218
219 import GHC.Data.FastString
220 import GHC.Data.Bag
221 import GHC.Data.StringBuffer
222 import qualified GHC.Data.Stream as Stream
223 import GHC.Data.Stream (Stream)
224 import qualified GHC.SysTools
225
226 import Data.Data hiding (Fixity, TyCon)
227 import Data.List ( nub, isPrefixOf, partition )
228 import Control.Monad
229 import Data.IORef
230 import System.FilePath as FilePath
231 import System.Directory
232 import System.IO (fixIO)
233 import qualified Data.Set as S
234 import Data.Set (Set)
235 import Data.Functor
236 import Control.DeepSeq (force)
237 import Data.Bifunctor (first)
238 import GHC.Data.Maybe
239 import GHC.Driver.Env.KnotVars
240 import GHC.Types.Name.Set (NonCaffySet)
241 import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
242 import Data.List.NonEmpty (NonEmpty ((:|)))
243
244
245 {- **********************************************************************
246 %* *
247 Initialisation
248 %* *
249 %********************************************************************* -}
250
251 newHscEnv :: DynFlags -> IO HscEnv
252 newHscEnv dflags = do
253 nc_var <- initNameCache 'r' knownKeyNames
254 fc_var <- initFinderCache
255 logger <- initLogger
256 tmpfs <- initTmpFs
257 unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags)
258 return HscEnv { hsc_dflags = dflags
259 , hsc_logger = setLogFlags logger (initLogFlags dflags)
260 , hsc_targets = []
261 , hsc_mod_graph = emptyMG
262 , hsc_IC = emptyInteractiveContext dflags
263 , hsc_NC = nc_var
264 , hsc_FC = fc_var
265 , hsc_type_env_vars = emptyKnotVars
266 , hsc_interp = Nothing
267 , hsc_unit_env = unit_env
268 , hsc_plugins = []
269 , hsc_static_plugins = []
270 , hsc_hooks = emptyHooks
271 , hsc_tmpfs = tmpfs
272 }
273
274 -- -----------------------------------------------------------------------------
275
276 getDiagnostics :: Hsc (Messages GhcMessage)
277 getDiagnostics = Hsc $ \_ w -> return (w, w)
278
279 clearDiagnostics :: Hsc ()
280 clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages)
281
282 logDiagnostics :: Messages GhcMessage -> Hsc ()
283 logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w)
284
285 getHscEnv :: Hsc HscEnv
286 getHscEnv = Hsc $ \e w -> return (e, w)
287
288 handleWarnings :: Hsc ()
289 handleWarnings = do
290 diag_opts <- initDiagOpts <$> getDynFlags
291 logger <- getLogger
292 w <- getDiagnostics
293 liftIO $ printOrThrowDiagnostics logger diag_opts w
294 clearDiagnostics
295
296 -- | log warning in the monad, and if there are errors then
297 -- throw a SourceError exception.
298 logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()
299 logWarningsReportErrors (warnings,errors) = do
300 logDiagnostics (GhcPsMessage <$> warnings)
301 when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors)
302
303 -- | Log warnings and throw errors, assuming the messages
304 -- contain at least one error (e.g. coming from PFailed)
305 handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a
306 handleWarningsThrowErrors (warnings, errors) = do
307 diag_opts <- initDiagOpts <$> getDynFlags
308 logDiagnostics (GhcPsMessage <$> warnings)
309 logger <- getLogger
310 let (wWarns, wErrs) = partitionMessages warnings
311 liftIO $ printMessages logger diag_opts wWarns
312 throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs
313
314 -- | Deal with errors and warnings returned by a compilation step
315 --
316 -- In order to reduce dependencies to other parts of the compiler, functions
317 -- outside the "main" parts of GHC return warnings and errors as a parameter
318 -- and signal success via by wrapping the result in a 'Maybe' type. This
319 -- function logs the returned warnings and propagates errors as exceptions
320 -- (of type 'SourceError').
321 --
322 -- This function assumes the following invariants:
323 --
324 -- 1. If the second result indicates success (is of the form 'Just x'),
325 -- there must be no error messages in the first result.
326 --
327 -- 2. If there are no error messages, but the second result indicates failure
328 -- there should be warnings in the first result. That is, if the action
329 -- failed, it must have been due to the warnings (i.e., @-Werror@).
330 ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
331 ioMsgMaybe ioA = do
332 (msgs, mb_r) <- liftIO ioA
333 let (warns, errs) = partitionMessages msgs
334 logDiagnostics warns
335 case mb_r of
336 Nothing -> throwErrors errs
337 Just r -> assert (isEmptyMessages errs ) return r
338
339 -- | like ioMsgMaybe, except that we ignore error messages and return
340 -- 'Nothing' instead.
341 ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
342 ioMsgMaybe' ioA = do
343 (msgs, mb_r) <- liftIO $ ioA
344 logDiagnostics (mkMessages $ getWarningMessages msgs)
345 return mb_r
346
347 -- -----------------------------------------------------------------------------
348 -- | Lookup things in the compiler's environment
349
350 hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
351 hscTcRnLookupRdrName hsc_env0 rdr_name
352 = runInteractiveHsc hsc_env0 $
353 do { hsc_env <- getHscEnv
354 ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
355
356 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
357 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
358 hsc_env <- getHscEnv
359 ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name
360 -- ignore errors: the only error we're likely to get is
361 -- "name not found", and the Maybe in the return type
362 -- is used to indicate that.
363
364 hscTcRnGetInfo :: HscEnv -> Name
365 -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
366 hscTcRnGetInfo hsc_env0 name
367 = runInteractiveHsc hsc_env0 $
368 do { hsc_env <- getHscEnv
369 ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }
370
371 hscIsGHCiMonad :: HscEnv -> String -> IO Name
372 hscIsGHCiMonad hsc_env name
373 = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name
374
375 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
376 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
377 hsc_env <- getHscEnv
378 ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod
379
380 -- -----------------------------------------------------------------------------
381 -- | Rename some import declarations
382 hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
383 hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
384 hsc_env <- getHscEnv
385 ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls
386
387 -- -----------------------------------------------------------------------------
388 -- | parse a file, returning the abstract syntax
389
390 hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
391 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
392
393 -- internal version, that doesn't fail due to -Werror
394 hscParse' :: ModSummary -> Hsc HsParsedModule
395 hscParse' mod_summary
396 | Just r <- ms_parsed_mod mod_summary = return r
397 | otherwise = do
398 dflags <- getDynFlags
399 logger <- getLogger
400 {-# SCC "Parser" #-} withTiming logger
401 (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
402 (const ()) $ do
403 let src_filename = ms_hspp_file mod_summary
404 maybe_src_buf = ms_hspp_buf mod_summary
405
406 -------------------------- Parser ----------------
407 -- sometimes we already have the buffer in memory, perhaps
408 -- because we needed to parse the imports out of it, or get the
409 -- module name.
410 buf <- case maybe_src_buf of
411 Just b -> return b
412 Nothing -> liftIO $ hGetStringBuffer src_filename
413
414 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
415
416 let diag_opts = initDiagOpts dflags
417 when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do
418 case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of
419 Nothing -> pure ()
420 Just chars@((eloc,chr,_) :| _) ->
421 let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr)
422 in logDiagnostics $ singleMessage $
423 mkPlainMsgEnvelope diag_opts span $
424 GhcPsMessage $ PsWarnBidirectionalFormatChars chars
425
426 let parseMod | HsigFile == ms_hsc_src mod_summary
427 = parseSignature
428 | otherwise = parseModule
429
430 case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
431 PFailed pst ->
432 handleWarningsThrowErrors (getPsMessages pst)
433 POk pst rdr_module -> do
434 let (warns, errs) = getPsMessages pst
435 logDiagnostics (GhcPsMessage <$> warns)
436 liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"
437 FormatHaskell (ppr rdr_module)
438 liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"
439 FormatHaskell (showAstData NoBlankSrcSpan
440 NoBlankEpAnnotations
441 rdr_module)
442 liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"
443 FormatText (ppSourceStats False rdr_module)
444 when (not $ isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)
445
446 -- To get the list of extra source files, we take the list
447 -- that the parser gave us,
448 -- - eliminate files beginning with '<'. gcc likes to use
449 -- pseudo-filenames like "<built-in>" and "<command-line>"
450 -- - normalise them (eliminate differences between ./f and f)
451 -- - filter out the preprocessed source file
452 -- - filter out anything beginning with tmpdir
453 -- - remove duplicates
454 -- - filter out the .hs/.lhs source filename if we have one
455 --
456 let n_hspp = FilePath.normalise src_filename
457 TempDir tmp_dir = tmpDir dflags
458 srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`))
459 $ filter (not . (== n_hspp))
460 $ map FilePath.normalise
461 $ filter (not . isPrefixOf "<")
462 $ map unpackFS
463 $ srcfiles pst
464 srcs1 = case ml_hs_file (ms_location mod_summary) of
465 Just f -> filter (/= FilePath.normalise f) srcs0
466 Nothing -> srcs0
467
468 -- sometimes we see source files from earlier
469 -- preprocessing stages that cannot be found, so just
470 -- filter them out:
471 srcs2 <- liftIO $ filterM doesFileExist srcs1
472
473 let res = HsParsedModule {
474 hpm_module = rdr_module,
475 hpm_src_files = srcs2
476 }
477
478 -- apply parse transformation of plugins
479 let applyPluginAction p opts
480 = parsedResultAction p opts mod_summary
481 hsc_env <- getHscEnv
482 withPlugins hsc_env applyPluginAction res
483
484 checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
485 checkBidirectionFormatChars start_loc sb
486 | containsBidirectionalFormatChar sb = Just $ go start_loc sb
487 | otherwise = Nothing
488 where
489 go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)
490 go loc sb
491 | atEnd sb = panic "checkBidirectionFormatChars: no char found"
492 | otherwise = case nextChar sb of
493 (chr, sb)
494 | Just desc <- lookup chr bidirectionalFormatChars ->
495 (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb
496 | otherwise -> go (advancePsLoc loc chr) sb
497
498 go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]
499 go1 loc sb
500 | atEnd sb = []
501 | otherwise = case nextChar sb of
502 (chr, sb)
503 | Just desc <- lookup chr bidirectionalFormatChars ->
504 (loc, chr, desc) : go1 (advancePsLoc loc chr) sb
505 | otherwise -> go1 (advancePsLoc loc chr) sb
506
507
508 -- -----------------------------------------------------------------------------
509 -- | If the renamed source has been kept, extract it. Dump it if requested.
510
511
512 extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
513 extract_renamed_stuff mod_summary tc_result = do
514 let rn_info = getRenamedStuff tc_result
515
516 dflags <- getDynFlags
517 logger <- getLogger
518 liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"
519 FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)
520
521 -- Create HIE files
522 when (gopt Opt_WriteHie dflags) $ do
523 -- I assume this fromJust is safe because `-fwrite-hie-file`
524 -- enables the option which keeps the renamed source.
525 hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
526 let out_file = ml_hie_file $ ms_location mod_summary
527 liftIO $ writeHieFile out_file hieFile
528 liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
529
530 -- Validate HIE files
531 when (gopt Opt_ValidateHie dflags) $ do
532 hs_env <- Hsc $ \e w -> return (e, w)
533 liftIO $ do
534 -- Validate Scopes
535 case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
536 [] -> putMsg logger $ text "Got valid scopes"
537 xs -> do
538 putMsg logger $ text "Got invalid scopes"
539 mapM_ (putMsg logger) xs
540 -- Roundtrip testing
541 file' <- readHieFile (hsc_NC hs_env) out_file
542 case diffFile hieFile (hie_file_result file') of
543 [] ->
544 putMsg logger $ text "Got no roundtrip errors"
545 xs -> do
546 putMsg logger $ text "Got roundtrip errors"
547 let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)
548 mapM_ (putMsg logger') xs
549 return rn_info
550
551
552 -- -----------------------------------------------------------------------------
553 -- | Rename and typecheck a module, additionally returning the renamed syntax
554 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
555 -> IO (TcGblEnv, RenamedStuff)
556 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $
557 hsc_typecheck True mod_summary (Just rdr_module)
558
559 -- | Do Typechecking without throwing SourceError exception with -Werror
560 hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, WarningMessages)
561 hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do
562 case hscFrontendHook (hsc_hooks hsc_env) of
563 Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing
564 Just h -> h summary
565
566 -- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack
567 -- b) concerning dumping rename info and hie files. It would be nice to further
568 -- separate this stuff out, probably in conjunction better separating renaming
569 -- and type checking (#17781).
570 hsc_typecheck :: Bool -- ^ Keep renamed source?
571 -> ModSummary -> Maybe HsParsedModule
572 -> Hsc (TcGblEnv, RenamedStuff)
573 hsc_typecheck keep_rn mod_summary mb_rdr_module = do
574 hsc_env <- getHscEnv
575 let hsc_src = ms_hsc_src mod_summary
576 dflags = hsc_dflags hsc_env
577 home_unit = hsc_home_unit hsc_env
578 outer_mod = ms_mod mod_summary
579 mod_name = moduleName outer_mod
580 outer_mod' = mkHomeModule home_unit mod_name
581 inner_mod = homeModuleNameInstantiation home_unit mod_name
582 src_filename = ms_hspp_file mod_summary
583 real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
584 keep_rn' = gopt Opt_WriteHie dflags || keep_rn
585 massert (isHomeModule home_unit outer_mod)
586 tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
587 then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
588 else
589 do hpm <- case mb_rdr_module of
590 Just hpm -> return hpm
591 Nothing -> hscParse' mod_summary
592 tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
593 if hsc_src == HsigFile
594 then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary Nothing
595 ioMsgMaybe $ hoistTcRnMessage $
596 tcRnMergeSignatures hsc_env hpm tc_result0 iface
597 else return tc_result0
598 -- TODO are we extracting anything when we merely instantiate a signature?
599 -- If not, try to move this into the "else" case above.
600 rn_info <- extract_renamed_stuff mod_summary tc_result
601 return (tc_result, rn_info)
602
603 -- wrapper around tcRnModule to handle safe haskell extras
604 tcRnModule' :: ModSummary -> Bool -> HsParsedModule
605 -> Hsc TcGblEnv
606 tcRnModule' sum save_rn_syntax mod = do
607 hsc_env <- getHscEnv
608 dflags <- getDynFlags
609
610 let diag_opts = initDiagOpts dflags
611 -- -Wmissing-safe-haskell-mode
612 when (not (safeHaskellModeEnabled dflags)
613 && wopt Opt_WarnMissingSafeHaskellMode dflags) $
614 logDiagnostics $ singleMessage $
615 mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $
616 GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)
617
618 tcg_res <- {-# SCC "Typecheck-Rename" #-}
619 ioMsgMaybe $ hoistTcRnMessage $
620 tcRnModule hsc_env sum
621 save_rn_syntax mod
622
623 -- See Note [Safe Haskell Overlapping Instances Implementation]
624 -- although this is used for more than just that failure case.
625 tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)
626 whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)
627 let allSafeOK = safeInferred dflags && tcSafeOK
628
629 -- end of the safe haskell line, how to respond to user?
630 if not (safeHaskellOn dflags)
631 || (safeInferOn dflags && not allSafeOK)
632 -- if safe Haskell off or safe infer failed, mark unsafe
633 then markUnsafeInfer tcg_res whyUnsafe
634
635 -- module (could be) safe, throw warning if needed
636 else do
637 tcg_res' <- hscCheckSafeImports tcg_res
638 safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')
639 when safe $
640 case wopt Opt_WarnSafe dflags of
641 True
642 | safeHaskell dflags == Sf_Safe -> return ()
643 | otherwise -> (logDiagnostics $ singleMessage $
644 mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $
645 GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res'))
646 False | safeHaskell dflags == Sf_Trustworthy &&
647 wopt Opt_WarnTrustworthySafe dflags ->
648 (logDiagnostics $ singleMessage $
649 mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $
650 GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res'))
651 False -> return ()
652 return tcg_res'
653
654 -- | Convert a typechecked module to Core
655 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
656 hscDesugar hsc_env mod_summary tc_result =
657 runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
658
659 hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
660 hscDesugar' mod_location tc_result = do
661 hsc_env <- getHscEnv
662 ioMsgMaybe $ hoistDsMessage $
663 {-# SCC "deSugar" #-}
664 deSugar hsc_env mod_location tc_result
665
666 -- | Make a 'ModDetails' from the results of typechecking. Used when
667 -- typechecking only, as opposed to full compilation.
668 makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails
669 makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result
670
671
672 {- **********************************************************************
673 %* *
674 The main compiler pipeline
675 %* *
676 %********************************************************************* -}
677
678 {-
679 --------------------------------
680 The compilation proper
681 --------------------------------
682
683 It's the task of the compilation proper to compile Haskell, hs-boot and core
684 files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
685 (the module is still parsed and type-checked. This feature is mostly used by
686 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
687 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
688 mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
689 targets byte-code.
690
691 The modes are kept separate because of their different types and meanings:
692
693 * In 'one-shot' mode, we're only compiling a single file and can therefore
694 discard the new ModIface and ModDetails. This is also the reason it only
695 targets hard-code; compiling to byte-code or nothing doesn't make sense when
696 we discard the result.
697
698 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
699 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
700 return the newly compiled byte-code.
701
702 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
703 kept separate. This is because compiling to nothing is fairly special: We
704 don't output any interface files, we don't run the simplifier and we don't
705 generate any code.
706
707 * 'Interactive' mode is similar to 'batch' mode except that we return the
708 compiled byte-code together with the ModIface and ModDetails.
709
710 Trying to compile a hs-boot file to byte-code will result in a run-time error.
711 This is the only thing that isn't caught by the type-system.
712 -}
713
714
715 type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()
716
717 -- | Do the recompilation avoidance checks for both one-shot and --make modes
718 -- This function is the *only* place in the compiler where we decide whether to
719 -- recompile a module or not!
720 hscRecompStatus :: Maybe Messager
721 -> HscEnv
722 -> ModSummary
723 -> Maybe ModIface
724 -> Maybe Linkable
725 -> (Int,Int)
726 -> IO HscRecompStatus
727 hscRecompStatus
728 mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index
729 = do
730 let
731 msg what = case mHscMessage of
732 -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode
733 Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))
734 Nothing -> return ()
735
736 -- First check to see if the interface file agrees with the
737 -- source file.
738 (recomp_iface_reqd, mb_checked_iface)
739 <- {-# SCC "checkOldIface" #-}
740 liftIO $ checkOldIface hsc_env mod_summary mb_old_iface
741 -- Check to see whether the expected build products already exist.
742 -- If they don't exists then we trigger recompilation.
743 let lcl_dflags = ms_hspp_opts mod_summary
744 (recomp_obj_reqd, mb_linkable) <-
745 case () of
746 -- No need for a linkable, we're good to go
747 _ | NoBackend <- backend lcl_dflags -> return (UpToDate, Nothing)
748 -- Interpreter can use either already loaded bytecode or loaded object code
749 | not (backendProducesObject (backend lcl_dflags)) -> do
750 res <- liftIO $ checkByteCode old_linkable
751 case res of
752 (_, Just{}) -> return res
753 _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
754 -- Need object files for making object files
755 | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
756 | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)
757 let recomp_reqd = recomp_iface_reqd `mappend` recomp_obj_reqd
758 -- save the interface that comes back from checkOldIface.
759 -- In one-shot mode we don't have the old iface until this
760 -- point, when checkOldIface reads it from the disk.
761 let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
762 msg recomp_reqd
763 case mb_checked_iface of
764 Just iface | not (recompileRequired recomp_reqd) ->
765 return $ HscUpToDate iface mb_linkable
766 _ ->
767 return $ HscRecompNeeded mb_old_hash
768
769 -- | Check that the .o files produced by compilation are already up-to-date
770 -- or not.
771 checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (RecompileRequired, Maybe Linkable)
772 checkObjects dflags mb_old_linkable summary = do
773 let
774 dt_enabled = gopt Opt_BuildDynamicToo dflags
775 this_mod = ms_mod summary
776 mb_obj_date = ms_obj_date summary
777 mb_dyn_obj_date = ms_dyn_obj_date summary
778 mb_if_date = ms_iface_date summary
779 obj_fn = ml_obj_file (ms_location summary)
780 -- dynamic-too *also* produces the dyn_o_file, so have to check
781 -- that's there, and if it's not, regenerate both .o and
782 -- .dyn_o
783 checkDynamicObj k = if dt_enabled
784 then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of
785 Just True -> k
786 _ -> return (RecompBecause MissingDynObjectFile, Nothing)
787 -- Not in dynamic-too mode
788 else k
789
790 checkDynamicObj $
791 case (,) <$> mb_obj_date <*> mb_if_date of
792 Just (obj_date, if_date)
793 | obj_date >= if_date ->
794 case mb_old_linkable of
795 Just old_linkable
796 | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date
797 -> return $ (UpToDate, Just old_linkable)
798 _ -> (UpToDate,) . Just <$> findObjectLinkable this_mod obj_fn obj_date
799 _ -> return (RecompBecause MissingObjectFile, Nothing)
800
801 -- | Check to see if we can reuse the old linkable, by this point we will
802 -- have just checked that the old interface matches up with the source hash, so
803 -- no need to check that again here
804 checkByteCode :: Maybe Linkable -> IO (RecompileRequired, Maybe Linkable)
805 checkByteCode mb_old_linkable =
806 case mb_old_linkable of
807 Just old_linkable
808 | not (isObjectLinkable old_linkable)
809 -> return $ (UpToDate, Just old_linkable)
810 _ -> return $ (RecompBecause MissingBytecode, Nothing)
811
812 --------------------------------------------------------------
813 -- Compilers
814 --------------------------------------------------------------
815
816
817 -- Knot tying! See Note [Knot-tying typecheckIface]
818 -- See Note [ModDetails and --make mode]
819 initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails
820 initModDetails hsc_env mod_summary iface =
821 fixIO $ \details' -> do
822 let act hpt = addToHpt hpt (ms_mod_name mod_summary)
823 (HomeModInfo iface details' Nothing)
824 let hsc_env' = hscUpdateHPT act hsc_env
825 -- NB: This result is actually not that useful
826 -- in one-shot mode, since we're not going to do
827 -- any further typechecking. It's much more useful
828 -- in make mode, since this HMI will go into the HPT.
829 genModDetails hsc_env' iface
830
831
832 {-
833 Note [ModDetails and --make mode]
834 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
835
836 An interface file consists of two parts
837
838 * The `ModIface` which ends up getting written to disk.
839 The `ModIface` is a completely acyclic tree, which can be serialised
840 and de-serialised completely straightforwardly. The `ModIface` is
841 also the structure that is finger-printed for recompilation control.
842
843 * The `ModDetails` which provides a more structured view that is suitable
844 for usage during compilation. The `ModDetails` is heavily cyclic:
845 An `Id` contains a `Type`, which mentions a `TyCon` that contains kind
846 that mentions other `TyCons`; the `Id` also includes an unfolding that
847 in turn mentions more `Id`s; And so on.
848
849 The `ModIface` can be created from the `ModDetails` and the `ModDetails` from
850 a `ModIface`.
851
852 During tidying, just before interfaces are written to disk,
853 the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).
854 Then when GHC needs to restart typechecking from a certain point it can read the
855 interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).
856 The key part about the loading is that the ModDetails is regenerated lazily
857 from the ModIface, so that there's only a detailed in-memory representation
858 for declarations which are actually used from the interface. This mode is
859 also used when reading interface files from external packages.
860
861 In the old --make mode implementation, the interface was written after compiling a module
862 but the in-memory ModDetails which was used to compute the ModIface was retained.
863 The result was that --make mode used much more memory than `-c` mode, because a large amount of
864 information about a module would be kept in the ModDetails but never used.
865
866 The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`
867 at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that
868 we only have to keep the `ModIface` decls in memory and then lazily load
869 detailed representations if needed. It turns out this makes a really big difference
870 to memory usage, halving maximum memory used in some cases.
871
872 See !5492 and #13586
873 -}
874
875 -- Runs the post-typechecking frontend (desugar and simplify). We want to
876 -- generate most of the interface as late as possible. This gets us up-to-date
877 -- and good unfoldings and other info in the interface file.
878 --
879 -- We might create a interface right away, in which case we also return the
880 -- updated HomeModInfo. But we might also need to run the backend first. In the
881 -- later case Status will be HscRecomp and we return a function from ModIface ->
882 -- HomeModInfo.
883 --
884 -- HscRecomp in turn will carry the information required to compute a interface
885 -- when passed the result of the code generator. So all this can and is done at
886 -- the call site of the backend code gen if it is run.
887 hscDesugarAndSimplify :: ModSummary
888 -> FrontendResult
889 -> Messages GhcMessage
890 -> Maybe Fingerprint
891 -> Hsc HscBackendAction
892 hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do
893 hsc_env <- getHscEnv
894 dflags <- getDynFlags
895 logger <- getLogger
896 let bcknd = backend dflags
897 hsc_src = ms_hsc_src summary
898 diag_opts = initDiagOpts dflags
899
900 -- Desugar, if appropriate
901 --
902 -- We usually desugar even when we are not generating code, otherwise we
903 -- would miss errors thrown by the desugaring (see #10600). The only
904 -- exceptions are when the Module is Ghc.Prim or when it is not a
905 -- HsSrcFile Module.
906 mb_desugar <-
907 if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
908 then Just <$> hscDesugar' (ms_location summary) tc_result
909 else pure Nothing
910
911 -- Report the warnings from both typechecking and desugar together
912 w <- getDiagnostics
913 liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w)
914 clearDiagnostics
915
916 -- Simplify, if appropriate, and (whether we simplified or not) generate an
917 -- interface file.
918 case mb_desugar of
919 -- Just cause we desugared doesn't mean we are generating code, see above.
920 Just desugared_guts | bcknd /= NoBackend -> do
921 plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
922 simplified_guts <- hscSimplify' plugins desugared_guts
923
924 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
925 liftIO $ tidyProgram hsc_env simplified_guts
926
927 let !partial_iface =
928 {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
929 -- This `force` saves 2M residency in test T10370
930 -- See Note [Avoiding space leaks in toIface*] for details.
931 force (mkPartialIface hsc_env details summary simplified_guts)
932
933 return HscRecomp { hscs_guts = cg_guts,
934 hscs_mod_location = ms_location summary,
935 hscs_partial_iface = partial_iface,
936 hscs_old_iface_hash = mb_old_hash
937 }
938
939 -- We are not generating code, so we can skip simplification
940 -- and generate a simple interface.
941 _ -> do
942 (iface, mb_old_iface_hash, _details) <- liftIO $
943 hscSimpleIface hsc_env tc_result summary mb_old_hash
944
945 liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary)
946
947 return $ HscUpdate iface
948
949 {-
950 Note [Writing interface files]
951 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
952
953 We write one interface file per module and per compilation, except with
954 -dynamic-too where we write two interface files (non-dynamic and dynamic).
955
956 We can write two kinds of interfaces (see Note [Interface file stages] in
957 "GHC.Driver.Types"):
958
959 * simple interface: interface generated after the core pipeline
960
961 * full interface: simple interface completed with information from the
962 backend
963
964 Depending on the situation, we write one or the other (using
965 `hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the
966 backend is run twice, so if we write a simple interface we need to write both
967 the non-dynamic and the dynamic interfaces at the same time (with the same
968 contents).
969
970 Cases for which we generate simple interfaces:
971
972 * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation
973 of the hard code
974
975 * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target
976 bytecode (if interface writing is forced).
977
978 * GHC.Driver.Backpack uses simple interfaces for indefinite units
979 (units with module holes). It writes them indirectly by forcing the
980 -fwrite-interface flag while setting backend to NoBackend.
981
982 Cases for which we generate full interfaces:
983
984 * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard
985 code and/or require recompilation.
986
987 By default interface file names are derived from module file names by adding
988 suffixes. The interface file name can be overloaded with "-ohi", except when
989 `-dynamic-too` is used.
990
991 -}
992
993 -- | Write interface files
994 hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
995 hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
996 let force_write_interface = gopt Opt_WriteInterface dflags
997 write_interface = case backend dflags of
998 NoBackend -> False
999 Interpreter -> False
1000 _ -> True
1001
1002 write_iface dflags' iface =
1003 let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location
1004 profile = targetProfile dflags'
1005 in
1006 {-# SCC "writeIface" #-}
1007 withTiming logger
1008 (text "WriteIface"<+>brackets (text iface_name))
1009 (const ())
1010 (writeIface logger profile iface_name iface)
1011
1012 if (write_interface || force_write_interface) then do
1013
1014 -- FIXME: with -dynamic-too, "no_change" is only meaningful for the
1015 -- non-dynamic interface, not for the dynamic one. We should have another
1016 -- flag for the dynamic interface. In the meantime:
1017 --
1018 -- * when we write a single full interface, we check if we are
1019 -- currently writing the dynamic interface due to -dynamic-too, in
1020 -- which case we ignore "no_change".
1021 --
1022 -- * when we write two simple interfaces at once because of
1023 -- dynamic-too, we use "no_change" both for the non-dynamic and the
1024 -- dynamic interfaces. Hopefully both the dynamic and the non-dynamic
1025 -- interfaces stay in sync...
1026 --
1027 let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))
1028
1029 let dt = dynamicTooState dflags
1030
1031 when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $
1032 hang (text "Writing interface(s):") 2 $ vcat
1033 [ text "Kind:" <+> if is_simple then text "simple" else text "full"
1034 , text "Hash change:" <+> ppr (not no_change)
1035 , text "DynamicToo state:" <+> text (show dt)
1036 ]
1037
1038 if is_simple
1039 then unless no_change $ do -- FIXME: see no_change' comment above
1040 write_iface dflags iface
1041 case dt of
1042 DT_Dont -> return ()
1043 DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface"
1044 DT_OK -> write_iface (setDynamicNow dflags) iface
1045 else case dt of
1046 DT_Dont | not no_change -> write_iface dflags iface
1047 DT_OK | not no_change -> write_iface dflags iface
1048 -- FIXME: see no_change' comment above
1049 DT_Dyn -> write_iface dflags iface
1050 _ -> return ()
1051
1052 when (gopt Opt_WriteHie dflags) $ do
1053 -- This is slightly hacky. A hie file is considered to be up to date
1054 -- if its modification time on disk is greater than or equal to that
1055 -- of the .hi file (since we should always write a .hi file if we are
1056 -- writing a .hie file). However, with the way this code is
1057 -- structured at the moment, the .hie file is often written before
1058 -- the .hi file; by touching the file here, we ensure that it is
1059 -- correctly considered up-to-date.
1060 --
1061 -- The file should exist by the time we get here, but we check for
1062 -- existence just in case, so that we don't accidentally create empty
1063 -- .hie files.
1064 let hie_file = ml_hie_file mod_location
1065 whenM (doesFileExist hie_file) $
1066 GHC.SysTools.touch logger dflags "Touching hie file" hie_file
1067 else
1068 -- See Note [Strictness in ModIface]
1069 forceModIface iface
1070
1071 --------------------------------------------------------------
1072 -- NoRecomp handlers
1073 --------------------------------------------------------------
1074
1075
1076 -- | genModDetails is used to initialise 'ModDetails' at the end of compilation.
1077 -- This has two main effects:
1078 -- 1. Increases memory usage by unloading a lot of the TypeEnv
1079 -- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)
1080 -- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than
1081 -- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups
1082 -- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.
1083
1084 -- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new
1085 -- more compact and more correct version. This reduces memory usage whilst compiling the rest of
1086 -- the module loop.
1087 genModDetails :: HscEnv -> ModIface -> IO ModDetails
1088 genModDetails hsc_env old_iface
1089 = do
1090 -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and
1091 -- hence properly globalises DFunIds.
1092 new_details <- {-# SCC "tcRnIface" #-}
1093 initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)
1094 case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of
1095 Nothing -> return ()
1096 Just te_var -> writeIORef te_var (md_types new_details)
1097 dumpIfaceStats hsc_env
1098 return new_details
1099
1100 --------------------------------------------------------------
1101 -- Progress displayers.
1102 --------------------------------------------------------------
1103
1104 oneShotMsg :: Logger -> RecompileRequired -> IO ()
1105 oneShotMsg logger recomp =
1106 case recomp of
1107 UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"
1108 _ -> return ()
1109
1110 batchMsg :: Messager
1111 batchMsg hsc_env mod_index recomp node = case node of
1112 InstantiationNode _ ->
1113 case recomp of
1114 MustCompile -> showMsg (text "Instantiating ") empty
1115 UpToDate
1116 | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty
1117 | otherwise -> return ()
1118 RecompBecause reason -> showMsg (text "Instantiating ")
1119 (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
1120 ModuleNode _ ->
1121 case recomp of
1122 MustCompile -> showMsg (text "Compiling ") empty
1123 UpToDate
1124 | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty
1125 | otherwise -> return ()
1126 RecompBecause reason -> showMsg (text "Compiling ")
1127 (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
1128 where
1129 dflags = hsc_dflags hsc_env
1130 logger = hsc_logger hsc_env
1131 state = hsc_units hsc_env
1132 showMsg msg reason =
1133 compilationProgressMsg logger $
1134 (showModuleIndex mod_index <>
1135 msg <> showModMsg dflags (recompileRequired recomp) node)
1136 <> reason
1137
1138 --------------------------------------------------------------
1139 -- Safe Haskell
1140 --------------------------------------------------------------
1141
1142 -- Note [Safe Haskell Trust Check]
1143 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1144 -- Safe Haskell checks that an import is trusted according to the following
1145 -- rules for an import of module M that resides in Package P:
1146 --
1147 -- * If M is recorded as Safe and all its trust dependencies are OK
1148 -- then M is considered safe.
1149 -- * If M is recorded as Trustworthy and P is considered trusted and
1150 -- all M's trust dependencies are OK then M is considered safe.
1151 --
1152 -- By trust dependencies we mean that the check is transitive. So if
1153 -- a module M that is Safe relies on a module N that is trustworthy,
1154 -- importing module M will first check (according to the second case)
1155 -- that N is trusted before checking M is trusted.
1156 --
1157 -- This is a minimal description, so please refer to the user guide
1158 -- for more details. The user guide is also considered the authoritative
1159 -- source in this matter, not the comments or code.
1160
1161
1162 -- Note [Safe Haskell Inference]
1163 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1164 -- Safe Haskell does Safe inference on modules that don't have any specific
1165 -- safe haskell mode flag. The basic approach to this is:
1166 -- * When deciding if we need to do a Safe language check, treat
1167 -- an unmarked module as having -XSafe mode specified.
1168 -- * For checks, don't throw errors but return them to the caller.
1169 -- * Caller checks if there are errors:
1170 -- * For modules explicitly marked -XSafe, we throw the errors.
1171 -- * For unmarked modules (inference mode), we drop the errors
1172 -- and mark the module as being Unsafe.
1173 --
1174 -- It used to be that we only did safe inference on modules that had no Safe
1175 -- Haskell flags, but now we perform safe inference on all modules as we want
1176 -- to allow users to set the `-Wsafe`, `-Wunsafe` and
1177 -- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a
1178 -- user can ensure their assumptions are correct and see reasons for why a
1179 -- module is safe or unsafe.
1180 --
1181 -- This is tricky as we must be careful when we should throw an error compared
1182 -- to just warnings. For checking safe imports we manage it as two steps. First
1183 -- we check any imports that are required to be safe, then we check all other
1184 -- imports to see if we can infer them to be safe.
1185
1186
1187 -- | Check that the safe imports of the module being compiled are valid.
1188 -- If not we either issue a compilation error if the module is explicitly
1189 -- using Safe Haskell, or mark the module as unsafe if we're in safe
1190 -- inference mode.
1191 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
1192 hscCheckSafeImports tcg_env = do
1193 dflags <- getDynFlags
1194 tcg_env' <- checkSafeImports tcg_env
1195 checkRULES dflags tcg_env'
1196
1197 where
1198 checkRULES dflags tcg_env' =
1199 let diag_opts = initDiagOpts dflags
1200 in case safeLanguageOn dflags of
1201 True -> do
1202 -- XSafe: we nuke user written RULES
1203 logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')
1204 return tcg_env' { tcg_rules = [] }
1205 False
1206 -- SafeInferred: user defined RULES, so not safe
1207 | safeInferOn dflags && not (null $ tcg_rules tcg_env')
1208 -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')
1209
1210 -- Trustworthy OR SafeInferred: with no RULES
1211 | otherwise
1212 -> return tcg_env'
1213
1214 warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules
1215
1216 warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
1217 warnRules diag_opts (L loc rule) =
1218 mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule
1219
1220 -- | Validate that safe imported modules are actually safe. For modules in the
1221 -- HomePackage (the package the module we are compiling in resides) this just
1222 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
1223 -- that reside in another package we also must check that the external package
1224 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
1225 -- information.
1226 --
1227 -- The code for this is quite tricky as the whole algorithm is done in a few
1228 -- distinct phases in different parts of the code base. See
1229 -- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a
1230 -- module are collected and unioned. Specifically see the Note [Tracking Trust
1231 -- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in
1232 -- "GHC.Rename.Names".
1233 checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
1234 checkSafeImports tcg_env
1235 = do
1236 dflags <- getDynFlags
1237 imps <- mapM condense imports'
1238 let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
1239
1240 -- We want to use the warning state specifically for detecting if safe
1241 -- inference has failed, so store and clear any existing warnings.
1242 oldErrs <- getDiagnostics
1243 clearDiagnostics
1244
1245 -- Check safe imports are correct
1246 safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
1247 safeErrs <- getDiagnostics
1248 clearDiagnostics
1249
1250 -- Check non-safe imports are correct if inferring safety
1251 -- See the Note [Safe Haskell Inference]
1252 (infErrs, infPkgs) <- case (safeInferOn dflags) of
1253 False -> return (emptyMessages, S.empty)
1254 True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
1255 infErrs <- getDiagnostics
1256 clearDiagnostics
1257 return (infErrs, infPkgs)
1258
1259 -- restore old errors
1260 logDiagnostics oldErrs
1261
1262 case (isEmptyMessages safeErrs) of
1263 -- Failed safe check
1264 False -> liftIO . throwErrors $ safeErrs
1265
1266 -- Passed safe check
1267 True -> do
1268 let infPassed = isEmptyMessages infErrs
1269 tcg_env' <- case (not infPassed) of
1270 True -> markUnsafeInfer tcg_env infErrs
1271 False -> return tcg_env
1272 when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
1273 let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
1274 return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
1275
1276 where
1277 impInfo = tcg_imports tcg_env -- ImportAvails
1278 imports = imp_mods impInfo -- ImportedMods
1279 imports1 = moduleEnvToList imports -- (Module, [ImportedBy])
1280 imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])
1281 pkgReqs = imp_trust_pkgs impInfo -- [Unit]
1282
1283 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
1284 condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!"
1285 condense (m, x:xs) = do imv <- foldlM cond' x xs
1286 return (m, imv_span imv, imv_is_safe imv)
1287
1288 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
1289 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
1290 cond' v1 v2
1291 | imv_is_safe v1 /= imv_is_safe v2
1292 = throwOneError $
1293 mkPlainErrorMsgEnvelope (imv_span v1) $
1294 GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1)
1295 | otherwise
1296 = return v1
1297
1298 -- easier interface to work with
1299 checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
1300 checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
1301
1302 -- what pkg's to add to our trust requirements
1303 pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->
1304 Bool -> ImportAvails
1305 pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
1306 && not (safeHaskellModeEnabled dflags) && infPassed
1307 = emptyImportAvails {
1308 imp_trust_pkgs = req `S.union` inf
1309 }
1310 pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe
1311 = emptyImportAvails
1312 pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
1313
1314 -- | Check that a module is safe to import.
1315 --
1316 -- We return True to indicate the import is safe and False otherwise
1317 -- although in the False case an exception may be thrown first.
1318 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
1319 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
1320 dflags <- getDynFlags
1321 pkgs <- snd `fmap` hscCheckSafe' m l
1322 when (packageTrustOn dflags) $ checkPkgTrust pkgs
1323 errs <- getDiagnostics
1324 return $ isEmptyMessages errs
1325
1326 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
1327 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
1328 hscGetSafe hsc_env m l = runHsc hsc_env $ do
1329 (self, pkgs) <- hscCheckSafe' m l
1330 good <- isEmptyMessages `fmap` getDiagnostics
1331 clearDiagnostics -- don't want them printed...
1332 let pkgs' | Just p <- self = S.insert p pkgs
1333 | otherwise = pkgs
1334 return (good, pkgs')
1335
1336 -- | Is a module trusted? If not, throw or log errors depending on the type.
1337 -- Return (regardless of trusted or not) if the trust type requires the modules
1338 -- own package be trusted and a list of other packages required to be trusted
1339 -- (these later ones haven't been checked) but the own package trust has been.
1340 hscCheckSafe' :: Module -> SrcSpan
1341 -> Hsc (Maybe UnitId, Set UnitId)
1342 hscCheckSafe' m l = do
1343 hsc_env <- getHscEnv
1344 let home_unit = hsc_home_unit hsc_env
1345 (tw, pkgs) <- isModSafe home_unit m l
1346 case tw of
1347 False -> return (Nothing, pkgs)
1348 True | isHomeModule home_unit m -> return (Nothing, pkgs)
1349 -- TODO: do we also have to check the trust of the instantiation?
1350 -- Not necessary if that is reflected in dependencies
1351 | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs)
1352 where
1353 isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
1354 isModSafe home_unit m l = do
1355 hsc_env <- getHscEnv
1356 dflags <- getDynFlags
1357 iface <- lookup' m
1358 let diag_opts = initDiagOpts dflags
1359 case iface of
1360 -- can't load iface to check trust!
1361 Nothing -> throwOneError $
1362 mkPlainErrorMsgEnvelope l $
1363 GhcDriverMessage $ DriverCannotLoadInterfaceFile m
1364
1365 -- got iface, check trust
1366 Just iface' ->
1367 let trust = getSafeMode $ mi_trust iface'
1368 trust_own_pkg = mi_trust_pkg iface'
1369 -- check module is trusted
1370 safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]
1371 -- check package is trusted
1372 safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m
1373 -- pkg trust reqs
1374 pkgRs = dep_trusted_pkgs $ mi_deps iface'
1375 -- warn if Safe module imports Safe-Inferred module.
1376 warns = if wopt Opt_WarnInferredSafeImports dflags
1377 && safeLanguageOn dflags
1378 && trust == Sf_SafeInferred
1379 then inferredImportWarn diag_opts
1380 else emptyMessages
1381 -- General errors we throw but Safe errors we log
1382 errs = case (safeM, safeP) of
1383 (True, True ) -> emptyMessages
1384 (True, False) -> pkgTrustErr
1385 (False, _ ) -> modTrustErr
1386 in do
1387 logDiagnostics warns
1388 logDiagnostics errs
1389 return (trust == Sf_Trustworthy, pkgRs)
1390
1391 where
1392 state = hsc_units hsc_env
1393 inferredImportWarn diag_opts = singleMessage
1394 $ mkMsgEnvelope diag_opts l (pkgQual state)
1395 $ GhcDriverMessage $ DriverInferredSafeImport m
1396 pkgTrustErr = singleMessage
1397 $ mkErrorMsgEnvelope l (pkgQual state)
1398 $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m
1399 modTrustErr = singleMessage
1400 $ mkErrorMsgEnvelope l (pkgQual state)
1401 $ GhcDriverMessage $ DriverCannotImportUnsafeModule m
1402
1403 -- | Check the package a module resides in is trusted. Safe compiled
1404 -- modules are trusted without requiring that their package is trusted. For
1405 -- trustworthy modules, modules in the home package are trusted but
1406 -- otherwise we check the package trust flag.
1407 packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool
1408 packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =
1409 case safe_mode of
1410 Sf_None -> False -- shouldn't hit these cases
1411 Sf_Ignore -> False -- shouldn't hit these cases
1412 Sf_Unsafe -> False -- prefer for completeness.
1413 _ | not (packageTrustOn dflags) -> True
1414 Sf_Safe | not trust_own_pkg -> True
1415 Sf_SafeInferred | not trust_own_pkg -> True
1416 _ | isHomeModule home_unit mod -> True
1417 _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)
1418
1419 lookup' :: Module -> Hsc (Maybe ModIface)
1420 lookup' m = do
1421 hsc_env <- getHscEnv
1422 hsc_eps <- liftIO $ hscEPS hsc_env
1423 let pkgIfaceT = eps_PIT hsc_eps
1424 homePkgT = hsc_HPT hsc_env
1425 iface = lookupIfaceByModule homePkgT pkgIfaceT m
1426 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
1427 -- as the compiler hasn't filled in the various module tables
1428 -- so we need to call 'getModuleInterface' to load from disk
1429 case iface of
1430 Just _ -> return iface
1431 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
1432
1433
1434 -- | Check the list of packages are trusted.
1435 checkPkgTrust :: Set UnitId -> Hsc ()
1436 checkPkgTrust pkgs = do
1437 hsc_env <- getHscEnv
1438 let errors = S.foldr go emptyBag pkgs
1439 state = hsc_units hsc_env
1440 go pkg acc
1441 | unitIsTrusted $ unsafeLookupUnitId state pkg
1442 = acc
1443 | otherwise
1444 = (`consBag` acc)
1445 $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)
1446 $ GhcDriverMessage
1447 $ DriverPackageNotTrusted state pkg
1448 if isEmptyBag errors
1449 then return ()
1450 else liftIO $ throwErrors $ mkMessages errors
1451
1452 -- | Set module to unsafe and (potentially) wipe trust information.
1453 --
1454 -- Make sure to call this method to set a module to inferred unsafe, it should
1455 -- be a central and single failure method. We only wipe the trust information
1456 -- when we aren't in a specific Safe Haskell mode.
1457 --
1458 -- While we only use this for recording that a module was inferred unsafe, we
1459 -- may call it on modules using Trustworthy or Unsafe flags so as to allow
1460 -- warning flags for safety to function correctly. See Note [Safe Haskell
1461 -- Inference].
1462 markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
1463 markUnsafeInfer tcg_env whyUnsafe = do
1464 dflags <- getDynFlags
1465
1466 let reason = WarningWithFlag Opt_WarnUnsafe
1467 let diag_opts = initDiagOpts dflags
1468 when (diag_wopt Opt_WarnUnsafe diag_opts)
1469 (logDiagnostics $ singleMessage $
1470 mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $
1471 GhcDriverMessage $ DriverUnknownMessage $
1472 mkPlainDiagnostic reason noHints $
1473 whyUnsafe' dflags)
1474
1475 liftIO $ writeIORef (tcg_safe_infer tcg_env) False
1476 liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages
1477 -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
1478 -- times inference may be on but we are in Trustworthy mode -- so we want
1479 -- to record safe-inference failed but not wipe the trust dependencies.
1480 case not (safeHaskellModeEnabled dflags) of
1481 True -> return $ tcg_env { tcg_imports = wiped_trust }
1482 False -> return tcg_env
1483
1484 where
1485 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
1486 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1487 whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
1488 , text "Reason:"
1489 , nest 4 $ (vcat $ badFlags df) $+$
1490 (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$
1491 (vcat $ badInsts $ tcg_insts tcg_env)
1492 ]
1493 badFlags df = concatMap (badFlag df) unsafeFlagsForInfer
1494 badFlag df (str,loc,on,_)
1495 | on df = [mkLocMessage MCOutput (loc df) $
1496 text str <+> text "is not allowed in Safe Haskell"]
1497 | otherwise = []
1498 badInsts insts = concatMap badInst insts
1499
1500 checkOverlap (NoOverlap _) = False
1501 checkOverlap _ = True
1502
1503 badInst ins | checkOverlap (overlapMode (is_flag ins))
1504 = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $
1505 ppr (overlapMode $ is_flag ins) <+>
1506 text "overlap mode isn't allowed in Safe Haskell"]
1507 | otherwise = []
1508
1509 -- | Figure out the final correct safe haskell mode
1510 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
1511 hscGetSafeMode tcg_env = do
1512 dflags <- getDynFlags
1513 liftIO $ finalSafeMode dflags tcg_env
1514
1515 --------------------------------------------------------------
1516 -- Simplifiers
1517 --------------------------------------------------------------
1518
1519 -- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
1520 -- module names added via TH (cf 'addCorePlugin').
1521 hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
1522 hscSimplify hsc_env plugins modguts =
1523 runHsc hsc_env $ hscSimplify' plugins modguts
1524
1525 -- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
1526 -- module names added via TH (cf 'addCorePlugin').
1527 hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
1528 hscSimplify' plugins ds_result = do
1529 hsc_env <- getHscEnv
1530 hsc_env_with_plugins <- if null plugins -- fast path
1531 then return hsc_env
1532 else liftIO $ flip initializePlugins (Just $ mg_mnwib ds_result)
1533 $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins)
1534 hsc_env
1535 {-# SCC "Core2Core" #-}
1536 liftIO $ core2core hsc_env_with_plugins ds_result
1537
1538 --------------------------------------------------------------
1539 -- Interface generators
1540 --------------------------------------------------------------
1541
1542 -- | Generate a striped down interface file, e.g. for boot files or when ghci
1543 -- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]
1544 hscSimpleIface :: HscEnv
1545 -> TcGblEnv
1546 -> ModSummary
1547 -> Maybe Fingerprint
1548 -> IO (ModIface, Maybe Fingerprint, ModDetails)
1549 hscSimpleIface hsc_env tc_result summary mb_old_iface
1550 = runHsc hsc_env $ hscSimpleIface' tc_result summary mb_old_iface
1551
1552 hscSimpleIface' :: TcGblEnv
1553 -> ModSummary
1554 -> Maybe Fingerprint
1555 -> Hsc (ModIface, Maybe Fingerprint, ModDetails)
1556 hscSimpleIface' tc_result summary mb_old_iface = do
1557 hsc_env <- getHscEnv
1558 logger <- getLogger
1559 details <- liftIO $ mkBootModDetailsTc logger tc_result
1560 safe_mode <- hscGetSafeMode tc_result
1561 new_iface
1562 <- {-# SCC "MkFinalIface" #-}
1563 liftIO $
1564 mkIfaceTc hsc_env safe_mode details summary tc_result
1565 -- And the answer is ...
1566 liftIO $ dumpIfaceStats hsc_env
1567 return (new_iface, mb_old_iface, details)
1568
1569 --------------------------------------------------------------
1570 -- BackEnd combinators
1571 --------------------------------------------------------------
1572
1573 -- | Compile to hard-code.
1574 hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
1575 -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
1576 -- ^ @Just f@ <=> _stub.c is f
1577 hscGenHardCode hsc_env cgguts location output_filename = do
1578 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1579 -- From now on, we just use the bits we need.
1580 cg_module = this_mod,
1581 cg_binds = core_binds,
1582 cg_ccs = local_ccs,
1583 cg_tycons = tycons,
1584 cg_foreign = foreign_stubs0,
1585 cg_foreign_files = foreign_files,
1586 cg_dep_pkgs = dependencies,
1587 cg_hpc_info = hpc_info } = cgguts
1588 dflags = hsc_dflags hsc_env
1589 logger = hsc_logger hsc_env
1590 hooks = hsc_hooks hsc_env
1591 tmpfs = hsc_tmpfs hsc_env
1592 profile = targetProfile dflags
1593 data_tycons = filter isDataTyCon tycons
1594 -- cg_tycons includes newtypes, for the benefit of External Core,
1595 -- but we don't generate any code for newtypes
1596
1597 -------------------
1598 -- PREPARE FOR CODE GENERATION
1599 -- Do saturation and convert to A-normal form
1600 (prepd_binds) <- {-# SCC "CorePrep" #-}
1601 corePrepPgm hsc_env this_mod location
1602 core_binds data_tycons
1603
1604 ----------------- Convert to STG ------------------
1605 (stg_binds, denv, (caf_ccs, caf_cc_stacks))
1606 <- {-# SCC "CoreToStg" #-}
1607 withTiming logger
1608 (text "CoreToStg"<+>brackets (ppr this_mod))
1609 (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())
1610 (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
1611
1612 let cost_centre_info =
1613 (local_ccs ++ caf_ccs, caf_cc_stacks)
1614 platform = targetPlatform dflags
1615 prof_init
1616 | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
1617 | otherwise = mempty
1618
1619 ------------------ Code generation ------------------
1620 -- The back-end is streamed: each top-level function goes
1621 -- from Stg all the way to asm before dealing with the next
1622 -- top-level function, so showPass isn't very useful here.
1623 -- Hence we have one showPass for the whole backend, the
1624 -- next showPass after this will be "Assembler".
1625 withTiming logger
1626 (text "CodeGen"<+>brackets (ppr this_mod))
1627 (const ()) $ do
1628 cmms <- {-# SCC "StgToCmm" #-}
1629 doCodeGen hsc_env this_mod denv data_tycons
1630 cost_centre_info
1631 stg_binds hpc_info
1632
1633 ------------------ Code output -----------------------
1634 rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
1635 case cmmToRawCmmHook hooks of
1636 Nothing -> cmmToRawCmm logger profile cmms
1637 Just h -> h dflags (Just this_mod) cmms
1638
1639 let dump a = do
1640 unless (null a) $
1641 putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)
1642 return a
1643 rawcmms1 = Stream.mapM dump rawcmms0
1644
1645 let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init
1646 `appendStubC` cgIPEStub st
1647
1648 (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
1649 <- {-# SCC "codeOutput" #-}
1650 codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location
1651 foreign_stubs foreign_files dependencies rawcmms1
1652 return (output_filename, stub_c_exists, foreign_fps, cg_infos)
1653
1654
1655 hscInteractive :: HscEnv
1656 -> CgGuts
1657 -> ModLocation
1658 -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
1659 hscInteractive hsc_env cgguts location = do
1660 let dflags = hsc_dflags hsc_env
1661 let logger = hsc_logger hsc_env
1662 let tmpfs = hsc_tmpfs hsc_env
1663 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1664 -- From now on, we just use the bits we need.
1665 cg_module = this_mod,
1666 cg_binds = core_binds,
1667 cg_tycons = tycons,
1668 cg_foreign = foreign_stubs,
1669 cg_modBreaks = mod_breaks,
1670 cg_spt_entries = spt_entries } = cgguts
1671
1672 data_tycons = filter isDataTyCon tycons
1673 -- cg_tycons includes newtypes, for the benefit of External Core,
1674 -- but we don't generate any code for newtypes
1675
1676 -------------------
1677 -- PREPARE FOR CODE GENERATION
1678 -- Do saturation and convert to A-normal form
1679 prepd_binds <- {-# SCC "CorePrep" #-}
1680 corePrepPgm hsc_env this_mod location core_binds data_tycons
1681
1682 (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
1683 <- {-# SCC "CoreToStg" #-}
1684 myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
1685 ----------------- Generate byte code ------------------
1686 comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
1687 ------------------ Create f-x-dynamic C-side stuff -----
1688 (_istub_h_exists, istub_c_exists)
1689 <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
1690 return (istub_c_exists, comp_bc, spt_entries)
1691
1692 ------------------------------
1693
1694 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)
1695 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
1696 let dflags = hsc_dflags hsc_env
1697 let logger = hsc_logger hsc_env
1698 let profile = targetProfile dflags
1699 let hooks = hsc_hooks hsc_env
1700 let tmpfs = hsc_tmpfs hsc_env
1701 home_unit = hsc_home_unit hsc_env
1702 platform = targetPlatform dflags
1703 -- Make up a module name to give the NCG. We can't pass bottom here
1704 -- lest we reproduce #11784.
1705 mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
1706 cmm_mod = mkHomeModule home_unit mod_name
1707 (cmm, ents) <- ioMsgMaybe
1708 $ do
1709 (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
1710 $ parseCmmFile dflags cmm_mod home_unit filename
1711 let msgs = warns `unionMessages` errs
1712 return (GhcPsMessage <$> msgs, cmm)
1713 liftIO $ do
1714 putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
1715
1716 -- Compile decls in Cmm files one decl at a time, to avoid re-ordering
1717 -- them in SRT analysis.
1718 --
1719 -- Re-ordering here causes breakage when booting with C backend because
1720 -- in C we must declare before use, but SRT algorithm is free to
1721 -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]
1722 cmmgroup <-
1723 concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm
1724
1725 unless (null cmmgroup) $
1726 putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"
1727 FormatCMM (pdoc platform cmmgroup)
1728
1729 rawCmms <- case cmmToRawCmmHook hooks of
1730 Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)
1731 Just h -> h dflags Nothing (Stream.yield cmmgroup)
1732
1733 let foreign_stubs _ =
1734 let ip_init = ipInitCode dflags cmm_mod ents
1735 in NoStubs `appendStubC` ip_init
1736
1737 (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
1738 <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
1739 rawCmms
1740 return stub_c_exists
1741 where
1742 no_loc = ModLocation{ ml_hs_file = Just filename,
1743 ml_hi_file = panic "hscCompileCmmFile: no hi file",
1744 ml_obj_file = panic "hscCompileCmmFile: no obj file",
1745 ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",
1746 ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file",
1747 ml_hie_file = panic "hscCompileCmmFile: no hie file"}
1748
1749 -------------------- Stuff for new code gen ---------------------
1750
1751 {-
1752 Note [Forcing of stg_binds]
1753 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1754
1755 The two last steps in the STG pipeline are:
1756
1757 * Sorting the bindings in dependency order.
1758 * Annotating them with free variables.
1759
1760 We want to make sure we do not keep references to unannotated STG bindings
1761 alive, nor references to bindings which have already been compiled to Cmm.
1762
1763 We explicitly force the bindings to avoid this.
1764
1765 This reduces residency towards the end of the CodeGen phase significantly
1766 (5-10%).
1767 -}
1768
1769 doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
1770 -> CollectedCCs
1771 -> [StgTopBinding]
1772 -> HpcInfo
1773 -> IO (Stream IO CmmGroupSRTs CgInfos)
1774 -- Note we produce a 'Stream' of CmmGroups, so that the
1775 -- backend can be run incrementally. Otherwise it generates all
1776 -- the C-- up front, which has a significant space cost.
1777 doCodeGen hsc_env this_mod denv data_tycons
1778 cost_centre_info stg_binds hpc_info = do
1779 let dflags = hsc_dflags hsc_env
1780 let logger = hsc_logger hsc_env
1781 let hooks = hsc_hooks hsc_env
1782 let tmpfs = hsc_tmpfs hsc_env
1783 let platform = targetPlatform dflags
1784
1785 let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
1786
1787 putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)
1788
1789 let stg_to_cmm = case stgToCmmHook hooks of
1790 Nothing -> StgToCmm.codeGen logger tmpfs
1791 Just h -> h
1792
1793 let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
1794 -- See Note [Forcing of stg_binds]
1795 cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
1796 stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
1797
1798 -- codegen consumes a stream of CmmGroup, and produces a new
1799 -- stream of CmmGroup (not necessarily synchronised: one
1800 -- CmmGroup on input may produce many CmmGroups on output due
1801 -- to proc-point splitting).
1802
1803 let dump1 a = do
1804 unless (null a) $
1805 putDumpFileMaybe logger Opt_D_dump_cmm_from_stg
1806 "Cmm produced by codegen" FormatCMM (pdoc platform a)
1807 return a
1808
1809 ppr_stream1 = Stream.mapM dump1 cmm_stream
1810
1811 pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
1812 pipeline_stream = do
1813 (non_cafs, lf_infos) <-
1814 {-# SCC "cmmPipeline" #-}
1815 Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
1816 <&> first (srtMapNonCAFs . moduleSRTMap)
1817
1818 return (non_cafs, lf_infos)
1819
1820 dump2 a = do
1821 unless (null a) $
1822 putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
1823 return a
1824
1825 return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream
1826
1827 myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
1828 -> Bool
1829 -> Module -> ModLocation -> CoreExpr
1830 -> IO ( Id
1831 , [StgTopBinding]
1832 , InfoTableProvMap
1833 , CollectedCCs )
1834 myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
1835 {- Create a temporary binding (just because myCoreToStg needs a
1836 binding for the stg2stg step) -}
1837 let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
1838 (mkPseudoUniqueE 0)
1839 Many
1840 (exprType prepd_expr)
1841 (stg_binds, prov_map, collected_ccs) <-
1842 myCoreToStg logger
1843 dflags
1844 ictxt
1845 for_bytecode
1846 this_mod
1847 ml
1848 [NonRec bco_tmp_id prepd_expr]
1849 return (bco_tmp_id, stg_binds, prov_map, collected_ccs)
1850
1851 myCoreToStg :: Logger -> DynFlags -> InteractiveContext
1852 -> Bool
1853 -> Module -> ModLocation -> CoreProgram
1854 -> IO ( [StgTopBinding] -- output program
1855 , InfoTableProvMap
1856 , CollectedCCs ) -- CAF cost centre info (declared and used)
1857 myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
1858 let (stg_binds, denv, cost_centre_info)
1859 = {-# SCC "Core2Stg" #-}
1860 coreToStg dflags this_mod ml prepd_binds
1861
1862 stg_binds2
1863 <- {-# SCC "Stg2Stg" #-}
1864 stg2stg logger dflags ictxt for_bytecode this_mod stg_binds
1865
1866 return (stg_binds2, denv, cost_centre_info)
1867
1868 {- **********************************************************************
1869 %* *
1870 \subsection{Compiling a do-statement}
1871 %* *
1872 %********************************************************************* -}
1873
1874 {-
1875 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1876 you run it you get a list of HValues that should be the same length as the list
1877 of names; add them to the ClosureEnv.
1878
1879 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1880 IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context
1881 -}
1882
1883 -- | Compile a stmt all the way to an HValue, but don't run it
1884 --
1885 -- We return Nothing to indicate an empty statement (or comment only), not a
1886 -- parse error.
1887 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
1888 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1889
1890 -- | Compile a stmt all the way to an HValue, but don't run it
1891 --
1892 -- We return Nothing to indicate an empty statement (or comment only), not a
1893 -- parse error.
1894 hscStmtWithLocation :: HscEnv
1895 -> String -- ^ The statement
1896 -> String -- ^ The source
1897 -> Int -- ^ Starting line
1898 -> IO ( Maybe ([Id]
1899 , ForeignHValue {- IO [HValue] -}
1900 , FixityEnv))
1901 hscStmtWithLocation hsc_env0 stmt source linenumber =
1902 runInteractiveHsc hsc_env0 $ do
1903 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1904 case maybe_stmt of
1905 Nothing -> return Nothing
1906
1907 Just parsed_stmt -> do
1908 hsc_env <- getHscEnv
1909 liftIO $ hscParsedStmt hsc_env parsed_stmt
1910
1911 hscParsedStmt :: HscEnv
1912 -> GhciLStmt GhcPs -- ^ The parsed statement
1913 -> IO ( Maybe ([Id]
1914 , ForeignHValue {- IO [HValue] -}
1915 , FixityEnv))
1916 hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
1917 -- Rename and typecheck it
1918 (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt
1919
1920 -- Desugar it
1921 ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr
1922 liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
1923 handleWarnings
1924
1925 -- Then code-gen, and link it
1926 -- It's important NOT to have package 'interactive' as thisUnitId
1927 -- for linking, else we try to link 'main' and can't find it.
1928 -- Whereas the linker already knows to ignore 'interactive'
1929 let src_span = srcLocSpan interactiveSrcLoc
1930 hval <- liftIO $ hscCompileCoreExpr hsc_env (src_span, Nothing) ds_expr
1931
1932 return $ Just (ids, hval, fix_env)
1933
1934 -- | Compile a decls
1935 hscDecls :: HscEnv
1936 -> String -- ^ The statement
1937 -> IO ([TyThing], InteractiveContext)
1938 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1939
1940 hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
1941 hscParseDeclsWithLocation hsc_env source line_num str = do
1942 L _ (HsModule{ hsmodDecls = decls }) <-
1943 runInteractiveHsc hsc_env $
1944 hscParseThingWithLocation source line_num parseModule str
1945 return decls
1946
1947 -- | Compile a decls
1948 hscDeclsWithLocation :: HscEnv
1949 -> String -- ^ The statement
1950 -> String -- ^ The source
1951 -> Int -- ^ Starting line
1952 -> IO ([TyThing], InteractiveContext)
1953 hscDeclsWithLocation hsc_env str source linenumber = do
1954 L _ (HsModule{ hsmodDecls = decls }) <-
1955 runInteractiveHsc hsc_env $
1956 hscParseThingWithLocation source linenumber parseModule str
1957 hscParsedDecls hsc_env decls
1958
1959 hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
1960 hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
1961 hsc_env <- getHscEnv
1962 let interp = hscInterp hsc_env
1963
1964 {- Rename and typecheck it -}
1965 tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls
1966
1967 {- Grab the new instances -}
1968 -- We grab the whole environment because of the overlapping that may have
1969 -- been done. See the notes at the definition of InteractiveContext
1970 -- (ic_instances) for more details.
1971 let defaults = tcg_default tc_gblenv
1972
1973 {- Desugar it -}
1974 -- We use a basically null location for iNTERACTIVE
1975 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1976 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1977 ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
1978 ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
1979 ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",
1980 ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" }
1981 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1982
1983 {- Simplify -}
1984 simpl_mg <- liftIO $ do
1985 plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
1986 hscSimplify hsc_env plugins ds_result
1987
1988 {- Tidy -}
1989 (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1990
1991 let !CgGuts{ cg_module = this_mod,
1992 cg_binds = core_binds,
1993 cg_tycons = tycons,
1994 cg_modBreaks = mod_breaks } = tidy_cg
1995
1996 !ModDetails { md_insts = cls_insts
1997 , md_fam_insts = fam_insts } = mod_details
1998 -- Get the *tidied* cls_insts and fam_insts
1999
2000 data_tycons = filter isDataTyCon tycons
2001
2002 {- Prepare For Code Generation -}
2003 -- Do saturation and convert to A-normal form
2004 prepd_binds <- {-# SCC "CorePrep" #-}
2005 liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
2006
2007 (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
2008 <- {-# SCC "CoreToStg" #-}
2009 liftIO $ myCoreToStg (hsc_logger hsc_env)
2010 (hsc_dflags hsc_env)
2011 (hsc_IC hsc_env)
2012 True
2013 this_mod
2014 iNTERACTIVELoc
2015 prepd_binds
2016
2017 {- Generate byte code -}
2018 cbc <- liftIO $ byteCodeGen hsc_env this_mod
2019 stg_binds data_tycons mod_breaks
2020
2021 let src_span = srcLocSpan interactiveSrcLoc
2022 _ <- liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc
2023
2024 {- Load static pointer table entries -}
2025 liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg)
2026
2027 let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
2028 patsyns = mg_patsyns simpl_mg
2029
2030 ext_ids = [ id | id <- bindersOfBinds core_binds
2031 , isExternalName (idName id)
2032 , not (isDFunId id || isImplicitId id) ]
2033 -- We only need to keep around the external bindings
2034 -- (as decided by GHC.Iface.Tidy), since those are the only ones
2035 -- that might later be looked up by name. But we can exclude
2036 -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context
2037 -- - Implicit Ids, which are implicit in tcs
2038 -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv
2039
2040 new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
2041 ictxt = hsc_IC hsc_env
2042 -- See Note [Fixity declarations in GHCi]
2043 fix_env = tcg_fix_env tc_gblenv
2044 new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
2045 fam_insts defaults fix_env
2046 return (new_tythings, new_ictxt)
2047
2048 -- | Load the given static-pointer table entries into the interpreter.
2049 -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
2050 hscAddSptEntries :: HscEnv -> Maybe ModuleNameWithIsBoot -> [SptEntry] -> IO ()
2051 hscAddSptEntries hsc_env mnwib entries = do
2052 let interp = hscInterp hsc_env
2053 let add_spt_entry :: SptEntry -> IO ()
2054 add_spt_entry (SptEntry i fpr) = do
2055 val <- loadName interp hsc_env mnwib (idName i)
2056 addSptEntry interp fpr val
2057 mapM_ add_spt_entry entries
2058
2059 {-
2060 Note [Fixity declarations in GHCi]
2061 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2062
2063 To support fixity declarations on types defined within GHCi (as requested
2064 in #10018) we record the fixity environment in InteractiveContext.
2065 When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this
2066 fixity environment and uses it to initialize the global typechecker environment.
2067 After the typechecker has finished its business, an updated fixity environment
2068 (reflecting whatever fixity declarations were present in the statements we
2069 passed it) will be returned from hscParsedStmt. This is passed to
2070 updateFixityEnv, which will stuff it back into InteractiveContext, to be
2071 used in evaluating the next statement.
2072
2073 -}
2074
2075 hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
2076 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
2077 (L _ (HsModule{hsmodImports=is})) <-
2078 hscParseThing parseModule str
2079 case is of
2080 [L _ i] -> return i
2081 _ -> liftIO $ throwOneError $
2082 mkPlainErrorMsgEnvelope noSrcSpan $
2083 GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $
2084 text "parse error in import declaration"
2085
2086 -- | Typecheck an expression (but don't run it)
2087 hscTcExpr :: HscEnv
2088 -> TcRnExprMode
2089 -> String -- ^ The expression
2090 -> IO Type
2091 hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
2092 hsc_env <- getHscEnv
2093 parsed_expr <- hscParseExpr expr
2094 ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr
2095
2096 -- | Find the kind of a type, after generalisation
2097 hscKcType
2098 :: HscEnv
2099 -> Bool -- ^ Normalise the type
2100 -> String -- ^ The type as a string
2101 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
2102 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
2103 hsc_env <- getHscEnv
2104 ty <- hscParseType str
2105 ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty
2106
2107 hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
2108 hscParseExpr expr = do
2109 maybe_stmt <- hscParseStmt expr
2110 case maybe_stmt of
2111 Just (L _ (BodyStmt _ expr _ _)) -> return expr
2112 _ -> throwOneError $
2113 mkPlainErrorMsgEnvelope noSrcSpan $
2114 GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $
2115 text "not an expression:" <+> quotes (text expr)
2116
2117 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
2118 hscParseStmt = hscParseThing parseStmt
2119
2120 hscParseStmtWithLocation :: String -> Int -> String
2121 -> Hsc (Maybe (GhciLStmt GhcPs))
2122 hscParseStmtWithLocation source linenumber stmt =
2123 hscParseThingWithLocation source linenumber parseStmt stmt
2124
2125 hscParseType :: String -> Hsc (LHsType GhcPs)
2126 hscParseType = hscParseThing parseType
2127
2128 hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)
2129 hscParseIdentifier hsc_env str =
2130 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
2131
2132 hscParseThing :: (Outputable thing, Data thing)
2133 => Lexer.P thing -> String -> Hsc thing
2134 hscParseThing = hscParseThingWithLocation "<interactive>" 1
2135
2136 hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
2137 -> Lexer.P thing -> String -> Hsc thing
2138 hscParseThingWithLocation source linenumber parser str = do
2139 dflags <- getDynFlags
2140 logger <- getLogger
2141 withTiming logger
2142 (text "Parser [source]")
2143 (const ()) $ {-# SCC "Parser" #-} do
2144
2145 let buf = stringToStringBuffer str
2146 loc = mkRealSrcLoc (fsLit source) linenumber 1
2147
2148 case unP parser (initParserState (initParserOpts dflags) buf loc) of
2149 PFailed pst ->
2150 handleWarningsThrowErrors (getPsMessages pst)
2151 POk pst thing -> do
2152 logWarningsReportErrors (getPsMessages pst)
2153 liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"
2154 FormatHaskell (ppr thing)
2155 liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"
2156 FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)
2157 return thing
2158
2159
2160 {- **********************************************************************
2161 %* *
2162 Desugar, simplify, convert to bytecode, and link an expression
2163 %* *
2164 %********************************************************************* -}
2165
2166 hscCompileCoreExpr :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue
2167 hscCompileCoreExpr hsc_env loc expr =
2168 case hscCompileCoreExprHook (hsc_hooks hsc_env) of
2169 Nothing -> hscCompileCoreExpr' hsc_env loc expr
2170 Just h -> h hsc_env loc expr
2171
2172 hscCompileCoreExpr' :: HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CoreExpr -> IO ForeignHValue
2173 hscCompileCoreExpr' hsc_env srcspan ds_expr
2174 = do { {- Simplify it -}
2175 -- Question: should we call SimpleOpt.simpleOptExpr here instead?
2176 -- It is, well, simpler, and does less inlining etc.
2177 simpl_expr <- simplifyExpr hsc_env ds_expr
2178
2179 {- Tidy it (temporary, until coreSat does cloning) -}
2180 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
2181
2182 {- Prepare for codegen -}
2183 ; prepd_expr <- corePrepExpr hsc_env tidy_expr
2184
2185 {- Lint if necessary -}
2186 ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
2187 ; let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
2188 ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
2189 ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
2190 ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",
2191 ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file",
2192 ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
2193
2194 ; let ictxt = hsc_IC hsc_env
2195 ; (binding_id, stg_expr, _, _) <-
2196 myCoreToStgExpr (hsc_logger hsc_env)
2197 (hsc_dflags hsc_env)
2198 ictxt
2199 True
2200 (icInteractiveModule ictxt)
2201 iNTERACTIVELoc
2202 prepd_expr
2203
2204 {- Convert to BCOs -}
2205 ; bcos <- byteCodeGen hsc_env
2206 (icInteractiveModule ictxt)
2207 stg_expr
2208 [] Nothing
2209
2210 {- load it -}
2211 ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
2212 {- Get the HValue for the root -}
2213 ; return (expectJust "hscCompileCoreExpr'"
2214 $ lookup (idName binding_id) fv_hvs) }
2215
2216
2217 {- **********************************************************************
2218 %* *
2219 Statistics on reading interfaces
2220 %* *
2221 %********************************************************************* -}
2222
2223 dumpIfaceStats :: HscEnv -> IO ()
2224 dumpIfaceStats hsc_env = do
2225 eps <- hscEPS hsc_env
2226 let
2227 logger = hsc_logger hsc_env
2228 dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats
2229 dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace
2230 when (dump_if_trace || dump_rn_stats) $
2231 logDumpMsg logger "Interface statistics" (ifaceStats eps)
2232
2233
2234 {- **********************************************************************
2235 %* *
2236 Progress Messages: Module i of n
2237 %* *
2238 %********************************************************************* -}
2239
2240 showModuleIndex :: (Int, Int) -> SDoc
2241 showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "
2242 where
2243 -- compute the length of x > 0 in base 10
2244 len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)
2245 pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr
2246
2247 writeInterfaceOnlyMode :: DynFlags -> Bool
2248 writeInterfaceOnlyMode dflags =
2249 gopt Opt_WriteInterface dflags &&
2250 NoBackend == backend dflags