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