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