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