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