Fix recompilation avoidance bug for implementor of hsig.
[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 imports1 = moduleEnvToList imports -- (Module, [ImportedBy])
944 imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])
945 pkgReqs = imp_trust_pkgs impInfo -- [UnitId]
946
947 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
948 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
949 condense (m, x:xs) = do imv <- foldlM cond' x xs
950 return (m, imv_span imv, imv_is_safe imv)
951
952 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
953 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
954 cond' v1 v2
955 | imv_is_safe v1 /= imv_is_safe v2
956 = throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
957 (text "Module" <+> ppr (imv_name v1) <+>
958 (text $ "is imported both as a safe and unsafe import!"))
959 | otherwise
960 = return v1
961
962 -- easier interface to work with
963 checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
964 checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
965
966 -- what pkg's to add to our trust requirements
967 pkgTrustReqs :: Set InstalledUnitId -> Set InstalledUnitId -> Bool -> ImportAvails
968 pkgTrustReqs req inf infPassed | safeInferOn dflags
969 && safeHaskell dflags == Sf_None && infPassed
970 = emptyImportAvails {
971 imp_trust_pkgs = req `S.union` inf
972 }
973 pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe
974 = emptyImportAvails
975 pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = req }
976
977 -- | Check that a module is safe to import.
978 --
979 -- We return True to indicate the import is safe and False otherwise
980 -- although in the False case an exception may be thrown first.
981 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
982 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
983 dflags <- getDynFlags
984 pkgs <- snd `fmap` hscCheckSafe' dflags m l
985 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
986 errs <- getWarnings
987 return $ isEmptyBag errs
988
989 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
990 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
991 hscGetSafe hsc_env m l = runHsc hsc_env $ do
992 dflags <- getDynFlags
993 (self, pkgs) <- hscCheckSafe' dflags m l
994 good <- isEmptyBag `fmap` getWarnings
995 clearWarnings -- don't want them printed...
996 let pkgs' | Just p <- self = S.insert p pkgs
997 | otherwise = pkgs
998 return (good, pkgs')
999
1000 -- | Is a module trusted? If not, throw or log errors depending on the type.
1001 -- Return (regardless of trusted or not) if the trust type requires the modules
1002 -- own package be trusted and a list of other packages required to be trusted
1003 -- (these later ones haven't been checked) but the own package trust has been.
1004 hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
1005 hscCheckSafe' dflags m l = do
1006 (tw, pkgs) <- isModSafe m l
1007 case tw of
1008 False -> return (Nothing, pkgs)
1009 True | isHomePkg m -> return (Nothing, pkgs)
1010 -- TODO: do we also have to check the trust of the instantiation?
1011 -- Not necessary if that is reflected in dependencies
1012 | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
1013 where
1014 isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
1015 isModSafe m l = do
1016 iface <- lookup' m
1017 case iface of
1018 -- can't load iface to check trust!
1019 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
1020 $ text "Can't load the interface file for" <+> ppr m
1021 <> text ", to check that it can be safely imported"
1022
1023 -- got iface, check trust
1024 Just iface' ->
1025 let trust = getSafeMode $ mi_trust iface'
1026 trust_own_pkg = mi_trust_pkg iface'
1027 -- check module is trusted
1028 safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
1029 -- check package is trusted
1030 safeP = packageTrusted trust trust_own_pkg m
1031 -- pkg trust reqs
1032 pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
1033 -- General errors we throw but Safe errors we log
1034 errs = case (safeM, safeP) of
1035 (True, True ) -> emptyBag
1036 (True, False) -> pkgTrustErr
1037 (False, _ ) -> modTrustErr
1038 in do
1039 logWarnings errs
1040 return (trust == Sf_Trustworthy, pkgRs)
1041
1042 where
1043 pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
1044 sep [ ppr (moduleName m)
1045 <> text ": Can't be safely imported!"
1046 , text "The package (" <> ppr (moduleUnitId m)
1047 <> text ") the module resides in isn't trusted."
1048 ]
1049 modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
1050 sep [ ppr (moduleName m)
1051 <> text ": Can't be safely imported!"
1052 , text "The module itself isn't safe." ]
1053
1054 -- | Check the package a module resides in is trusted. Safe compiled
1055 -- modules are trusted without requiring that their package is trusted. For
1056 -- trustworthy modules, modules in the home package are trusted but
1057 -- otherwise we check the package trust flag.
1058 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
1059 packageTrusted Sf_None _ _ = False -- shouldn't hit these cases
1060 packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness.
1061 packageTrusted _ _ _
1062 | not (packageTrustOn dflags) = True
1063 packageTrusted Sf_Safe False _ = True
1064 packageTrusted _ _ m
1065 | isHomePkg m = True
1066 | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
1067
1068 lookup' :: Module -> Hsc (Maybe ModIface)
1069 lookup' m = do
1070 hsc_env <- getHscEnv
1071 hsc_eps <- liftIO $ hscEPS hsc_env
1072 let pkgIfaceT = eps_PIT hsc_eps
1073 homePkgT = hsc_HPT hsc_env
1074 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
1075 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
1076 -- as the compiler hasn't filled in the various module tables
1077 -- so we need to call 'getModuleInterface' to load from disk
1078 iface' <- case iface of
1079 Just _ -> return iface
1080 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
1081 return iface'
1082
1083
1084 isHomePkg :: Module -> Bool
1085 isHomePkg m
1086 | thisPackage dflags == moduleUnitId m = True
1087 | otherwise = False
1088
1089 -- | Check the list of packages are trusted.
1090 checkPkgTrust :: DynFlags -> Set InstalledUnitId -> Hsc ()
1091 checkPkgTrust dflags pkgs =
1092 case errors of
1093 [] -> return ()
1094 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1095 where
1096 errors = S.foldr go [] pkgs
1097 go pkg acc
1098 | trusted $ getInstalledPackageDetails dflags pkg
1099 = acc
1100 | otherwise
1101 = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
1102 $ text "The package (" <> ppr pkg <> text ") is required" <>
1103 text " to be trusted but it isn't!"
1104
1105 -- | Set module to unsafe and (potentially) wipe trust information.
1106 --
1107 -- Make sure to call this method to set a module to inferred unsafe, it should
1108 -- be a central and single failure method. We only wipe the trust information
1109 -- when we aren't in a specific Safe Haskell mode.
1110 --
1111 -- While we only use this for recording that a module was inferred unsafe, we
1112 -- may call it on modules using Trustworthy or Unsafe flags so as to allow
1113 -- warning flags for safety to function correctly. See Note [Safe Haskell
1114 -- Inference].
1115 markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1116 markUnsafeInfer tcg_env whyUnsafe = do
1117 dflags <- getDynFlags
1118
1119 when (wopt Opt_WarnUnsafe dflags)
1120 (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $
1121 mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
1122
1123 liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
1124 -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other
1125 -- times inference may be on but we are in Trustworthy mode -- so we want
1126 -- to record safe-inference failed but not wipe the trust dependencies.
1127 case safeHaskell dflags == Sf_None of
1128 True -> return $ tcg_env { tcg_imports = wiped_trust }
1129 False -> return tcg_env
1130
1131 where
1132 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
1133 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1134 whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
1135 , text "Reason:"
1136 , nest 4 $ (vcat $ badFlags df) $+$
1137 (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
1138 (vcat $ badInsts $ tcg_insts tcg_env)
1139 ]
1140 badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer
1141 badFlag df (str,loc,on,_)
1142 | on df = [mkLocMessage SevOutput (loc df) $
1143 text str <+> text "is not allowed in Safe Haskell"]
1144 | otherwise = []
1145 badInsts insts = concat $ map badInst insts
1146
1147 checkOverlap (NoOverlap _) = False
1148 checkOverlap _ = True
1149
1150 badInst ins | checkOverlap (overlapMode (is_flag ins))
1151 = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
1152 ppr (overlapMode $ is_flag ins) <+>
1153 text "overlap mode isn't allowed in Safe Haskell"]
1154 | otherwise = []
1155
1156
1157 -- | Figure out the final correct safe haskell mode
1158 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
1159 hscGetSafeMode tcg_env = do
1160 dflags <- getDynFlags
1161 liftIO $ finalSafeMode dflags tcg_env
1162
1163 --------------------------------------------------------------
1164 -- Simplifiers
1165 --------------------------------------------------------------
1166
1167 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1168 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1169
1170 hscSimplify' :: ModGuts -> Hsc ModGuts
1171 hscSimplify' ds_result = do
1172 hsc_env <- getHscEnv
1173 {-# SCC "Core2Core" #-}
1174 liftIO $ core2core hsc_env ds_result
1175
1176 --------------------------------------------------------------
1177 -- Interface generators
1178 --------------------------------------------------------------
1179
1180 hscSimpleIface :: HscEnv
1181 -> TcGblEnv
1182 -> Maybe Fingerprint
1183 -> IO (ModIface, Bool, ModDetails)
1184 hscSimpleIface hsc_env tc_result mb_old_iface
1185 = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
1186
1187 hscSimpleIface' :: TcGblEnv
1188 -> Maybe Fingerprint
1189 -> Hsc (ModIface, Bool, ModDetails)
1190 hscSimpleIface' tc_result mb_old_iface = do
1191 hsc_env <- getHscEnv
1192 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1193 safe_mode <- hscGetSafeMode tc_result
1194 (new_iface, no_change)
1195 <- {-# SCC "MkFinalIface" #-}
1196 liftIO $
1197 mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
1198 -- And the answer is ...
1199 liftIO $ dumpIfaceStats hsc_env
1200 return (new_iface, no_change, details)
1201
1202 hscNormalIface :: HscEnv
1203 -> ModGuts
1204 -> Maybe Fingerprint
1205 -> IO (ModIface, Bool, ModDetails, CgGuts)
1206 hscNormalIface hsc_env simpl_result mb_old_iface =
1207 runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
1208
1209 hscNormalIface' :: ModGuts
1210 -> Maybe Fingerprint
1211 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1212 hscNormalIface' simpl_result mb_old_iface = do
1213 hsc_env <- getHscEnv
1214 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1215 liftIO $ tidyProgram hsc_env simpl_result
1216
1217 -- BUILD THE NEW ModIface and ModDetails
1218 -- and emit external core if necessary
1219 -- This has to happen *after* code gen so that the back-end
1220 -- info has been set. Not yet clear if it matters waiting
1221 -- until after code output
1222 (new_iface, no_change)
1223 <- {-# SCC "MkFinalIface" #-}
1224 liftIO $
1225 mkIface hsc_env mb_old_iface details simpl_result
1226
1227 liftIO $ dumpIfaceStats hsc_env
1228
1229 -- Return the prepared code.
1230 return (new_iface, no_change, details, cg_guts)
1231
1232 --------------------------------------------------------------
1233 -- BackEnd combinators
1234 --------------------------------------------------------------
1235
1236 hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
1237 hscWriteIface dflags iface no_change mod_summary = do
1238 let ifaceFile = ml_hi_file (ms_location mod_summary)
1239 unless no_change $
1240 {-# SCC "writeIface" #-}
1241 writeIfaceFile dflags ifaceFile iface
1242 whenGeneratingDynamicToo dflags $ do
1243 -- TODO: We should do a no_change check for the dynamic
1244 -- interface file too
1245 -- TODO: Should handle the dynamic hi filename properly
1246 let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
1247 dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
1248 dynDflags = dynamicTooMkDynamicDynFlags dflags
1249 writeIfaceFile dynDflags dynIfaceFile' iface
1250
1251 -- | Compile to hard-code.
1252 hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
1253 -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
1254 -- ^ @Just f@ <=> _stub.c is f
1255 hscGenHardCode hsc_env cgguts mod_summary output_filename = do
1256 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1257 -- From now on, we just use the bits we need.
1258 cg_module = this_mod,
1259 cg_binds = core_binds,
1260 cg_tycons = tycons,
1261 cg_foreign = foreign_stubs0,
1262 cg_foreign_files = foreign_files,
1263 cg_dep_pkgs = dependencies,
1264 cg_hpc_info = hpc_info } = cgguts
1265 dflags = hsc_dflags hsc_env
1266 location = ms_location mod_summary
1267 data_tycons = filter isDataTyCon tycons
1268 -- cg_tycons includes newtypes, for the benefit of External Core,
1269 -- but we don't generate any code for newtypes
1270
1271 -------------------
1272 -- PREPARE FOR CODE GENERATION
1273 -- Do saturation and convert to A-normal form
1274 prepd_binds <- {-# SCC "CorePrep" #-}
1275 corePrepPgm hsc_env this_mod location
1276 core_binds data_tycons
1277 ----------------- Convert to STG ------------------
1278 (stg_binds, cost_centre_info)
1279 <- {-# SCC "CoreToStg" #-}
1280 myCoreToStg dflags this_mod prepd_binds
1281
1282 let prof_init = profilingInitCode this_mod cost_centre_info
1283 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1284
1285 ------------------ Code generation ------------------
1286
1287 -- The back-end is streamed: each top-level function goes
1288 -- from Stg all the way to asm before dealing with the next
1289 -- top-level function, so showPass isn't very useful here.
1290 -- Hence we have one showPass for the whole backend, the
1291 -- next showPass after this will be "Assembler".
1292 withTiming (pure dflags)
1293 (text "CodeGen"<+>brackets (ppr this_mod))
1294 (const ()) $ do
1295 cmms <- {-# SCC "StgCmm" #-}
1296 doCodeGen hsc_env this_mod data_tycons
1297 cost_centre_info
1298 stg_binds hpc_info
1299
1300 ------------------ Code output -----------------------
1301 rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
1302 cmmToRawCmm dflags cmms
1303
1304 let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
1305 (ppr a)
1306 return a
1307 rawcmms1 = Stream.mapM dump rawcmms0
1308
1309 (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)
1310 <- {-# SCC "codeOutput" #-}
1311 codeOutput dflags this_mod output_filename location
1312 foreign_stubs foreign_files dependencies rawcmms1
1313 return (output_filename, stub_c_exists, foreign_fps)
1314
1315
1316 hscInteractive :: HscEnv
1317 -> CgGuts
1318 -> ModSummary
1319 -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
1320 hscInteractive hsc_env cgguts mod_summary = do
1321 let dflags = hsc_dflags hsc_env
1322 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1323 -- From now on, we just use the bits we need.
1324 cg_module = this_mod,
1325 cg_binds = core_binds,
1326 cg_tycons = tycons,
1327 cg_foreign = foreign_stubs,
1328 cg_modBreaks = mod_breaks,
1329 cg_spt_entries = spt_entries } = cgguts
1330
1331 location = ms_location mod_summary
1332 data_tycons = filter isDataTyCon tycons
1333 -- cg_tycons includes newtypes, for the benefit of External Core,
1334 -- but we don't generate any code for newtypes
1335
1336 -------------------
1337 -- PREPARE FOR CODE GENERATION
1338 -- Do saturation and convert to A-normal form
1339 prepd_binds <- {-# SCC "CorePrep" #-}
1340 corePrepPgm hsc_env this_mod location core_binds data_tycons
1341 ----------------- Generate byte code ------------------
1342 comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
1343 ------------------ Create f-x-dynamic C-side stuff -----
1344 (_istub_h_exists, istub_c_exists)
1345 <- outputForeignStubs dflags this_mod location foreign_stubs
1346 return (istub_c_exists, comp_bc, spt_entries)
1347
1348 ------------------------------
1349
1350 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
1351 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
1352 let dflags = hsc_dflags hsc_env
1353 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1354 liftIO $ do
1355 us <- mkSplitUniqSupply 'S'
1356 let initTopSRT = initUs_ us emptySRT
1357 dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
1358 (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
1359 rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
1360 let -- Make up a module name to give the NCG. We can't pass bottom here
1361 -- lest we reproduce #11784.
1362 mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
1363 cmm_mod = mkModule (thisPackage dflags) mod_name
1364 _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
1365 rawCmms
1366 return ()
1367 where
1368 no_loc = ModLocation{ ml_hs_file = Just filename,
1369 ml_hi_file = panic "hscCompileCmmFile: no hi file",
1370 ml_obj_file = panic "hscCompileCmmFile: no obj file" }
1371
1372 -------------------- Stuff for new code gen ---------------------
1373
1374 doCodeGen :: HscEnv -> Module -> [TyCon]
1375 -> CollectedCCs
1376 -> [StgTopBinding]
1377 -> HpcInfo
1378 -> IO (Stream IO CmmGroup ())
1379 -- Note we produce a 'Stream' of CmmGroups, so that the
1380 -- backend can be run incrementally. Otherwise it generates all
1381 -- the C-- up front, which has a significant space cost.
1382 doCodeGen hsc_env this_mod data_tycons
1383 cost_centre_info stg_binds hpc_info = do
1384 let dflags = hsc_dflags hsc_env
1385
1386 let cmm_stream :: Stream IO CmmGroup ()
1387 cmm_stream = {-# SCC "StgCmm" #-}
1388 StgCmm.codeGen dflags this_mod data_tycons
1389 cost_centre_info stg_binds hpc_info
1390
1391 -- codegen consumes a stream of CmmGroup, and produces a new
1392 -- stream of CmmGroup (not necessarily synchronised: one
1393 -- CmmGroup on input may produce many CmmGroups on output due
1394 -- to proc-point splitting).
1395
1396 let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
1397 "Cmm produced by codegen" (ppr a)
1398 return a
1399
1400 ppr_stream1 = Stream.mapM dump1 cmm_stream
1401
1402 -- We are building a single SRT for the entire module, so
1403 -- we must thread it through all the procedures as we cps-convert them.
1404 us <- mkSplitUniqSupply 'S'
1405
1406 -- When splitting, we generate one SRT per split chunk, otherwise
1407 -- we generate one SRT for the whole module.
1408 let
1409 pipeline_stream
1410 | gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags ||
1411 osSubsectionsViaSymbols (platformOS (targetPlatform dflags))
1412 = {-# SCC "cmmPipeline" #-}
1413 let run_pipeline us cmmgroup = do
1414 let (topSRT', us') = initUs us emptySRT
1415 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
1416 let srt | isEmptySRT topSRT = []
1417 | otherwise = srtToData topSRT
1418 return (us', srt ++ cmmgroup)
1419
1420 in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
1421 return ()
1422
1423 | otherwise
1424 = {-# SCC "cmmPipeline" #-}
1425 let initTopSRT = initUs_ us emptySRT
1426 run_pipeline = cmmPipeline hsc_env
1427 in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
1428 Stream.yield (srtToData topSRT)
1429
1430 let
1431 dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
1432 "Output Cmm" (ppr a)
1433 return a
1434
1435 ppr_stream2 = Stream.mapM dump2 pipeline_stream
1436
1437 return ppr_stream2
1438
1439
1440
1441 myCoreToStg :: DynFlags -> Module -> CoreProgram
1442 -> IO ( [StgTopBinding] -- output program
1443 , CollectedCCs) -- cost centre info (declared and used)
1444 myCoreToStg dflags this_mod prepd_binds = do
1445 let stg_binds
1446 = {-# SCC "Core2Stg" #-}
1447 coreToStg dflags this_mod prepd_binds
1448
1449 (stg_binds2, cost_centre_info)
1450 <- {-# SCC "Stg2Stg" #-}
1451 stg2stg dflags this_mod stg_binds
1452
1453 return (stg_binds2, cost_centre_info)
1454
1455
1456 {- **********************************************************************
1457 %* *
1458 \subsection{Compiling a do-statement}
1459 %* *
1460 %********************************************************************* -}
1461
1462 {-
1463 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1464 you run it you get a list of HValues that should be the same length as the list
1465 of names; add them to the ClosureEnv.
1466
1467 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1468 IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
1469 -}
1470
1471 -- | Compile a stmt all the way to an HValue, but don't run it
1472 --
1473 -- We return Nothing to indicate an empty statement (or comment only), not a
1474 -- parse error.
1475 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
1476 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1477
1478 -- | Compile a stmt all the way to an HValue, but don't run it
1479 --
1480 -- We return Nothing to indicate an empty statement (or comment only), not a
1481 -- parse error.
1482 hscStmtWithLocation :: HscEnv
1483 -> String -- ^ The statement
1484 -> String -- ^ The source
1485 -> Int -- ^ Starting line
1486 -> IO ( Maybe ([Id]
1487 , ForeignHValue {- IO [HValue] -}
1488 , FixityEnv))
1489 hscStmtWithLocation hsc_env0 stmt source linenumber =
1490 runInteractiveHsc hsc_env0 $ do
1491 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1492 case maybe_stmt of
1493 Nothing -> return Nothing
1494
1495 Just parsed_stmt -> do
1496 hsc_env <- getHscEnv
1497 liftIO $ hscParsedStmt hsc_env parsed_stmt
1498
1499 hscParsedStmt :: HscEnv
1500 -> GhciLStmt RdrName -- ^ The parsed statement
1501 -> IO ( Maybe ([Id]
1502 , ForeignHValue {- IO [HValue] -}
1503 , FixityEnv))
1504 hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
1505 -- Rename and typecheck it
1506 (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
1507
1508 -- Desugar it
1509 ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
1510 liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
1511 handleWarnings
1512
1513 -- Then code-gen, and link it
1514 -- It's important NOT to have package 'interactive' as thisUnitId
1515 -- for linking, else we try to link 'main' and can't find it.
1516 -- Whereas the linker already knows to ignore 'interactive'
1517 let src_span = srcLocSpan interactiveSrcLoc
1518 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1519
1520 return $ Just (ids, hval, fix_env)
1521
1522 -- | Compile a decls
1523 hscDecls :: HscEnv
1524 -> String -- ^ The statement
1525 -> IO ([TyThing], InteractiveContext)
1526 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1527
1528 -- | Compile a decls
1529 hscDeclsWithLocation :: HscEnv
1530 -> String -- ^ The statement
1531 -> String -- ^ The source
1532 -> Int -- ^ Starting line
1533 -> IO ([TyThing], InteractiveContext)
1534 hscDeclsWithLocation hsc_env0 str source linenumber =
1535 runInteractiveHsc hsc_env0 $ do
1536 L _ (HsModule{ hsmodDecls = decls }) <-
1537 hscParseThingWithLocation source linenumber parseModule str
1538
1539 {- Rename and typecheck it -}
1540 hsc_env <- getHscEnv
1541 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
1542
1543 {- Grab the new instances -}
1544 -- We grab the whole environment because of the overlapping that may have
1545 -- been done. See the notes at the definition of InteractiveContext
1546 -- (ic_instances) for more details.
1547 let defaults = tcg_default tc_gblenv
1548
1549 {- Desugar it -}
1550 -- We use a basically null location for iNTERACTIVE
1551 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1552 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1553 ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
1554 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1555
1556 {- Simplify -}
1557 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1558
1559 {- Tidy -}
1560 (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1561
1562 let !CgGuts{ cg_module = this_mod,
1563 cg_binds = core_binds,
1564 cg_tycons = tycons,
1565 cg_modBreaks = mod_breaks } = tidy_cg
1566
1567 !ModDetails { md_insts = cls_insts
1568 , md_fam_insts = fam_insts } = mod_details
1569 -- Get the *tidied* cls_insts and fam_insts
1570
1571 data_tycons = filter isDataTyCon tycons
1572
1573 {- Prepare For Code Generation -}
1574 -- Do saturation and convert to A-normal form
1575 prepd_binds <- {-# SCC "CorePrep" #-}
1576 liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
1577
1578 {- Generate byte code -}
1579 cbc <- liftIO $ byteCodeGen hsc_env this_mod
1580 prepd_binds data_tycons mod_breaks
1581
1582 let src_span = srcLocSpan interactiveSrcLoc
1583 liftIO $ linkDecls hsc_env src_span cbc
1584
1585 {- Load static pointer table entries -}
1586 liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
1587
1588 let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
1589 patsyns = mg_patsyns simpl_mg
1590
1591 ext_ids = [ id | id <- bindersOfBinds core_binds
1592 , isExternalName (idName id)
1593 , not (isDFunId id || isImplicitId id) ]
1594 -- We only need to keep around the external bindings
1595 -- (as decided by TidyPgm), since those are the only ones
1596 -- that might later be looked up by name. But we can exclude
1597 -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
1598 -- - Implicit Ids, which are implicit in tcs
1599 -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv
1600
1601 new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
1602 ictxt = hsc_IC hsc_env
1603 -- See Note [Fixity declarations in GHCi]
1604 fix_env = tcg_fix_env tc_gblenv
1605 new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
1606 fam_insts defaults fix_env
1607 return (new_tythings, new_ictxt)
1608
1609 -- | Load the given static-pointer table entries into the interpreter.
1610 -- See Note [Grand plan for static forms] in StaticPtrTable.
1611 hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
1612 hscAddSptEntries hsc_env entries = do
1613 let add_spt_entry :: SptEntry -> IO ()
1614 add_spt_entry (SptEntry i fpr) = do
1615 val <- getHValue hsc_env (idName i)
1616 pprTrace "add_spt_entry" (ppr fpr <+> ppr i) $
1617 addSptEntry hsc_env fpr val
1618 mapM_ add_spt_entry entries
1619
1620 {-
1621 Note [Fixity declarations in GHCi]
1622 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1623
1624 To support fixity declarations on types defined within GHCi (as requested
1625 in #10018) we record the fixity environment in InteractiveContext.
1626 When we want to evaluate something TcRnDriver.runTcInteractive pulls out this
1627 fixity environment and uses it to initialize the global typechecker environment.
1628 After the typechecker has finished its business, an updated fixity environment
1629 (reflecting whatever fixity declarations were present in the statements we
1630 passed it) will be returned from hscParsedStmt. This is passed to
1631 updateFixityEnv, which will stuff it back into InteractiveContext, to be
1632 used in evaluating the next statement.
1633
1634 -}
1635
1636 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1637 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1638 (L _ (HsModule{hsmodImports=is})) <-
1639 hscParseThing parseModule str
1640 case is of
1641 [L _ i] -> return i
1642 _ -> liftIO $ throwOneError $
1643 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
1644 text "parse error in import declaration"
1645
1646 -- | Typecheck an expression (but don't run it)
1647 hscTcExpr :: HscEnv
1648 -> TcRnExprMode
1649 -> String -- ^ The expression
1650 -> IO Type
1651 hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
1652 hsc_env <- getHscEnv
1653 parsed_expr <- hscParseExpr expr
1654 ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
1655
1656 -- | Find the kind of a type
1657 -- Currently this does *not* generalise the kinds of the type
1658 hscKcType
1659 :: HscEnv
1660 -> Bool -- ^ Normalise the type
1661 -> String -- ^ The type as a string
1662 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1663 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1664 hsc_env <- getHscEnv
1665 ty <- hscParseType str
1666 ioMsgMaybe $ tcRnType hsc_env normalise ty
1667
1668 hscParseExpr :: String -> Hsc (LHsExpr RdrName)
1669 hscParseExpr expr = do
1670 hsc_env <- getHscEnv
1671 maybe_stmt <- hscParseStmt expr
1672 case maybe_stmt of
1673 Just (L _ (BodyStmt expr _ _ _)) -> return expr
1674 _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
1675 (text "not an expression:" <+> quotes (text expr))
1676
1677 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
1678 hscParseStmt = hscParseThing parseStmt
1679
1680 hscParseStmtWithLocation :: String -> Int -> String
1681 -> Hsc (Maybe (GhciLStmt RdrName))
1682 hscParseStmtWithLocation source linenumber stmt =
1683 hscParseThingWithLocation source linenumber parseStmt stmt
1684
1685 hscParseType :: String -> Hsc (LHsType RdrName)
1686 hscParseType = hscParseThing parseType
1687
1688 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1689 hscParseIdentifier hsc_env str =
1690 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1691
1692 hscParseThing :: (Outputable thing, Data thing)
1693 => Lexer.P thing -> String -> Hsc thing
1694 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1695
1696 hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
1697 -> Lexer.P thing -> String -> Hsc thing
1698 hscParseThingWithLocation source linenumber parser str
1699 = withTiming getDynFlags
1700 (text "Parser [source]")
1701 (const ()) $ {-# SCC "Parser" #-} do
1702 dflags <- getDynFlags
1703
1704 let buf = stringToStringBuffer str
1705 loc = mkRealSrcLoc (fsLit source) linenumber 1
1706
1707 case unP parser (mkPState dflags buf loc) of
1708 PFailed span err -> do
1709 let msg = mkPlainErrMsg dflags span err
1710 throwErrors $ unitBag msg
1711
1712 POk pst thing -> do
1713 logWarningsReportErrors (getMessages pst dflags)
1714 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1715 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
1716 text $ showAstData NoBlankSrcSpan thing
1717 return thing
1718
1719
1720 {- **********************************************************************
1721 %* *
1722 Desugar, simplify, convert to bytecode, and link an expression
1723 %* *
1724 %********************************************************************* -}
1725
1726 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
1727 hscCompileCoreExpr hsc_env =
1728 lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
1729
1730 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
1731 hscCompileCoreExpr' hsc_env srcspan ds_expr
1732 = do { let dflags = hsc_dflags hsc_env
1733
1734 {- Simplify it -}
1735 ; simpl_expr <- simplifyExpr dflags ds_expr
1736
1737 {- Tidy it (temporary, until coreSat does cloning) -}
1738 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1739
1740 {- Prepare for codegen -}
1741 ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
1742
1743 {- Lint if necessary -}
1744 ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
1745
1746 {- Convert to BCOs -}
1747 ; bcos <- coreExprToBCOs hsc_env
1748 (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
1749
1750 {- link it -}
1751 ; hval <- linkExpr hsc_env srcspan bcos
1752
1753 ; return hval }
1754
1755
1756 {- **********************************************************************
1757 %* *
1758 Statistics on reading interfaces
1759 %* *
1760 %********************************************************************* -}
1761
1762 dumpIfaceStats :: HscEnv -> IO ()
1763 dumpIfaceStats hsc_env = do
1764 eps <- readIORef (hsc_EPS hsc_env)
1765 dumpIfSet dflags (dump_if_trace || dump_rn_stats)
1766 "Interface statistics"
1767 (ifaceStats eps)
1768 where
1769 dflags = hsc_dflags hsc_env
1770 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1771 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1772
1773
1774 {- **********************************************************************
1775 %* *
1776 Progress Messages: Module i of n
1777 %* *
1778 %********************************************************************* -}
1779
1780 showModuleIndex :: (Int, Int) -> String
1781 showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1782 where
1783 n_str = show n
1784 i_str = show i
1785 padded = replicate (length n_str - length i_str) ' ' ++ i_str