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