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