Unify hsig and hs-boot; add preliminary "hs-boot" merging.
[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 ||
808 ms_hsc_src mod_summary == HsSrcFile )
809 hpm <- hscParse' mod_summary
810 hsc_env <- getHscEnv
811 tcg_env <- tcRnModule' hsc_env mod_summary False hpm
812 return tcg_env
813
814 --------------------------------------------------------------
815 -- Safe Haskell
816 --------------------------------------------------------------
817
818 -- Note [Safe Haskell Trust Check]
819 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
820 -- Safe Haskell checks that an import is trusted according to the following
821 -- rules for an import of module M that resides in Package P:
822 --
823 -- * If M is recorded as Safe and all its trust dependencies are OK
824 -- then M is considered safe.
825 -- * If M is recorded as Trustworthy and P is considered trusted and
826 -- all M's trust dependencies are OK then M is considered safe.
827 --
828 -- By trust dependencies we mean that the check is transitive. So if
829 -- a module M that is Safe relies on a module N that is trustworthy,
830 -- importing module M will first check (according to the second case)
831 -- that N is trusted before checking M is trusted.
832 --
833 -- This is a minimal description, so please refer to the user guide
834 -- for more details. The user guide is also considered the authoritative
835 -- source in this matter, not the comments or code.
836
837
838 -- Note [Safe Haskell Inference]
839 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
840 -- Safe Haskell does Safe inference on modules that don't have any specific
841 -- safe haskell mode flag. The basic aproach to this is:
842 -- * When deciding if we need to do a Safe language check, treat
843 -- an unmarked module as having -XSafe mode specified.
844 -- * For checks, don't throw errors but return them to the caller.
845 -- * Caller checks if there are errors:
846 -- * For modules explicitly marked -XSafe, we throw the errors.
847 -- * For unmarked modules (inference mode), we drop the errors
848 -- and mark the module as being Unsafe.
849 --
850 -- It used to be that we only did safe inference on modules that had no Safe
851 -- Haskell flags, but now we perform safe inference on all modules as we want
852 -- to allow users to set the `-fwarn-safe`, `-fwarn-unsafe` and
853 -- `-fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a
854 -- user can ensure their assumptions are correct and see reasons for why a
855 -- module is safe or unsafe.
856 --
857 -- This is tricky as we must be careful when we should throw an error compared
858 -- to just warnings. For checking safe imports we manage it as two steps. First
859 -- we check any imports that are required to be safe, then we check all other
860 -- imports to see if we can infer them to be safe.
861
862
863 -- | Check that the safe imports of the module being compiled are valid.
864 -- If not we either issue a compilation error if the module is explicitly
865 -- using Safe Haskell, or mark the module as unsafe if we're in safe
866 -- inference mode.
867 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
868 hscCheckSafeImports tcg_env = do
869 dflags <- getDynFlags
870 tcg_env' <- checkSafeImports dflags tcg_env
871 checkRULES dflags tcg_env'
872
873 where
874 checkRULES dflags tcg_env' = do
875 case safeLanguageOn dflags of
876 True -> do
877 -- XSafe: we nuke user written RULES
878 logWarnings $ warns dflags (tcg_rules tcg_env')
879 return tcg_env' { tcg_rules = [] }
880 False
881 -- SafeInferred: user defined RULES, so not safe
882 | safeInferOn dflags && not (null $ tcg_rules tcg_env')
883 -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
884
885 -- Trustworthy OR SafeInferred: with no RULES
886 | otherwise
887 -> return tcg_env'
888
889 warns dflags rules = listToBag $ map (warnRules dflags) rules
890 warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
891 mkPlainWarnMsg dflags loc $
892 text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
893 text "User defined rules are disabled under Safe Haskell"
894
895 -- | Validate that safe imported modules are actually safe. For modules in the
896 -- HomePackage (the package the module we are compiling in resides) this just
897 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
898 -- that reside in another package we also must check that the external pacakge
899 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
900 -- information.
901 --
902 -- The code for this is quite tricky as the whole algorithm is done in a few
903 -- distinct phases in different parts of the code base. See
904 -- RnNames.rnImportDecl for where package trust dependencies for a module are
905 -- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
906 -- Transitively] and the Note [RnNames . Trust Own Package].
907 checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
908 checkSafeImports dflags tcg_env
909 = do
910 imps <- mapM condense imports'
911 let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
912
913 -- We want to use the warning state specifically for detecting if safe
914 -- inference has failed, so store and clear any existing warnings.
915 oldErrs <- getWarnings
916 clearWarnings
917
918 -- Check safe imports are correct
919 safePkgs <- mapM checkSafe safeImps
920 safeErrs <- getWarnings
921 clearWarnings
922
923 -- Check non-safe imports are correct if inferring safety
924 -- See the Note [Safe Haskell Inference]
925 (infErrs, infPkgs) <- case (safeInferOn dflags) of
926 False -> return (emptyBag, [])
927 True -> do infPkgs <- mapM checkSafe regImps
928 infErrs <- getWarnings
929 clearWarnings
930 return (infErrs, infPkgs)
931
932 -- restore old errors
933 logWarnings oldErrs
934
935 case (isEmptyBag safeErrs) of
936 -- Failed safe check
937 False -> liftIO . throwIO . mkSrcErr $ safeErrs
938
939 -- Passed safe check
940 True -> do
941 let infPassed = isEmptyBag infErrs
942 tcg_env' <- case (not infPassed) of
943 True -> markUnsafeInfer tcg_env infErrs
944 False -> return tcg_env
945 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs
946 let newTrust = pkgTrustReqs safePkgs infPkgs infPassed
947 return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
948
949 where
950 impInfo = tcg_imports tcg_env -- ImportAvails
951 imports = imp_mods impInfo -- ImportedMods
952 imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
953 pkgReqs = imp_trust_pkgs impInfo -- [PackageKey]
954
955 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
956 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
957 condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
958 return (m, l, s)
959
960 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
961 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
962 cond' v1@(m1,_,l1,s1) (_,_,_,s2)
963 | s1 /= s2
964 = throwErrors $ unitBag $ mkPlainErrMsg dflags l1
965 (text "Module" <+> ppr m1 <+>
966 (text $ "is imported both as a safe and unsafe import!"))
967 | otherwise
968 = return v1
969
970 -- easier interface to work with
971 checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
972
973 -- what pkg's to add to our trust requirements
974 pkgTrustReqs req inf infPassed | safeInferOn dflags
975 && safeHaskell dflags == Sf_None && infPassed
976 = emptyImportAvails {
977 imp_trust_pkgs = catMaybes req ++ catMaybes inf
978 }
979 pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe
980 = emptyImportAvails
981 pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req }
982
983 -- | Check that a module is safe to import.
984 --
985 -- We return True to indicate the import is safe and False otherwise
986 -- although in the False case an exception may be thrown first.
987 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
988 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
989 dflags <- getDynFlags
990 pkgs <- snd `fmap` hscCheckSafe' dflags m l
991 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
992 errs <- getWarnings
993 return $ isEmptyBag errs
994
995 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
996 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageKey])
997 hscGetSafe hsc_env m l = runHsc hsc_env $ do
998 dflags <- getDynFlags
999 (self, pkgs) <- hscCheckSafe' dflags m l
1000 good <- isEmptyBag `fmap` getWarnings
1001 clearWarnings -- don't want them printed...
1002 let pkgs' | Just p <- self = p:pkgs
1003 | otherwise = pkgs
1004 return (good, pkgs')
1005
1006 -- | Is a module trusted? If not, throw or log errors depending on the type.
1007 -- Return (regardless of trusted or not) if the trust type requires the modules
1008 -- own package be trusted and a list of other packages required to be trusted
1009 -- (these later ones haven't been checked) but the own package trust has been.
1010 hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageKey, [PackageKey])
1011 hscCheckSafe' dflags m l = do
1012 (tw, pkgs) <- isModSafe m l
1013 case tw of
1014 False -> return (Nothing, pkgs)
1015 True | isHomePkg m -> return (Nothing, pkgs)
1016 | otherwise -> return (Just $ modulePackageKey m, pkgs)
1017 where
1018 isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey])
1019 isModSafe m l = do
1020 iface <- lookup' m
1021 case iface of
1022 -- can't load iface to check trust!
1023 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
1024 $ text "Can't load the interface file for" <+> ppr m
1025 <> text ", to check that it can be safely imported"
1026
1027 -- got iface, check trust
1028 Just iface' ->
1029 let trust = getSafeMode $ mi_trust iface'
1030 trust_own_pkg = mi_trust_pkg iface'
1031 -- check module is trusted
1032 safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
1033 -- check package is trusted
1034 safeP = packageTrusted trust trust_own_pkg m
1035 -- pkg trust reqs
1036 pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
1037 -- General errors we throw but Safe errors we log
1038 errs = case (safeM, safeP) of
1039 (True, True ) -> emptyBag
1040 (True, False) -> pkgTrustErr
1041 (False, _ ) -> modTrustErr
1042 in do
1043 logWarnings errs
1044 return (trust == Sf_Trustworthy, pkgRs)
1045
1046 where
1047 pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
1048 sep [ ppr (moduleName m)
1049 <> text ": Can't be safely imported!"
1050 , text "The package (" <> ppr (modulePackageKey m)
1051 <> text ") the module resides in isn't trusted."
1052 ]
1053 modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
1054 sep [ ppr (moduleName m)
1055 <> text ": Can't be safely imported!"
1056 , text "The module itself isn't safe." ]
1057
1058 -- | Check the package a module resides in is trusted. Safe compiled
1059 -- modules are trusted without requiring that their package is trusted. For
1060 -- trustworthy modules, modules in the home package are trusted but
1061 -- otherwise we check the package trust flag.
1062 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
1063 packageTrusted Sf_None _ _ = False -- shouldn't hit these cases
1064 packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness.
1065 packageTrusted _ _ _
1066 | not (packageTrustOn dflags) = True
1067 packageTrusted Sf_Safe False _ = True
1068 packageTrusted _ _ m
1069 | isHomePkg m = True
1070 | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m)
1071
1072 lookup' :: Module -> Hsc (Maybe ModIface)
1073 lookup' m = do
1074 hsc_env <- getHscEnv
1075 hsc_eps <- liftIO $ hscEPS hsc_env
1076 let pkgIfaceT = eps_PIT hsc_eps
1077 homePkgT = hsc_HPT hsc_env
1078 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
1079 #ifdef GHCI
1080 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
1081 -- as the compiler hasn't filled in the various module tables
1082 -- so we need to call 'getModuleInterface' to load from disk
1083 iface' <- case iface of
1084 Just _ -> return iface
1085 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
1086 return iface'
1087 #else
1088 return iface
1089 #endif
1090
1091
1092 isHomePkg :: Module -> Bool
1093 isHomePkg m
1094 | thisPackage dflags == modulePackageKey m = True
1095 | otherwise = False
1096
1097 -- | Check the list of packages are trusted.
1098 checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc ()
1099 checkPkgTrust dflags pkgs =
1100 case errors of
1101 [] -> return ()
1102 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1103 where
1104 errors = catMaybes $ map go pkgs
1105 go pkg
1106 | trusted $ getPackageDetails dflags pkg
1107 = Nothing
1108 | otherwise
1109 = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
1110 $ text "The package (" <> ppr pkg <> text ") is required" <>
1111 text " to be trusted but it isn't!"
1112
1113 -- | Set module to unsafe and (potentially) wipe trust information.
1114 --
1115 -- Make sure to call this method to set a module to inferred unsafe, it should
1116 -- be a central and single failure method. We only wipe the trust information
1117 -- when we aren't in a specific Safe Haskell mode.
1118 --
1119 -- While we only use this for recording that a module was inferred unsafe, we
1120 -- may call it on modules using Trustworthy or Unsafe flags so as to allow
1121 -- warning flags for safety to function correctly. See Note [Safe Haskell
1122 -- Inference].
1123 markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1124 markUnsafeInfer tcg_env whyUnsafe = do
1125 dflags <- getDynFlags
1126
1127 when (wopt Opt_WarnUnsafe dflags)
1128 (logWarnings $ unitBag $
1129 mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
1130
1131 liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
1132 -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other
1133 -- times inference may be on but we are in Trustworthy mode -- so we want
1134 -- to record safe-inference failed but not wipe the trust dependencies.
1135 case safeHaskell dflags == Sf_None of
1136 True -> return $ tcg_env { tcg_imports = wiped_trust }
1137 False -> return tcg_env
1138
1139 where
1140 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
1141 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1142 whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
1143 , text "Reason:"
1144 , nest 4 $ (vcat $ badFlags df) $+$
1145 (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
1146 (vcat $ badInsts $ tcg_insts tcg_env)
1147 ]
1148 badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer
1149 badFlag df (str,loc,on,_)
1150 | on df = [mkLocMessage SevOutput (loc df) $
1151 text str <+> text "is not allowed in Safe Haskell"]
1152 | otherwise = []
1153 badInsts insts = concat $ map badInst insts
1154
1155 checkOverlap (NoOverlap _) = False
1156 checkOverlap _ = True
1157
1158 badInst ins | checkOverlap (overlapMode (is_flag ins))
1159 = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
1160 ppr (overlapMode $ is_flag ins) <+>
1161 text "overlap mode isn't allowed in Safe Haskell"]
1162 | otherwise = []
1163
1164
1165 -- | Figure out the final correct safe haskell mode
1166 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
1167 hscGetSafeMode tcg_env = do
1168 dflags <- getDynFlags
1169 liftIO $ finalSafeMode dflags tcg_env
1170
1171 --------------------------------------------------------------
1172 -- Simplifiers
1173 --------------------------------------------------------------
1174
1175 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1176 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1177
1178 hscSimplify' :: ModGuts -> Hsc ModGuts
1179 hscSimplify' ds_result = do
1180 hsc_env <- getHscEnv
1181 {-# SCC "Core2Core" #-}
1182 liftIO $ core2core hsc_env ds_result
1183
1184 --------------------------------------------------------------
1185 -- Interface generators
1186 --------------------------------------------------------------
1187
1188 hscSimpleIface :: HscEnv
1189 -> TcGblEnv
1190 -> Maybe Fingerprint
1191 -> IO (ModIface, Bool, ModDetails)
1192 hscSimpleIface hsc_env tc_result mb_old_iface
1193 = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
1194
1195 hscSimpleIface' :: TcGblEnv
1196 -> Maybe Fingerprint
1197 -> Hsc (ModIface, Bool, ModDetails)
1198 hscSimpleIface' tc_result mb_old_iface = do
1199 hsc_env <- getHscEnv
1200 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1201 safe_mode <- hscGetSafeMode tc_result
1202 (new_iface, no_change)
1203 <- {-# SCC "MkFinalIface" #-}
1204 ioMsgMaybe $
1205 mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
1206 -- And the answer is ...
1207 liftIO $ dumpIfaceStats hsc_env
1208 return (new_iface, no_change, details)
1209
1210 hscNormalIface :: HscEnv
1211 -> ModGuts
1212 -> Maybe Fingerprint
1213 -> IO (ModIface, Bool, ModDetails, CgGuts)
1214 hscNormalIface hsc_env simpl_result mb_old_iface =
1215 runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
1216
1217 hscNormalIface' :: ModGuts
1218 -> Maybe Fingerprint
1219 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1220 hscNormalIface' simpl_result mb_old_iface = do
1221 hsc_env <- getHscEnv
1222 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1223 liftIO $ tidyProgram hsc_env simpl_result
1224
1225 -- BUILD THE NEW ModIface and ModDetails
1226 -- and emit external core if necessary
1227 -- This has to happen *after* code gen so that the back-end
1228 -- info has been set. Not yet clear if it matters waiting
1229 -- until after code output
1230 (new_iface, no_change)
1231 <- {-# SCC "MkFinalIface" #-}
1232 ioMsgMaybe $
1233 mkIface hsc_env mb_old_iface details simpl_result
1234
1235 liftIO $ dumpIfaceStats hsc_env
1236
1237 -- Return the prepared code.
1238 return (new_iface, no_change, details, cg_guts)
1239
1240 --------------------------------------------------------------
1241 -- BackEnd combinators
1242 --------------------------------------------------------------
1243
1244 hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
1245 hscWriteIface dflags iface no_change mod_summary = do
1246 let ifaceFile = ml_hi_file (ms_location mod_summary)
1247 unless no_change $
1248 {-# SCC "writeIface" #-}
1249 writeIfaceFile dflags ifaceFile iface
1250 whenGeneratingDynamicToo dflags $ do
1251 -- TODO: We should do a no_change check for the dynamic
1252 -- interface file too
1253 -- TODO: Should handle the dynamic hi filename properly
1254 let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
1255 dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
1256 dynDflags = dynamicTooMkDynamicDynFlags dflags
1257 writeIfaceFile dynDflags dynIfaceFile' iface
1258
1259 -- | Compile to hard-code.
1260 hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
1261 -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1262 hscGenHardCode hsc_env cgguts mod_summary output_filename = do
1263 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1264 -- From now on, we just use the bits we need.
1265 cg_module = this_mod,
1266 cg_binds = core_binds,
1267 cg_tycons = tycons,
1268 cg_foreign = foreign_stubs0,
1269 cg_dep_pkgs = dependencies,
1270 cg_hpc_info = hpc_info } = cgguts
1271 dflags = hsc_dflags hsc_env
1272 location = ms_location mod_summary
1273 data_tycons = filter isDataTyCon tycons
1274 -- cg_tycons includes newtypes, for the benefit of External Core,
1275 -- but we don't generate any code for newtypes
1276
1277 -------------------
1278 -- PREPARE FOR CODE GENERATION
1279 -- Do saturation and convert to A-normal form
1280 prepd_binds <- {-# SCC "CorePrep" #-}
1281 corePrepPgm hsc_env location core_binds data_tycons ;
1282 ----------------- Convert to STG ------------------
1283 (stg_binds, cost_centre_info)
1284 <- {-# SCC "CoreToStg" #-}
1285 myCoreToStg dflags this_mod prepd_binds
1286
1287 let prof_init = profilingInitCode this_mod cost_centre_info
1288 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1289
1290 ------------------ Code generation ------------------
1291
1292 -- The back-end is streamed: each top-level function goes
1293 -- from Stg all the way to asm before dealing with the next
1294 -- top-level function, so showPass isn't very useful here.
1295 -- Hence we have one showPass for the whole backend, the
1296 -- next showPass after this will be "Assembler".
1297 showPass dflags "CodeGen"
1298
1299 cmms <- {-# SCC "StgCmm" #-}
1300 doCodeGen hsc_env this_mod data_tycons
1301 cost_centre_info
1302 stg_binds hpc_info
1303
1304 ------------------ Code output -----------------------
1305 rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
1306 cmmToRawCmm dflags cmms
1307
1308 let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
1309 (ppr a)
1310 return a
1311 rawcmms1 = Stream.mapM dump rawcmms0
1312
1313 (output_filename, (_stub_h_exists, stub_c_exists))
1314 <- {-# SCC "codeOutput" #-}
1315 codeOutput dflags this_mod output_filename location
1316 foreign_stubs dependencies rawcmms1
1317 return (output_filename, stub_c_exists)
1318
1319
1320 hscInteractive :: HscEnv
1321 -> CgGuts
1322 -> ModSummary
1323 -> IO (Maybe FilePath, CompiledByteCode, ModBreaks)
1324 #ifdef GHCI
1325 hscInteractive hsc_env cgguts mod_summary = do
1326 let dflags = hsc_dflags hsc_env
1327 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1328 -- From now on, we just use the bits we need.
1329 cg_module = this_mod,
1330 cg_binds = core_binds,
1331 cg_tycons = tycons,
1332 cg_foreign = foreign_stubs,
1333 cg_modBreaks = mod_breaks } = cgguts
1334
1335 location = ms_location mod_summary
1336 data_tycons = filter isDataTyCon tycons
1337 -- cg_tycons includes newtypes, for the benefit of External Core,
1338 -- but we don't generate any code for newtypes
1339
1340 -------------------
1341 -- PREPARE FOR CODE GENERATION
1342 -- Do saturation and convert to A-normal form
1343 prepd_binds <- {-# SCC "CorePrep" #-}
1344 corePrepPgm hsc_env location core_binds data_tycons
1345 ----------------- Generate byte code ------------------
1346 comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
1347 ------------------ Create f-x-dynamic C-side stuff ---
1348 (_istub_h_exists, istub_c_exists)
1349 <- outputForeignStubs dflags this_mod location foreign_stubs
1350 return (istub_c_exists, comp_bc, mod_breaks)
1351 #else
1352 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1353 #endif
1354
1355 ------------------------------
1356
1357 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
1358 hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
1359 let dflags = hsc_dflags hsc_env
1360 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1361 liftIO $ do
1362 us <- mkSplitUniqSupply 'S'
1363 let initTopSRT = initUs_ us emptySRT
1364 dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm)
1365 (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
1366 rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
1367 _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms
1368 return ()
1369 where
1370 no_mod = panic "hscCmmFile: no_mod"
1371 no_loc = ModLocation{ ml_hs_file = Just filename,
1372 ml_hi_file = panic "hscCmmFile: no hi file",
1373 ml_obj_file = panic "hscCmmFile: no obj file" }
1374
1375 -------------------- Stuff for new code gen ---------------------
1376
1377 doCodeGen :: HscEnv -> Module -> [TyCon]
1378 -> CollectedCCs
1379 -> [StgBinding]
1380 -> HpcInfo
1381 -> IO (Stream IO CmmGroup ())
1382 -- Note we produce a 'Stream' of CmmGroups, so that the
1383 -- backend can be run incrementally. Otherwise it generates all
1384 -- the C-- up front, which has a significant space cost.
1385 doCodeGen hsc_env this_mod data_tycons
1386 cost_centre_info stg_binds hpc_info = do
1387 let dflags = hsc_dflags hsc_env
1388
1389 let cmm_stream :: Stream IO CmmGroup ()
1390 cmm_stream = {-# SCC "StgCmm" #-}
1391 StgCmm.codeGen dflags this_mod data_tycons
1392 cost_centre_info stg_binds hpc_info
1393
1394 -- codegen consumes a stream of CmmGroup, and produces a new
1395 -- stream of CmmGroup (not necessarily synchronised: one
1396 -- CmmGroup on input may produce many CmmGroups on output due
1397 -- to proc-point splitting).
1398
1399 let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
1400 "Cmm produced by new codegen" (ppr a)
1401 return a
1402
1403 ppr_stream1 = Stream.mapM dump1 cmm_stream
1404
1405 -- We are building a single SRT for the entire module, so
1406 -- we must thread it through all the procedures as we cps-convert them.
1407 us <- mkSplitUniqSupply 'S'
1408
1409 -- When splitting, we generate one SRT per split chunk, otherwise
1410 -- we generate one SRT for the whole module.
1411 let
1412 pipeline_stream
1413 | gopt Opt_SplitObjs dflags
1414 = {-# SCC "cmmPipeline" #-}
1415 let run_pipeline us cmmgroup = do
1416 let (topSRT', us') = initUs us emptySRT
1417 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
1418 let srt | isEmptySRT topSRT = []
1419 | otherwise = srtToData topSRT
1420 return (us', srt ++ cmmgroup)
1421
1422 in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
1423 return ()
1424
1425 | otherwise
1426 = {-# SCC "cmmPipeline" #-}
1427 let initTopSRT = initUs_ us emptySRT
1428 run_pipeline = cmmPipeline hsc_env
1429 in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
1430 Stream.yield (srtToData topSRT)
1431
1432 let
1433 dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a
1434 return a
1435
1436 ppr_stream2 = Stream.mapM dump2 pipeline_stream
1437
1438 return ppr_stream2
1439
1440
1441
1442 myCoreToStg :: DynFlags -> Module -> CoreProgram
1443 -> IO ( [StgBinding] -- output program
1444 , CollectedCCs) -- cost centre info (declared and used)
1445 myCoreToStg dflags this_mod prepd_binds = do
1446 stg_binds
1447 <- {-# SCC "Core2Stg" #-}
1448 coreToStg dflags this_mod prepd_binds
1449
1450 (stg_binds2, cost_centre_info)
1451 <- {-# SCC "Stg2Stg" #-}
1452 stg2stg dflags this_mod stg_binds
1453
1454 return (stg_binds2, cost_centre_info)
1455
1456
1457 {- **********************************************************************
1458 %* *
1459 \subsection{Compiling a do-statement}
1460 %* *
1461 %********************************************************************* -}
1462
1463 {-
1464 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1465 you run it you get a list of HValues that should be the same length as the list
1466 of names; add them to the ClosureEnv.
1467
1468 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1469 IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
1470 -}
1471
1472 #ifdef GHCI
1473 -- | Compile a stmt all the way to an HValue, but don't run it
1474 --
1475 -- We return Nothing to indicate an empty statement (or comment only), not a
1476 -- parse error.
1477 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1478 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1479
1480 -- | Compile a stmt all the way to an HValue, but don't run it
1481 --
1482 -- We return Nothing to indicate an empty statement (or comment only), not a
1483 -- parse error.
1484 hscStmtWithLocation :: HscEnv
1485 -> String -- ^ The statement
1486 -> String -- ^ The source
1487 -> Int -- ^ Starting line
1488 -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1489 hscStmtWithLocation hsc_env0 stmt source linenumber =
1490 runInteractiveHsc hsc_env0 $ do
1491 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1492 case maybe_stmt of
1493 Nothing -> return Nothing
1494
1495 Just parsed_stmt -> do
1496 hsc_env <- getHscEnv
1497 liftIO $ hscParsedStmt hsc_env parsed_stmt
1498
1499 hscParsedStmt :: HscEnv
1500 -> GhciLStmt RdrName -- ^ The parsed statement
1501 -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1502 hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
1503 -- Rename and typecheck it
1504 (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
1505
1506 -- Desugar it
1507 ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
1508 liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
1509 handleWarnings
1510
1511 -- Then code-gen, and link it
1512 -- It's important NOT to have package 'interactive' as thisPackageKey
1513 -- for linking, else we try to link 'main' and can't find it.
1514 -- Whereas the linker already knows to ignore 'interactive'
1515 let src_span = srcLocSpan interactiveSrcLoc
1516 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1517 let hvals_io = unsafeCoerce# hval :: IO [HValue]
1518
1519 return $ Just (ids, hvals_io, fix_env)
1520
1521 -- | Compile a decls
1522 hscDecls :: HscEnv
1523 -> String -- ^ The statement
1524 -> IO ([TyThing], InteractiveContext)
1525 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1526
1527 -- | Compile a decls
1528 hscDeclsWithLocation :: HscEnv
1529 -> String -- ^ The statement
1530 -> String -- ^ The source
1531 -> Int -- ^ Starting line
1532 -> IO ([TyThing], InteractiveContext)
1533 hscDeclsWithLocation hsc_env0 str source linenumber =
1534 runInteractiveHsc hsc_env0 $ do
1535 L _ (HsModule{ hsmodDecls = decls }) <-
1536 hscParseThingWithLocation source linenumber parseModule str
1537
1538 {- Rename and typecheck it -}
1539 hsc_env <- getHscEnv
1540 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
1541
1542 {- Grab the new instances -}
1543 -- We grab the whole environment because of the overlapping that may have
1544 -- been done. See the notes at the definition of InteractiveContext
1545 -- (ic_instances) for more details.
1546 let defaults = tcg_default tc_gblenv
1547
1548 {- Desugar it -}
1549 -- We use a basically null location for iNTERACTIVE
1550 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1551 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1552 ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
1553 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1554
1555 {- Simplify -}
1556 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1557
1558 {- Tidy -}
1559 (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1560
1561 let dflags = hsc_dflags hsc_env
1562 !CgGuts{ cg_module = this_mod,
1563 cg_binds = core_binds,
1564 cg_tycons = tycons,
1565 cg_modBreaks = mod_breaks } = tidy_cg
1566
1567 !ModDetails { md_insts = cls_insts
1568 , md_fam_insts = fam_insts } = mod_details
1569 -- Get the *tidied* cls_insts and fam_insts
1570
1571 data_tycons = filter isDataTyCon tycons
1572
1573 {- Prepare For Code Generation -}
1574 -- Do saturation and convert to A-normal form
1575 prepd_binds <- {-# SCC "CorePrep" #-}
1576 liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons
1577
1578 {- Generate byte code -}
1579 cbc <- liftIO $ byteCodeGen dflags this_mod
1580 prepd_binds data_tycons mod_breaks
1581
1582 let src_span = srcLocSpan interactiveSrcLoc
1583 liftIO $ linkDecls hsc_env src_span cbc
1584
1585 let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
1586 patsyns = mg_patsyns simpl_mg
1587
1588 ext_ids = [ id | id <- bindersOfBinds core_binds
1589 , isExternalName (idName id)
1590 , not (isDFunId id || isImplicitId id) ]
1591 -- We only need to keep around the external bindings
1592 -- (as decided by TidyPgm), since those are the only ones
1593 -- that might later be looked up by name. But we can exclude
1594 -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
1595 -- - Implicit Ids, which are implicit in tcs
1596 -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv
1597
1598 new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
1599 ictxt = hsc_IC hsc_env
1600 -- See Note [Fixity declarations in GHCi]
1601 fix_env = tcg_fix_env tc_gblenv
1602 new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
1603 fam_insts defaults fix_env
1604 return (new_tythings, new_ictxt)
1605
1606
1607 {-
1608 Note [Fixity declarations in GHCi]
1609 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1610
1611 To support fixity declarations on types defined within GHCi (as requested
1612 in #10018) we record the fixity environment in InteractiveContext.
1613 When we want to evaluate something TcRnDriver.runTcInteractive pulls out this
1614 fixity environment and uses it to initialize the global typechecker environment.
1615 After the typechecker has finished its business, an updated fixity environment
1616 (reflecting whatever fixity declarations were present in the statements we
1617 passed it) will be returned from hscParsedStmt. This is passed to
1618 updateFixityEnv, which will stuff it back into InteractiveContext, to be
1619 used in evaluating the next statement.
1620
1621 -}
1622
1623 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1624 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1625 (L _ (HsModule{hsmodImports=is})) <-
1626 hscParseThing parseModule str
1627 case is of
1628 [L _ i] -> return i
1629 _ -> liftIO $ throwOneError $
1630 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
1631 ptext (sLit "parse error in import declaration")
1632
1633 -- | Typecheck an expression (but don't run it)
1634 -- Returns its most general type
1635 hscTcExpr :: HscEnv
1636 -> String -- ^ The expression
1637 -> IO Type
1638 hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
1639 hsc_env <- getHscEnv
1640 parsed_expr <- hscParseExpr expr
1641 ioMsgMaybe $ tcRnExpr hsc_env parsed_expr
1642
1643 -- | Find the kind of a type
1644 -- Currently this does *not* generalise the kinds of the type
1645 hscKcType
1646 :: HscEnv
1647 -> Bool -- ^ Normalise the type
1648 -> String -- ^ The type as a string
1649 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1650 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1651 hsc_env <- getHscEnv
1652 ty <- hscParseType str
1653 ioMsgMaybe $ tcRnType hsc_env normalise ty
1654
1655 hscParseExpr :: String -> Hsc (LHsExpr RdrName)
1656 hscParseExpr expr = do
1657 hsc_env <- getHscEnv
1658 maybe_stmt <- hscParseStmt expr
1659 case maybe_stmt of
1660 Just (L _ (BodyStmt expr _ _ _)) -> return expr
1661 _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
1662 (text "not an expression:" <+> quotes (text expr))
1663
1664 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
1665 hscParseStmt = hscParseThing parseStmt
1666
1667 hscParseStmtWithLocation :: String -> Int -> String
1668 -> Hsc (Maybe (GhciLStmt RdrName))
1669 hscParseStmtWithLocation source linenumber stmt =
1670 hscParseThingWithLocation source linenumber parseStmt stmt
1671
1672 hscParseType :: String -> Hsc (LHsType RdrName)
1673 hscParseType = hscParseThing parseType
1674 #endif
1675
1676 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1677 hscParseIdentifier hsc_env str =
1678 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1679
1680 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1681 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1682
1683 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1684 -> Lexer.P thing -> String -> Hsc thing
1685 hscParseThingWithLocation source linenumber parser str
1686 = {-# SCC "Parser" #-} do
1687 dflags <- getDynFlags
1688 liftIO $ showPass dflags "Parser"
1689
1690 let buf = stringToStringBuffer str
1691 loc = mkRealSrcLoc (fsLit source) linenumber 1
1692
1693 case unP parser (mkPState dflags buf loc) of
1694 PFailed span err -> do
1695 let msg = mkPlainErrMsg dflags span err
1696 throwErrors $ unitBag msg
1697
1698 POk pst thing -> do
1699 logWarningsReportErrors (getMessages pst)
1700 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1701 return thing
1702
1703 hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
1704 -> CoreProgram -> FilePath -> IO ()
1705 hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename
1706 = runHsc hsc_env $ do
1707 guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
1708 (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing
1709 liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary
1710 _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename
1711 return ()
1712
1713 where
1714 maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1715 | otherwise = return mod_guts
1716
1717 -- Makes a "vanilla" ModGuts.
1718 mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts
1719 mkModGuts mod safe binds =
1720 ModGuts {
1721 mg_module = mod,
1722 mg_hsc_src = HsSrcFile,
1723 mg_loc = mkGeneralSrcSpan (moduleNameFS (moduleName mod)),
1724 -- A bit crude
1725 mg_exports = [],
1726 mg_deps = noDependencies,
1727 mg_dir_imps = emptyModuleEnv,
1728 mg_used_names = emptyNameSet,
1729 mg_used_th = False,
1730 mg_rdr_env = emptyGlobalRdrEnv,
1731 mg_fix_env = emptyFixityEnv,
1732 mg_tcs = [],
1733 mg_insts = [],
1734 mg_fam_insts = [],
1735 mg_patsyns = [],
1736 mg_rules = [],
1737 mg_vect_decls = [],
1738 mg_binds = binds,
1739 mg_foreign = NoStubs,
1740 mg_warns = NoWarnings,
1741 mg_anns = [],
1742 mg_hpc_info = emptyHpcInfo False,
1743 mg_modBreaks = emptyModBreaks,
1744 mg_vect_info = noVectInfo,
1745 mg_inst_env = emptyInstEnv,
1746 mg_fam_inst_env = emptyFamInstEnv,
1747 mg_safe_haskell = safe,
1748 mg_trust_pkg = False,
1749 mg_dependent_files = []
1750 }
1751
1752
1753 {- **********************************************************************
1754 %* *
1755 Desugar, simplify, convert to bytecode, and link an expression
1756 %* *
1757 %********************************************************************* -}
1758
1759 #ifdef GHCI
1760 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1761 hscCompileCoreExpr hsc_env =
1762 lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
1763
1764 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1765 hscCompileCoreExpr' hsc_env srcspan ds_expr
1766 | rtsIsProfiled
1767 = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1768 -- Otherwise you get a seg-fault when you run it
1769
1770 | otherwise
1771 = do { let dflags = hsc_dflags hsc_env
1772
1773 {- Simplify it -}
1774 ; simpl_expr <- simplifyExpr dflags ds_expr
1775
1776 {- Tidy it (temporary, until coreSat does cloning) -}
1777 ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1778
1779 {- Prepare for codegen -}
1780 ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
1781
1782 {- Lint if necessary -}
1783 ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
1784
1785 {- Convert to BCOs -}
1786 ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
1787
1788 {- link it -}
1789 ; hval <- linkExpr hsc_env srcspan bcos
1790
1791 ; return hval }
1792 #endif
1793
1794
1795 {- **********************************************************************
1796 %* *
1797 Statistics on reading interfaces
1798 %* *
1799 %********************************************************************* -}
1800
1801 dumpIfaceStats :: HscEnv -> IO ()
1802 dumpIfaceStats hsc_env = do
1803 eps <- readIORef (hsc_EPS hsc_env)
1804 dumpIfSet dflags (dump_if_trace || dump_rn_stats)
1805 "Interface statistics"
1806 (ifaceStats eps)
1807 where
1808 dflags = hsc_dflags hsc_env
1809 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1810 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1811
1812
1813 {- **********************************************************************
1814 %* *
1815 Progress Messages: Module i of n
1816 %* *
1817 %********************************************************************* -}
1818
1819 showModuleIndex :: (Int, Int) -> String
1820 showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1821 where
1822 n_str = show n
1823 i_str = show i
1824 padded = replicate (length n_str - length i_str) ' ' ++ i_str