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