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