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