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