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