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