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