git.haskell.org / ghc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / main / HscMain.hs
1 -------------------------------------------------------------------------------
2 --
3 -- | Main API for compiling plain Haskell source code.
4 --
5 -- This module implements compilation of a Haskell source. It is
6 -- /not/ concerned with preprocessing of source files; this is handled
7 -- in "DriverPipeline".
8 --
9 -- There are various entry points depending on what mode we're in:
10 -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
11 -- "interactive" mode (GHCi). There are also entry points for
12 -- individual passes: parsing, typechecking/renaming, desugaring, and
13 -- simplification.
14 --
15 -- All the functions here take an 'HscEnv' as a parameter, but none of
16 -- them return a new one: 'HscEnv' is treated as an immutable value
17 -- from here on in (although it has mutable components, for the
18 -- caches).
19 --
20 -- Warning messages are dealt with consistently throughout this API:
21 -- during compilation warnings are collected, and before any function
22 -- in @HscMain@ returns, the warnings are either printed, or turned
23 -- into a real compialtion error if the @-Werror@ flag is enabled.
24 --
25 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
26 --
27 -------------------------------------------------------------------------------
28
29 module HscMain
30 (
31 -- * Making an HscEnv
32 newHscEnv
33
34 -- * Compiling complete source files
35 , Compiler
36 , HscStatus' (..)
37 , InteractiveStatus, HscStatus
38 , hscCompileOneShot
39 , hscCompileBatch
40 , hscCompileNothing
41 , hscCompileInteractive
42 , hscCompileCmmFile
43 , hscCompileCore
44
45 -- * Running passes separately
46 , hscParse
47 , hscTypecheckRename
48 , hscDesugar
49 , makeSimpleIface
50 , makeSimpleDetails
51 , hscSimplify -- ToDo, shouldn't really export this
52
53 -- ** Backends
54 , hscOneShotBackendOnly
55 , hscBatchBackendOnly
56 , hscNothingBackendOnly
57 , hscInteractiveBackendOnly
58
59 -- * Support for interactive evaluation
60 , hscParseIdentifier
61 , hscTcRcLookupName
62 , hscTcRnGetInfo
63 #ifdef GHCI
64 , hscGetModuleInterface
65 , hscRnImportDecls
66 , hscTcRnLookupRdrName
67 , hscStmt, hscStmtWithLocation
68 , hscDecls, hscDeclsWithLocation
69 , hscTcExpr, hscImport, hscKcType
70 , hscCompileCoreExpr
71 #endif
72 ) where
73
74 #ifdef GHCI
75 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
76 import Linker
77 import CoreTidy ( tidyExpr )
78 import Type ( Type )
79 import PrelNames
80 import {- Kind parts of -} Type ( Kind )
81 import CoreLint ( lintUnfolding )
82 import DsMeta ( templateHaskellNames )
83 import VarSet
84 import VarEnv ( emptyTidyEnv )
85 import Panic
86 #endif
87
88 import Id
89 import Module
90 import Packages
91 import RdrName
92 import HsSyn
93 import CoreSyn
94 import StringBuffer
95 import Parser
96 import Lexer
97 import SrcLoc
98 import TcRnDriver
99 import TcIface ( typecheckIface )
100 import TcRnMonad
101 import IfaceEnv ( initNameCache )
102 import LoadIface ( ifaceStats, initExternalPackageState )
103 import PrelInfo
104 import MkIface
105 import Desugar
106 import SimplCore
107 import TidyPgm
108 import CorePrep
109 import CoreToStg ( coreToStg )
110 import qualified StgCmm ( codeGen )
111 import StgSyn
112 import CostCentre
113 import ProfInit
114 import TyCon
115 import Name
116 import SimplStg ( stg2stg )
117 import CodeGen ( codeGen )
118 import OldCmm as Old ( CmmGroup )
119 import PprCmm ( pprCmms )
120 import CmmParse ( parseCmmFile )
121 import CmmBuildInfoTables
122 import CmmPipeline
123 import CmmInfo
124 import OptimizationFuel ( initOptFuelState )
125 import CmmCvt
126 import CodeOutput
127 import NameEnv ( emptyNameEnv )
128 import NameSet ( emptyNameSet )
129 import InstEnv
130 import FamInstEnv
131 import Fingerprint ( Fingerprint )
132
133 import DynFlags
134 import ErrUtils
135 import UniqSupply ( mkSplitUniqSupply )
136
137 import Outputable
138 import HscStats ( ppSourceStats )
139 import HscTypes
140 import MkExternalCore ( emitExternalCore )
141 import FastString
142 import UniqFM ( emptyUFM )
143 import UniqSupply ( initUs_ )
144 import Bag
145 import Exception
146
147 import Data.List
148 import Control.Monad
149 import Data.Maybe
150 import Data.IORef
151 import System.FilePath as FilePath
152 import System.Directory
153
154 #include "HsVersions.h"
155
156
157 {- **********************************************************************
158 %* *
159 Initialisation
160 %* *
161 %********************************************************************* -}
162
163 newHscEnv :: DynFlags -> IO HscEnv
164 newHscEnv dflags = do
165 eps_var <- newIORef initExternalPackageState
166 us <- mkSplitUniqSupply 'r'
167 nc_var <- newIORef (initNameCache us knownKeyNames)
168 fc_var <- newIORef emptyUFM
169 mlc_var <- newIORef emptyModuleEnv
170 optFuel <- initOptFuelState
171 safe_var <- newIORef True
172 return HscEnv { hsc_dflags = dflags,
173 hsc_targets = [],
174 hsc_mod_graph = [],
175 hsc_IC = emptyInteractiveContext,
176 hsc_HPT = emptyHomePackageTable,
177 hsc_EPS = eps_var,
178 hsc_NC = nc_var,
179 hsc_FC = fc_var,
180 hsc_MLC = mlc_var,
181 hsc_OptFuel = optFuel,
182 hsc_type_env_var = Nothing,
183 hsc_safeInf = safe_var }
184
185
186 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
187 knownKeyNames = -- where templateHaskellNames are defined
188 map getName wiredInThings
189 ++ basicKnownKeyNames
190 #ifdef GHCI
191 ++ templateHaskellNames
192 #endif
193
194 -- -----------------------------------------------------------------------------
195 -- The Hsc monad: Passing an enviornment and warning state
196
197 newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
198
199 instance Monad Hsc where
200 return a = Hsc $ \_ w -> return (a, w)
201 Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
202 case k a of
203 Hsc k' -> k' e w1
204
205 instance MonadIO Hsc where
206 liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
207
208 runHsc :: HscEnv -> Hsc a -> IO a
209 runHsc hsc_env (Hsc hsc) = do
210 (a, w) <- hsc hsc_env emptyBag
211 printOrThrowWarnings (hsc_dflags hsc_env) w
212 return a
213
214 getWarnings :: Hsc WarningMessages
215 getWarnings = Hsc $ \_ w -> return (w, w)
216
217 clearWarnings :: Hsc ()
218 clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
219
220 logWarnings :: WarningMessages -> Hsc ()
221 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
222
223 getHscEnv :: Hsc HscEnv
224 getHscEnv = Hsc $ \e w -> return (e, w)
225
226 instance HasDynFlags Hsc where
227 getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
228
229 handleWarnings :: Hsc ()
230 handleWarnings = do
231 dflags <- getDynFlags
232 w <- getWarnings
233 liftIO $ printOrThrowWarnings dflags w
234 clearWarnings
235
236 -- | log warning in the monad, and if there are errors then
237 -- throw a SourceError exception.
238 logWarningsReportErrors :: Messages -> Hsc ()
239 logWarningsReportErrors (warns,errs) = do
240 logWarnings warns
241 when (not $ isEmptyBag errs) $ throwErrors errs
242
243 -- | Throw some errors.
244 throwErrors :: ErrorMessages -> Hsc a
245 throwErrors = liftIO . throwIO . mkSrcErr
246
247 -- | Deal with errors and warnings returned by a compilation step
248 --
249 -- In order to reduce dependencies to other parts of the compiler, functions
250 -- outside the "main" parts of GHC return warnings and errors as a parameter
251 -- and signal success via by wrapping the result in a 'Maybe' type. This
252 -- function logs the returned warnings and propagates errors as exceptions
253 -- (of type 'SourceError').
254 --
255 -- This function assumes the following invariants:
256 --
257 -- 1. If the second result indicates success (is of the form 'Just x'),
258 -- there must be no error messages in the first result.
259 --
260 -- 2. If there are no error messages, but the second result indicates failure
261 -- there should be warnings in the first result. That is, if the action
262 -- failed, it must have been due to the warnings (i.e., @-Werror@).
263 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
264 ioMsgMaybe ioA = do
265 ((warns,errs), mb_r) <- liftIO $ ioA
266 logWarnings warns
267 case mb_r of
268 Nothing -> throwErrors errs
269 Just r -> ASSERT( isEmptyBag errs ) return r
270
271 -- | like ioMsgMaybe, except that we ignore error messages and return
272 -- 'Nothing' instead.
273 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
274 ioMsgMaybe' ioA = do
275 ((warns,_errs), mb_r) <- liftIO $ ioA
276 logWarnings warns
277 return mb_r
278
279 -- -----------------------------------------------------------------------------
280 -- | Lookup things in the compiler's environment
281
282 #ifdef GHCI
283 hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
284 hscTcRnLookupRdrName hsc_env rdr_name =
285 runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
286 #endif
287
288 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
289 hscTcRcLookupName hsc_env name =
290 runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name
291 -- ignore errors: the only error we're likely to get is
292 -- "name not found", and the Maybe in the return type
293 -- is used to indicate that.
294
295 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance]))
296 hscTcRnGetInfo hsc_env name =
297 runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name
298
299 #ifdef GHCI
300 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
301 hscGetModuleInterface hsc_env mod =
302 runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod
303
304 -- -----------------------------------------------------------------------------
305 -- | Rename some import declarations
306 hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv
307 hscRnImportDecls hsc_env import_decls =
308 runHsc hsc_env $ 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 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 . (== '<') . head)
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 }
378
379 -- XXX: should this really be a Maybe X? Check under which circumstances this
380 -- can become a Nothing and decide whether this should instead throw an
381 -- exception/signal an error.
382 type RenamedStuff =
383 (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
384 Maybe LHsDocString))
385
386 -- | Rename and typecheck a module, additionally returning the renamed syntax
387 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
388 -> IO (TcGblEnv, RenamedStuff)
389 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
390 tc_result <- {-# SCC "Typecheck-Rename" #-}
391 ioMsgMaybe $
392 tcRnModule hsc_env (ms_hsc_src mod_summary)
393 True rdr_module
394
395 -- This 'do' is in the Maybe monad!
396 let rn_info = do decl <- tcg_rn_decls tc_result
397 let imports = tcg_rn_imports tc_result
398 exports = tcg_rn_exports tc_result
399 doc_hdr = tcg_doc_hdr tc_result
400 return (decl,imports,exports,doc_hdr)
401
402 return (tc_result, rn_info)
403
404 -- | Convert a typechecked module to Core
405 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
406 hscDesugar hsc_env mod_summary tc_result =
407 runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
408
409 hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
410 hscDesugar' mod_location tc_result = do
411 hsc_env <- getHscEnv
412 r <- ioMsgMaybe $
413 {-# SCC "deSugar" #-}
414 deSugar hsc_env mod_location tc_result
415
416 -- always check -Werror after desugaring, this is the last opportunity for
417 -- warnings to arise before the backend.
418 handleWarnings
419 return r
420
421 -- | Make a 'ModIface' from the results of typechecking. Used when
422 -- not optimising, and the interface doesn't need to contain any
423 -- unfoldings or other cross-module optimisation info.
424 -- ToDo: the old interface is only needed to get the version numbers,
425 -- we should use fingerprint versions instead.
426 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
427 -> IO (ModIface,Bool)
428 makeSimpleIface hsc_env maybe_old_iface tc_result details =
429 runHsc hsc_env $ ioMsgMaybe $
430 mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
431
432 -- | Make a 'ModDetails' from the results of typechecking. Used when
433 -- typechecking only, as opposed to full compilation.
434 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
435 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
436
437
438 {- **********************************************************************
439 %* *
440 The main compiler pipeline
441 %* *
442 %********************************************************************* -}
443
444 {-
445 --------------------------------
446 The compilation proper
447 --------------------------------
448
449 It's the task of the compilation proper to compile Haskell, hs-boot and core
450 files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all
451 (the module is still parsed and type-checked. This feature is mostly used by
452 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
453 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
454 mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
455 targets byte-code.
456
457 The modes are kept separate because of their different types and meanings:
458
459 * In 'one-shot' mode, we're only compiling a single file and can therefore
460 discard the new ModIface and ModDetails. This is also the reason it only
461 targets hard-code; compiling to byte-code or nothing doesn't make sense when
462 we discard the result.
463
464 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
465 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
466 return the newly compiled byte-code.
467
468 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
469 kept separate. This is because compiling to nothing is fairly special: We
470 don't output any interface files, we don't run the simplifier and we don't
471 generate any code.
472
473 * 'Interactive' mode is similar to 'batch' mode except that we return the
474 compiled byte-code together with the ModIface and ModDetails.
475
476 Trying to compile a hs-boot file to byte-code will result in a run-time error.
477 This is the only thing that isn't caught by the type-system.
478 -}
479
480
481 -- | Status of a compilation to hard-code or nothing.
482 data HscStatus' a
483 = HscNoRecomp
484 | HscRecomp
485 (Maybe FilePath) -- Has stub files. This is a hack. We can't compile
486 -- C files here since it's done in DriverPipeline.
487 -- For now we just return True if we want the caller
488 -- to compile them for us.
489 a
490
491 -- This is a bit ugly. Since we use a typeclass below and would like to avoid
492 -- functional dependencies, we have to parameterise the typeclass over the
493 -- result type. Therefore we need to artificially distinguish some types. We do
494 -- this by adding type tags which will simply be ignored by the caller.
495 type HscStatus = HscStatus' ()
496 type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
497 -- INVARIANT: result is @Nothing@ <=> input was a boot file
498
499 type OneShotResult = HscStatus
500 type BatchResult = (HscStatus, ModIface, ModDetails)
501 type NothingResult = (HscStatus, ModIface, ModDetails)
502 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
503
504 -- ToDo: The old interface and module index are only using in 'batch' and
505 -- 'interactive' mode. They should be removed from 'oneshot' mode.
506 type Compiler result = HscEnv
507 -> ModSummary
508 -> SourceModified
509 -> Maybe ModIface -- Old interface, if available
510 -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
511 -> IO result
512
513 data HsCompiler a = HsCompiler {
514 -- | Called when no recompilation is necessary.
515 hscNoRecomp :: ModIface
516 -> Hsc a,
517
518 -- | Called to recompile the module.
519 hscRecompile :: ModSummary -> Maybe Fingerprint
520 -> Hsc a,
521
522 hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint
523 -> Hsc a,
524
525 -- | Code generation for Boot modules.
526 hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint
527 -> Hsc a,
528
529 -- | Code generation for normal modules.
530 hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint
531 -> Hsc a
532 }
533
534 genericHscCompile :: HsCompiler a
535 -> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ())
536 -> HscEnv -> ModSummary -> SourceModified
537 -> Maybe ModIface -> Maybe (Int, Int)
538 -> IO a
539 genericHscCompile compiler hscMessage hsc_env
540 mod_summary source_modified
541 mb_old_iface0 mb_mod_index
542 = do
543 (recomp_reqd, mb_checked_iface)
544 <- {-# SCC "checkOldIface" #-}
545 checkOldIface hsc_env mod_summary
546 source_modified mb_old_iface0
547 -- save the interface that comes back from checkOldIface.
548 -- In one-shot mode we don't have the old iface until this
549 -- point, when checkOldIface reads it from the disk.
550 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
551
552 let skip iface = do
553 hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary
554 runHsc hsc_env $ hscNoRecomp compiler iface
555
556 compile reason = do
557 hscMessage hsc_env mb_mod_index reason mod_summary
558 runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
559
560 stable = case source_modified of
561 SourceUnmodifiedAndStable -> True
562 _ -> False
563
564 -- If the module used TH splices when it was last compiled,
565 -- then the recompilation check is not accurate enough (#481)
566 -- and we must ignore it. However, if the module is stable
567 -- (none of the modules it depends on, directly or indirectly,
568 -- changed), then we *can* skip recompilation. This is why
569 -- the SourceModified type contains SourceUnmodifiedAndStable,
570 -- and it's pretty important: otherwise ghc --make would
571 -- always recompile TH modules, even if nothing at all has
572 -- changed. Stability is just the same check that make is
573 -- doing for us in one-shot mode.
574
575 case mb_checked_iface of
576 Just iface | not recomp_reqd ->
577 if mi_used_th iface && not stable
578 then compile RecompForcedByTH
579 else skip iface
580 _otherwise ->
581 compile RecompRequired
582
583 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
584 hscCheckRecompBackend compiler tc_result hsc_env mod_summary
585 source_modified mb_old_iface _m_of_n
586 = do
587 (recomp_reqd, mb_checked_iface)
588 <- {-# SCC "checkOldIface" #-}
589 checkOldIface hsc_env mod_summary
590 source_modified mb_old_iface
591
592 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
593 case mb_checked_iface of
594 Just iface | not recomp_reqd
595 -> runHsc hsc_env $
596 hscNoRecomp compiler
597 iface{ mi_globals = Just (tcg_rdr_env tc_result) }
598 _otherwise
599 -> runHsc hsc_env $
600 hscBackend compiler tc_result mod_summary mb_old_hash
601
602 genericHscRecompile :: HsCompiler a
603 -> ModSummary -> Maybe Fingerprint
604 -> Hsc a
605 genericHscRecompile compiler mod_summary mb_old_hash
606 | ExtCoreFile <- ms_hsc_src mod_summary =
607 panic "GHC does not currently support reading External Core files"
608 | otherwise = do
609 tc_result <- hscFileFrontEnd mod_summary
610 hscBackend compiler tc_result mod_summary mb_old_hash
611
612 genericHscBackend :: HsCompiler a
613 -> TcGblEnv -> ModSummary -> Maybe Fingerprint
614 -> Hsc a
615 genericHscBackend compiler tc_result mod_summary mb_old_hash
616 | HsBootFile <- ms_hsc_src mod_summary =
617 hscGenBootOutput compiler tc_result mod_summary mb_old_hash
618 | otherwise = do
619 guts <- hscDesugar' (ms_location mod_summary) tc_result
620 hscGenOutput compiler guts mod_summary mb_old_hash
621
622 compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
623 compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ =
624 runHsc hsc_env $ hscBackend comp tcg ms' Nothing
625
626 --------------------------------------------------------------
627 -- Compilers
628 --------------------------------------------------------------
629
630 hscOneShotCompiler :: HsCompiler OneShotResult
631 hscOneShotCompiler = HsCompiler {
632
633 hscNoRecomp = \_old_iface -> do
634 hsc_env <- getHscEnv
635 liftIO $ dumpIfaceStats hsc_env
636 return HscNoRecomp
637
638 , hscRecompile = genericHscRecompile hscOneShotCompiler
639
640 , hscBackend = \tc_result mod_summary mb_old_hash -> do
641 dflags <- getDynFlags
642 case hscTarget dflags of
643 HscNothing -> return (HscRecomp Nothing ())
644 _otherw -> genericHscBackend hscOneShotCompiler
645 tc_result mod_summary mb_old_hash
646
647 , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
648 (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
649 hscWriteIface iface changed mod_summary
650 return (HscRecomp Nothing ())
651
652 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
653 guts <- hscSimplify' guts0
654 (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface
655 hscWriteIface iface changed mod_summary
656 hasStub <- hscGenHardCode cgguts mod_summary
657 return (HscRecomp hasStub ())
658 }
659
660 -- Compile Haskell, boot and extCore in OneShot mode.
661 hscCompileOneShot :: Compiler OneShotResult
662 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
663 = do
664 -- One-shot mode needs a knot-tying mutable variable for interface
665 -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
666 type_env_var <- newIORef emptyNameEnv
667 let mod = ms_mod mod_summary
668 hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
669
670 genericHscCompile hscOneShotCompiler
671 oneShotMsg hsc_env' mod_summary src_changed
672 mb_old_iface mb_i_of_n
673
674 hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult
675 hscOneShotBackendOnly = compilerBackend hscOneShotCompiler
676
677 --------------------------------------------------------------
678
679 hscBatchCompiler :: HsCompiler BatchResult
680 hscBatchCompiler = HsCompiler {
681
682 hscNoRecomp = \iface -> do
683 details <- genModDetails iface
684 return (HscNoRecomp, iface, details)
685
686 , hscRecompile = genericHscRecompile hscBatchCompiler
687
688 , hscBackend = genericHscBackend hscBatchCompiler
689
690 , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
691 (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
692 hscWriteIface iface changed mod_summary
693 return (HscRecomp Nothing (), iface, details)
694
695 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
696 guts <- hscSimplify' guts0
697 (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface
698 hscWriteIface iface changed mod_summary
699 hasStub <- hscGenHardCode cgguts mod_summary
700 return (HscRecomp hasStub (), iface, details)
701 }
702
703 -- | Compile Haskell, boot and extCore in batch mode.
704 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
705 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
706
707 hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult
708 hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler
709
710 --------------------------------------------------------------
711
712 hscInteractiveCompiler :: HsCompiler InteractiveResult
713 hscInteractiveCompiler = HsCompiler {
714 hscNoRecomp = \iface -> do
715 details <- genModDetails iface
716 return (HscNoRecomp, iface, details)
717
718 , hscRecompile = genericHscRecompile hscInteractiveCompiler
719
720 , hscBackend = genericHscBackend hscInteractiveCompiler
721
722 , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
723 (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
724 return (HscRecomp Nothing Nothing, iface, details)
725
726 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
727 guts <- hscSimplify' guts0
728 (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface
729 hscInteractive (iface, details, cgguts) mod_summary
730 }
731
732 -- Compile Haskell, extCore to bytecode.
733 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
734 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
735
736 hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult
737 hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler
738
739 --------------------------------------------------------------
740
741 hscNothingCompiler :: HsCompiler NothingResult
742 hscNothingCompiler = HsCompiler {
743 hscNoRecomp = \iface -> do
744 details <- genModDetails iface
745 return (HscNoRecomp, iface, details)
746
747 , hscRecompile = genericHscRecompile hscNothingCompiler
748
749 , hscBackend = \tc_result _mod_summary mb_old_iface -> do
750 handleWarnings
751 (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
752 return (HscRecomp Nothing (), iface, details)
753
754 , hscGenBootOutput = \_ _ _ ->
755 panic "hscCompileNothing: hscGenBootOutput should not be called"
756
757 , hscGenOutput = \_ _ _ ->
758 panic "hscCompileNothing: hscGenOutput should not be called"
759 }
760
761 -- Type-check Haskell and .hs-boot only (no external core)
762 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
763 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
764
765 hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult
766 hscNothingBackendOnly = compilerBackend hscNothingCompiler
767
768 --------------------------------------------------------------
769 -- NoRecomp handlers
770 --------------------------------------------------------------
771
772 genModDetails :: ModIface -> Hsc ModDetails
773 genModDetails old_iface
774 = do
775 hsc_env <- getHscEnv
776 new_details <- {-# SCC "tcRnIface" #-}
777 liftIO $ initIfaceCheck hsc_env (typecheckIface old_iface)
778 liftIO $ dumpIfaceStats hsc_env
779 return new_details
780
781 --------------------------------------------------------------
782 -- Progress displayers.
783 --------------------------------------------------------------
784
785 data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH
786 deriving Eq
787
788 oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()
789 oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
790 case recomp of
791 RecompNotRequired ->
792 compilationProgressMsg (hsc_dflags hsc_env) $
793 "compilation IS NOT required"
794 _other ->
795 return ()
796
797 batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()
798 batchMsg hsc_env mb_mod_index recomp mod_summary =
799 case recomp of
800 RecompRequired -> showMsg "Compiling "
801 RecompNotRequired
802 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping "
803 | otherwise -> return ()
804 RecompForcedByTH -> showMsg "Compiling [TH] "
805 where
806 showMsg msg =
807 compilationProgressMsg (hsc_dflags hsc_env) $
808 (showModuleIndex mb_mod_index ++
809 msg ++ showModMsg (hscTarget (hsc_dflags hsc_env))
810 (recomp == RecompRequired) mod_summary)
811
812 --------------------------------------------------------------
813 -- FrontEnds
814 --------------------------------------------------------------
815
816 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
817 hscFileFrontEnd mod_summary = do
818 hpm <- hscParse' mod_summary
819 hsc_env <- getHscEnv
820 dflags <- getDynFlags
821 tcg_env <-
822 {-# SCC "Typecheck-Rename" #-}
823 ioMsgMaybe $
824 tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm
825 tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
826
827 -- end of the Safe Haskell line, how to respond to user?
828 if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
829
830 -- if safe haskell off or safe infer failed, wipe trust
831 then wipeTrust tcg_env emptyBag
832
833 -- module safe, throw warning if needed
834 else do
835 tcg_env' <- hscCheckSafeImports tcg_env
836 safe <- liftIO $ hscGetSafeInf hsc_env
837 when (safe && wopt Opt_WarnSafe dflags)
838 (logWarnings $ unitBag $
839 mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env')
840 return tcg_env'
841 where
842 pprMod t = ppr $ moduleName $ tcg_mod t
843 errSafe t = text "Warning:" <+> quotes (pprMod t)
844 <+> text "has been infered as safe!"
845
846 --------------------------------------------------------------
847 -- Safe Haskell
848 --------------------------------------------------------------
849
850 -- Note [Safe Haskell Trust Check]
851 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
852 -- Safe Haskell checks that an import is trusted according to the following
853 -- rules for an import of module M that resides in Package P:
854 --
855 -- * If M is recorded as Safe and all its trust dependencies are OK
856 -- then M is considered safe.
857 -- * If M is recorded as Trustworthy and P is considered trusted and
858 -- all M's trust dependencies are OK then M is considered safe.
859 --
860 -- By trust dependencies we mean that the check is transitive. So if
861 -- a module M that is Safe relies on a module N that is trustworthy,
862 -- importing module M will first check (according to the second case)
863 -- that N is trusted before checking M is trusted.
864 --
865 -- This is a minimal description, so please refer to the user guide
866 -- for more details. The user guide is also considered the authoritative
867 -- source in this matter, not the comments or code.
868
869
870 -- Note [Safe Haskell Inference]
871 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
872 -- Safe Haskell does Safe inference on modules that don't have any specific
873 -- safe haskell mode flag. The basic aproach to this is:
874 -- * When deciding if we need to do a Safe language check, treat
875 -- an unmarked module as having -XSafe mode specified.
876 -- * For checks, don't throw errors but return them to the caller.
877 -- * Caller checks if there are errors:
878 -- * For modules explicitly marked -XSafe, we throw the errors.
879 -- * For unmarked modules (inference mode), we drop the errors
880 -- and mark the module as being Unsafe.
881
882
883 -- | Check that the safe imports of the module being compiled are valid.
884 -- If not we either issue a compilation error if the module is explicitly
885 -- using Safe Haskell, or mark the module as unsafe if we're in safe
886 -- inference mode.
887 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
888 hscCheckSafeImports tcg_env = do
889 hsc_env <- getHscEnv
890 dflags <- getDynFlags
891 tcg_env' <- checkSafeImports dflags hsc_env tcg_env
892 case safeLanguageOn dflags of
893 True -> do
894 -- we nuke user written RULES in -XSafe
895 logWarnings $ warns (tcg_rules tcg_env')
896 return tcg_env' { tcg_rules = [] }
897 False
898 -- user defined RULES, so not safe or already unsafe
899 | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
900 safeHaskell dflags == Sf_None
901 -> wipeTrust tcg_env' $ warns (tcg_rules tcg_env')
902
903 -- trustworthy OR safe infered with no RULES
904 | otherwise
905 -> return tcg_env'
906
907 where
908 warns rules = listToBag $ map warnRules rules
909 warnRules (L loc (HsRule n _ _ _ _ _ _)) =
910 mkPlainWarnMsg loc $
911 text "Rule \"" <> ftext n <> text "\" ignored" $+$
912 text "User defined rules are disabled under Safe Haskell"
913
914 -- | Validate that safe imported modules are actually safe.
915 -- For modules in the HomePackage (the package the module we
916 -- are compiling in resides) this just involves checking its
917 -- trust type is 'Safe' or 'Trustworthy'. For modules that
918 -- reside in another package we also must check that the
919 -- external pacakge is trusted. See the Note [Safe Haskell
920 -- Trust Check] above for more information.
921 --
922 -- The code for this is quite tricky as the whole algorithm
923 -- is done in a few distinct phases in different parts of the
924 -- code base. See RnNames.rnImportDecl for where package trust
925 -- dependencies for a module are collected and unioned.
926 -- Specifically see the Note [RnNames . Tracking Trust Transitively]
927 -- and the Note [RnNames . Trust Own Package].
928 checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
929 checkSafeImports dflags hsc_env tcg_env
930 = do
931 -- We want to use the warning state specifically for detecting if safe
932 -- inference has failed, so store and clear any existing warnings.
933 oldErrs <- getWarnings
934 clearWarnings
935
936 imps <- mapM condense imports'
937 pkgs <- mapM checkSafe imps
938
939 -- grab any safe haskell specific errors and restore old warnings
940 errs <- getWarnings
941 clearWarnings
942 logWarnings oldErrs
943
944 -- See the Note [ Safe Haskell Inference]
945 case (not $ isEmptyBag errs) of
946
947 -- We have errors!
948 True ->
949 -- did we fail safe inference or fail -XSafe?
950 case safeInferOn dflags of
951 True -> wipeTrust tcg_env errs
952 False -> liftIO . throwIO . mkSrcErr $ errs
953
954 -- All good matey!
955 False -> do
956 when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
957 -- add in trusted package requirements for this module
958 let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
959 return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
960
961 where
962 imp_info = tcg_imports tcg_env -- ImportAvails
963 imports = imp_mods imp_info -- ImportedMods
964 imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
965 pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
966
967 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
968 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
969 condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
970 -- we turn all imports into safe ones when
971 -- inference mode is on.
972 let s' = if safeInferOn dflags then True else s
973 return (m, l, s')
974
975 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
976 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
977 cond' v1@(m1,_,l1,s1) (_,_,_,s2)
978 | s1 /= s2
979 = throwErrors $ unitBag $ mkPlainErrMsg l1
980 (text "Module" <+> ppr m1 <+>
981 (text $ "is imported both as a safe and unsafe import!"))
982 | otherwise
983 = return v1
984
985 lookup' :: Module -> Hsc (Maybe ModIface)
986 lookup' m = do
987 hsc_eps <- liftIO $ hscEPS hsc_env
988 let pkgIfaceT = eps_PIT hsc_eps
989 homePkgT = hsc_HPT hsc_env
990 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
991 return iface
992
993 isHomePkg :: Module -> Bool
994 isHomePkg m
995 | thisPackage dflags == modulePackageId m = True
996 | otherwise = False
997
998 -- | Check the package a module resides in is trusted.
999 -- Safe compiled modules are trusted without requiring
1000 -- that their package is trusted. For trustworthy modules,
1001 -- modules in the home package are trusted but otherwise
1002 -- we check the package trust flag.
1003 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
1004 packageTrusted _ _ _
1005 | not (packageTrustOn dflags) = True
1006 packageTrusted Sf_Safe False _ = True
1007 packageTrusted Sf_SafeInfered False _ = True
1008 packageTrusted _ _ m
1009 | isHomePkg m = True
1010 | otherwise = trusted $ getPackageDetails (pkgState dflags)
1011 (modulePackageId m)
1012
1013 -- Is a module trusted? Return Nothing if True, or a String
1014 -- if it isn't, containing the reason it isn't. Also return
1015 -- if the module trustworthy (true) or safe (false) so we know
1016 -- if we should check if the package itself is trusted in the
1017 -- future.
1018 isModSafe :: Module -> SrcSpan -> Hsc (Bool)
1019 isModSafe m l = do
1020 iface <- lookup' m
1021 case iface of
1022 -- can't load iface to check trust!
1023 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l
1024 $ text "Can't load the interface file for" <+> ppr m <>
1025 text ", to check that it can be safely imported"
1026
1027 -- got iface, check trust
1028 Just iface' -> do
1029 let trust = getSafeMode $ mi_trust iface'
1030 trust_own_pkg = mi_trust_pkg iface'
1031 -- check module is trusted
1032 safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy]
1033 -- check package is trusted
1034 safeP = packageTrusted trust trust_own_pkg m
1035 case (safeM, safeP) of
1036 -- General errors we throw but Safe errors we log
1037 (True, True ) -> return $ trust == Sf_Trustworthy
1038 (True, False) -> liftIO . throwIO $ pkgTrustErr
1039 (False, _ ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy)
1040
1041 where
1042 pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m
1043 <+> text "can't be safely imported!" <+> text "The package ("
1044 <> ppr (modulePackageId m)
1045 <> text ") the module resides in isn't trusted."
1046 modTrustErr = unitBag $ mkPlainErrMsg l $ ppr m
1047 <+> text "can't be safely imported!"
1048 <+> text "The module itself isn't safe."
1049
1050 -- Here we check the transitive package trust requirements are OK still.
1051 checkPkgTrust :: [PackageId] -> Hsc ()
1052 checkPkgTrust pkgs =
1053 case errors of
1054 [] -> return ()
1055 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1056 where
1057 errors = catMaybes $ map go pkgs
1058 go pkg
1059 | trusted $ getPackageDetails (pkgState dflags) pkg
1060 = Nothing
1061 | otherwise
1062 = Just $ mkPlainErrMsg noSrcSpan
1063 $ text "The package (" <> ppr pkg <> text ") is required"
1064 <> text " to be trusted but it isn't!"
1065
1066 checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
1067 checkSafe (_, _, False) = return Nothing
1068 checkSafe (m, l, True ) = do
1069 tw <- isModSafe m l
1070 return $ pkg tw
1071 where pkg False = Nothing
1072 pkg True | isHomePkg m = Nothing
1073 | otherwise = Just (modulePackageId m)
1074
1075 -- | Set module to unsafe and wipe trust information.
1076 --
1077 -- Make sure to call this method to set a module to infered unsafe,
1078 -- it should be a central and single failure method.
1079 wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1080 wipeTrust tcg_env whyUnsafe = do
1081 env <- getHscEnv
1082 dflags <- getDynFlags
1083
1084 when (wopt Opt_WarnUnsafe dflags)
1085 (logWarnings $ unitBag $
1086 mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe')
1087
1088 liftIO $ hscSetSafeInf env False
1089 return $ tcg_env { tcg_imports = wiped_trust }
1090
1091 where
1092 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
1093 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1094 whyUnsafe' = vcat [ text "Warning:" <+> quotes pprMod
1095 <+> text "has been infered as unsafe!"
1096 , text "Reason:"
1097 , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ]
1098
1099
1100 --------------------------------------------------------------
1101 -- Simplifiers
1102 --------------------------------------------------------------
1103
1104 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1105 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1106
1107 hscSimplify' :: ModGuts -> Hsc ModGuts
1108 hscSimplify' ds_result = do
1109 hsc_env <- getHscEnv
1110 {-# SCC "Core2Core" #-}
1111 liftIO $ core2core hsc_env ds_result
1112
1113 --------------------------------------------------------------
1114 -- Interface generators
1115 --------------------------------------------------------------
1116
1117 hscSimpleIface :: TcGblEnv
1118 -> Maybe Fingerprint
1119 -> Hsc (ModIface, Bool, ModDetails)
1120 hscSimpleIface tc_result mb_old_iface = do
1121 hsc_env <- getHscEnv
1122 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1123 (new_iface, no_change)
1124 <- {-# SCC "MkFinalIface" #-}
1125 ioMsgMaybe $
1126 mkIfaceTc hsc_env mb_old_iface details tc_result
1127 -- And the answer is ...
1128 liftIO $ dumpIfaceStats hsc_env
1129 return (new_iface, no_change, details)
1130
1131 hscNormalIface :: ModGuts
1132 -> Maybe Fingerprint
1133 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1134 hscNormalIface simpl_result mb_old_iface = do
1135 hsc_env <- getHscEnv
1136 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1137 liftIO $ tidyProgram hsc_env simpl_result
1138
1139 -- BUILD THE NEW ModIface and ModDetails
1140 -- and emit external core if necessary
1141 -- This has to happen *after* code gen so that the back-end
1142 -- info has been set. Not yet clear if it matters waiting
1143 -- until after code output
1144 (new_iface, no_change)
1145 <- {-# SCC "MkFinalIface" #-}
1146 ioMsgMaybe $
1147 mkIface hsc_env mb_old_iface details simpl_result
1148
1149 -- Emit external core
1150 -- This should definitely be here and not after CorePrep,
1151 -- because CorePrep produces unqualified constructor wrapper declarations,
1152 -- so its output isn't valid External Core (without some preprocessing).
1153 liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
1154 liftIO $ dumpIfaceStats hsc_env
1155
1156 -- Return the prepared code.
1157 return (new_iface, no_change, details, cg_guts)
1158
1159 --------------------------------------------------------------
1160 -- BackEnd combinators
1161 --------------------------------------------------------------
1162
1163 hscWriteIface :: ModIface -> Bool -> ModSummary -> Hsc ()
1164 hscWriteIface iface no_change mod_summary = do
1165 dflags <- getDynFlags
1166 unless no_change $
1167 {-# SCC "writeIface" #-}
1168 liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
1169
1170 -- | Compile to hard-code.
1171 hscGenHardCode :: CgGuts -> ModSummary
1172 -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1173 hscGenHardCode cgguts mod_summary = do
1174 hsc_env <- getHscEnv
1175 liftIO $ do
1176 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1177 -- From now on, we just use the bits we need.
1178 cg_module = this_mod,
1179 cg_binds = core_binds,
1180 cg_tycons = tycons,
1181 cg_foreign = foreign_stubs0,
1182 cg_dep_pkgs = dependencies,
1183 cg_hpc_info = hpc_info } = cgguts
1184 dflags = hsc_dflags hsc_env
1185 platform = targetPlatform dflags
1186 location = ms_location mod_summary
1187 data_tycons = filter isDataTyCon tycons
1188 -- cg_tycons includes newtypes, for the benefit of External Core,
1189 -- but we don't generate any code for newtypes
1190
1191 -------------------
1192 -- PREPARE FOR CODE GENERATION
1193 -- Do saturation and convert to A-normal form
1194 prepd_binds <- {-# SCC "CorePrep" #-}
1195 corePrepPgm dflags core_binds data_tycons ;
1196 ----------------- Convert to STG ------------------
1197 (stg_binds, cost_centre_info)
1198 <- {-# SCC "CoreToStg" #-}
1199 myCoreToStg dflags this_mod prepd_binds
1200
1201 let prof_init = profilingInitCode platform this_mod cost_centre_info
1202 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1203
1204 ------------------ Code generation ------------------
1205
1206 cmms <- if dopt Opt_TryNewCodeGen dflags
1207 then {-# SCC "NewCodeGen" #-}
1208 tryNewCodeGen hsc_env this_mod data_tycons
1209 cost_centre_info
1210 stg_binds hpc_info
1211 else {-# SCC "CodeGen" #-}
1212 codeGen dflags this_mod data_tycons
1213 cost_centre_info
1214 stg_binds hpc_info
1215
1216 ------------------ Code output -----------------------
1217 rawcmms <- {-# SCC "cmmToRawCmm" #-}
1218 cmmToRawCmm platform cmms
1219 dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
1220 (_stub_h_exists, stub_c_exists)
1221 <- {-# SCC "codeOutput" #-}
1222 codeOutput dflags this_mod location foreign_stubs
1223 dependencies rawcmms
1224 return stub_c_exists
1225
1226 hscInteractive :: (ModIface, ModDetails, CgGuts)
1227 -> ModSummary
1228 -> Hsc (InteractiveStatus, ModIface, ModDetails)
1229 #ifdef GHCI
1230 hscInteractive (iface, details, cgguts) mod_summary = do
1231 dflags <- getDynFlags
1232 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1233 -- From now on, we just use the bits we need.
1234 cg_module = this_mod,
1235 cg_binds = core_binds,
1236 cg_tycons = tycons,
1237 cg_foreign = foreign_stubs,
1238 cg_modBreaks = mod_breaks } = cgguts
1239
1240 location = ms_location mod_summary
1241 data_tycons = filter isDataTyCon tycons
1242 -- cg_tycons includes newtypes, for the benefit of External Core,
1243 -- but we don't generate any code for newtypes
1244
1245 -------------------
1246 -- PREPARE FOR CODE GENERATION
1247 -- Do saturation and convert to A-normal form
1248 prepd_binds <- {-# SCC "CorePrep" #-}
1249 liftIO $ corePrepPgm dflags core_binds data_tycons ;
1250 ----------------- Generate byte code ------------------
1251 comp_bc <- liftIO $ byteCodeGen dflags this_mod prepd_binds
1252 data_tycons mod_breaks
1253 ------------------ Create f-x-dynamic C-side stuff ---
1254 (_istub_h_exists, istub_c_exists)
1255 <- liftIO $ outputForeignStubs dflags this_mod
1256 location foreign_stubs
1257 return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
1258 , iface, details)
1259 #else
1260 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1261 #endif
1262
1263 ------------------------------
1264
1265 hscCompileCmmFile :: HscEnv -> FilePath -> IO ()
1266 hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
1267 let dflags = hsc_dflags hsc_env
1268 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1269 liftIO $ do
1270 rawCmms <- cmmToRawCmm (targetPlatform dflags) [cmm]
1271 _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
1272 return ()
1273 where
1274 no_mod = panic "hscCmmFile: no_mod"
1275 no_loc = ModLocation{ ml_hs_file = Just filename,
1276 ml_hi_file = panic "hscCmmFile: no hi file",
1277 ml_obj_file = panic "hscCmmFile: no obj file" }
1278
1279 -------------------- Stuff for new code gen ---------------------
1280
1281 tryNewCodeGen :: HscEnv -> Module -> [TyCon]
1282 -> CollectedCCs
1283 -> [(StgBinding,[(Id,[Id])])]
1284 -> HpcInfo
1285 -> IO [Old.CmmGroup]
1286 tryNewCodeGen hsc_env this_mod data_tycons
1287 cost_centre_info stg_binds hpc_info = do
1288 let dflags = hsc_dflags hsc_env
1289 platform = targetPlatform dflags
1290 prog <- StgCmm.codeGen dflags this_mod data_tycons
1291 cost_centre_info stg_binds hpc_info
1292 dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
1293 (pprCmms platform prog)
1294
1295 -- We are building a single SRT for the entire module, so
1296 -- we must thread it through all the procedures as we cps-convert them.
1297 us <- mkSplitUniqSupply 'S'
1298 let initTopSRT = initUs_ us emptySRT
1299 (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
1300
1301 let prog' = map cmmOfZgraph (srtToData topSRT : prog)
1302 dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
1303 return prog'
1304
1305 myCoreToStg :: DynFlags -> Module -> CoreProgram
1306 -> IO ( [(StgBinding,[(Id,[Id])])] -- output program
1307 , CollectedCCs) -- cost centre info (declared and used)
1308 myCoreToStg dflags this_mod prepd_binds = do
1309 stg_binds
1310 <- {-# SCC "Core2Stg" #-}
1311 coreToStg dflags prepd_binds
1312
1313 (stg_binds2, cost_centre_info)
1314 <- {-# SCC "Stg2Stg" #-}
1315 stg2stg dflags this_mod stg_binds
1316
1317 return (stg_binds2, cost_centre_info)
1318
1319
1320 {- **********************************************************************
1321 %* *
1322 \subsection{Compiling a do-statement}
1323 %* *
1324 %********************************************************************* -}
1325
1326 {-
1327 When the UnlinkedBCOExpr is linked you get an HValue of type
1328 IO [HValue]
1329 When you run it you get a list of HValues that should be
1330 the same length as the list of names; add them to the ClosureEnv.
1331
1332 A naked expression returns a singleton Name [it].
1333
1334 What you type The IO [HValue] that hscStmt returns
1335 ------------- ------------------------------------
1336 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1337 bindings: [x,y,...]
1338
1339 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1340 bindings: [x,y,...]
1341
1342 expr (of IO type) ==> expr >>= \ v -> return [v]
1343 [NB: result not printed] bindings: [it]
1344
1345
1346 expr (of non-IO type,
1347 result showable) ==> let v = expr in print v >> return [v]
1348 bindings: [it]
1349
1350 expr (of non-IO type,
1351 result not showable) ==> error
1352 -}
1353
1354 #ifdef GHCI
1355 -- | Compile a stmt all the way to an HValue, but don't run it
1356 hscStmt :: HscEnv
1357 -> String -- ^ The statement
1358 -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement
1359 -- (or comment only), but no parse error
1360 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1361
1362 -- | Compile a stmt all the way to an HValue, but don't run it
1363 hscStmtWithLocation :: HscEnv
1364 -> String -- ^ The statement
1365 -> String -- ^ The source
1366 -> Int -- ^ Starting line
1367 -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement
1368 -- (or comment only), but no parse error
1369 hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
1370 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1371 case maybe_stmt of
1372 Nothing -> return Nothing
1373
1374 -- The real stuff
1375 Just parsed_stmt -> do
1376 -- Rename and typecheck it
1377 let icontext = hsc_IC hsc_env
1378 (ids, tc_expr) <- ioMsgMaybe $
1379 tcRnStmt hsc_env icontext parsed_stmt
1380 -- Desugar it
1381 let rdr_env = ic_rn_gbl_env icontext
1382 type_env = mkTypeEnvWithImplicits (ic_tythings icontext)
1383 ds_expr <- ioMsgMaybe $
1384 deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1385 handleWarnings
1386
1387 -- Then code-gen, and link it
1388 let src_span = srcLocSpan interactiveSrcLoc
1389 hsc_env <- getHscEnv
1390 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1391
1392 return $ Just (ids, hval)
1393
1394 -- | Compile a decls
1395 hscDecls :: HscEnv
1396 -> String -- ^ The statement
1397 -> IO ([TyThing], InteractiveContext)
1398 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1399
1400 -- | Compile a decls
1401 hscDeclsWithLocation :: HscEnv
1402 -> String -- ^ The statement
1403 -> String -- ^ The source
1404 -> Int -- ^ Starting line
1405 -> IO ([TyThing], InteractiveContext)
1406 hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
1407 L _ (HsModule{ hsmodDecls = decls }) <-
1408 hscParseThingWithLocation source linenumber parseModule str
1409
1410 {- Rename and typecheck it -}
1411 let icontext = hsc_IC hsc_env
1412 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env icontext decls
1413
1414 {- Grab the new instances -}
1415 -- We grab the whole environment because of the overlapping that may have
1416 -- been done. See the notes at the definition of InteractiveContext
1417 -- (ic_instances) for more details.
1418 let finsts = famInstEnvElts $ tcg_fam_inst_env tc_gblenv
1419 insts = instEnvElts $ tcg_inst_env tc_gblenv
1420
1421 {- Desugar it -}
1422 -- We use a basically null location for iNTERACTIVE
1423 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1424 ml_hi_file = undefined,
1425 ml_obj_file = undefined}
1426 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1427
1428 {- Simplify -}
1429 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1430
1431 {- Tidy -}
1432 (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1433
1434 let dflags = hsc_dflags hsc_env
1435 !CgGuts{ cg_module = this_mod,
1436 cg_binds = core_binds,
1437 cg_tycons = tycons,
1438 cg_modBreaks = mod_breaks } = tidy_cg
1439 data_tycons = filter isDataTyCon tycons
1440
1441 {- Prepare For Code Generation -}
1442 -- Do saturation and convert to A-normal form
1443 prepd_binds <- {-# SCC "CorePrep" #-}
1444 liftIO $ corePrepPgm dflags core_binds data_tycons
1445
1446 {- Generate byte code -}
1447 cbc <- liftIO $ byteCodeGen dflags this_mod
1448 prepd_binds data_tycons mod_breaks
1449
1450 let src_span = srcLocSpan interactiveSrcLoc
1451 hsc_env <- getHscEnv
1452 liftIO $ linkDecls hsc_env src_span cbc
1453
1454 let tcs = filter (not . isImplicitTyCon) $ (mg_tcs simpl_mg)
1455
1456 ext_vars = filter (isExternalName . idName) $
1457 bindersOfBinds core_binds
1458
1459 (sys_vars, user_vars) = partition is_sys_var ext_vars
1460 is_sys_var id = isDFunId id
1461 || isRecordSelector id
1462 || isJust (isClassOpId_maybe id)
1463 -- we only need to keep around the external bindings
1464 -- (as decided by TidyPgm), since those are the only ones
1465 -- that might be referenced elsewhere.
1466
1467 tythings = map AnId user_vars
1468 ++ map ATyCon tcs
1469
1470 let ictxt1 = extendInteractiveContext icontext tythings
1471 ictxt = ictxt1 { ic_sys_vars = sys_vars ++ ic_sys_vars ictxt1,
1472 ic_instances = (insts, finsts) }
1473
1474 return (tythings, ictxt)
1475
1476 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1477 hscImport hsc_env str = runHsc hsc_env $ do
1478 (L _ (HsModule{hsmodImports=is})) <-
1479 hscParseThing parseModule str
1480 case is of
1481 [i] -> return (unLoc i)
1482 _ -> liftIO $ throwOneError $
1483 mkPlainErrMsg noSrcSpan $
1484 ptext (sLit "parse error in import declaration")
1485
1486 -- | Typecheck an expression (but don't run it)
1487 hscTcExpr :: HscEnv
1488 -> String -- ^ The expression
1489 -> IO Type
1490 hscTcExpr hsc_env expr = runHsc hsc_env $ do
1491 maybe_stmt <- hscParseStmt expr
1492 case maybe_stmt of
1493 Just (L _ (ExprStmt expr _ _ _)) ->
1494 ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
1495 _ ->
1496 throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan
1497 (text "not an expression:" <+> quotes (text expr))
1498
1499 -- | Find the kind of a type
1500 hscKcType
1501 :: HscEnv
1502 -> Bool -- ^ Normalise the type
1503 -> String -- ^ The type as a string
1504 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1505 hscKcType hsc_env normalise str = runHsc hsc_env $ do
1506 ty <- hscParseType str
1507 ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty
1508
1509 hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
1510 hscParseStmt = hscParseThing parseStmt
1511
1512 hscParseStmtWithLocation :: String -> Int -> String
1513 -> Hsc (Maybe (LStmt RdrName))
1514 hscParseStmtWithLocation source linenumber stmt =
1515 hscParseThingWithLocation source linenumber parseStmt stmt
1516
1517 hscParseType :: String -> Hsc (LHsType RdrName)
1518 hscParseType = hscParseThing parseType
1519 #endif
1520
1521 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1522 hscParseIdentifier hsc_env str =
1523 runHsc hsc_env $ hscParseThing parseIdentifier str
1524
1525 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1526 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1527
1528 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1529 -> Lexer.P thing -> String -> Hsc thing
1530 hscParseThingWithLocation source linenumber parser str
1531 = {-# SCC "Parser" #-} do
1532 dflags <- getDynFlags
1533 liftIO $ showPass dflags "Parser"
1534
1535 let buf = stringToStringBuffer str
1536 loc = mkRealSrcLoc (fsLit source) linenumber 1
1537
1538 case unP parser (mkPState dflags buf loc) of
1539 PFailed span err -> do
1540 let msg = mkPlainErrMsg span err
1541 throwErrors $ unitBag msg
1542
1543 POk pst thing -> do
1544 logWarningsReportErrors (getMessages pst)
1545 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1546 return thing
1547
1548 hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO ()
1549 hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do
1550 guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds)
1551 (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
1552 hscWriteIface iface changed mod_summary
1553 _ <- hscGenHardCode cgguts mod_summary
1554 return ()
1555
1556 where
1557 maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1558 | otherwise = return mod_guts
1559
1560 -- Makes a "vanilla" ModGuts.
1561 mkModGuts :: Module -> CoreProgram -> ModGuts
1562 mkModGuts mod binds =
1563 ModGuts {
1564 mg_module = mod,
1565 mg_boot = False,
1566 mg_exports = [],
1567 mg_deps = noDependencies,
1568 mg_dir_imps = emptyModuleEnv,
1569 mg_used_names = emptyNameSet,
1570 mg_used_th = False,
1571 mg_rdr_env = emptyGlobalRdrEnv,
1572 mg_fix_env = emptyFixityEnv,
1573 mg_tcs = [],
1574 mg_insts = [],
1575 mg_fam_insts = [],
1576 mg_rules = [],
1577 mg_vect_decls = [],
1578 mg_binds = binds,
1579 mg_foreign = NoStubs,
1580 mg_warns = NoWarnings,
1581 mg_anns = [],
1582 mg_hpc_info = emptyHpcInfo False,
1583 mg_modBreaks = emptyModBreaks,
1584 mg_vect_info = noVectInfo,
1585 mg_inst_env = emptyInstEnv,
1586 mg_fam_inst_env = emptyFamInstEnv,
1587 mg_trust_pkg = False,
1588 mg_dependent_files = []
1589 }
1590
1591
1592 {- **********************************************************************
1593 %* *
1594 Desugar, simplify, convert to bytecode, and link an expression
1595 %* *
1596 %********************************************************************* -}
1597
1598 #ifdef GHCI
1599 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1600 hscCompileCoreExpr hsc_env srcspan ds_expr
1601 | rtsIsProfiled
1602 = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1603 -- Otherwise you get a seg-fault when you run it
1604
1605 | otherwise = do
1606 let dflags = hsc_dflags hsc_env
1607 let lint_on = dopt Opt_DoCoreLinting dflags
1608
1609 {- Simplify it -}
1610 simpl_expr <- simplifyExpr dflags ds_expr
1611
1612 {- Tidy it (temporary, until coreSat does cloning) -}
1613 let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1614
1615 {- Prepare for codegen -}
1616 prepd_expr <- corePrepExpr dflags tidy_expr
1617
1618 {- Lint if necessary -}
1619 -- ToDo: improve SrcLoc
1620 when lint_on $
1621 let ictxt = hsc_IC hsc_env
1622 te = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
1623 tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
1624 vars = typeEnvIds te
1625 in case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of
1626 Just err -> pprPanic "hscCompileCoreExpr" err
1627 Nothing -> return ()
1628
1629 {- Convert to BCOs -}
1630 bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr
1631
1632 {- link it -}
1633 hval <- linkExpr hsc_env srcspan bcos
1634
1635 return hval
1636 #endif
1637
1638
1639 {- **********************************************************************
1640 %* *
1641 Statistics on reading interfaces
1642 %* *
1643 %********************************************************************* -}
1644
1645 dumpIfaceStats :: HscEnv -> IO ()
1646 dumpIfaceStats hsc_env = do
1647 eps <- readIORef (hsc_EPS hsc_env)
1648 dumpIfSet (dump_if_trace || dump_rn_stats)
1649 "Interface statistics"
1650 (ifaceStats eps)
1651 where
1652 dflags = hsc_dflags hsc_env
1653 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1654 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1655
1656
1657 {- **********************************************************************
1658 %* *
1659 Progress Messages: Module i of n
1660 %* *
1661 %********************************************************************* -}
1662
1663 showModuleIndex :: Maybe (Int, Int) -> String
1664 showModuleIndex Nothing = ""
1665 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1666 where
1667 n_str = show n
1668 i_str = show i
1669 padded = replicate (length n_str - length i_str) ' ' ++ i_str
1670
GHC main repository