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