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