975ff9d5726fbf90084cd2b9db328de0e63b6ee0
[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
533 FilePath
534 (Maybe FilePath) -- Has stub files. This is a hack. We can't compile
535 -- C files here since it's done in DriverPipeline.
536 -- For now we just return True if we want the caller
537 -- to compile them for us.
538
539 type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
540
541 genericHscCompileGetFrontendResult ::
542 Bool -- always do basic recompilation check?
543 -> Maybe TcGblEnv
544 -> Maybe Messager
545 -> HscEnv
546 -> ModSummary
547 -> SourceModified
548 -> Maybe ModIface -- Old interface, if available
549 -> (Int,Int) -- (i,n) = module i of n (for msgs)
550 -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint))
551
552 genericHscCompileGetFrontendResult always_do_basic_recompilation_check m_tc_result
553 mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index
554 = do
555
556 let msg what = case mHscMessage of
557 Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
558 Nothing -> return ()
559
560 skip iface = do
561 msg UpToDate
562 return $ Left iface
563
564 compile mb_old_hash reason = do
565 msg reason
566 tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary
567 return $ Right (tc_result, mb_old_hash)
568
569 stable = case source_modified of
570 SourceUnmodifiedAndStable -> True
571 _ -> False
572
573 case m_tc_result of
574 Just tc_result
575 | not always_do_basic_recompilation_check ->
576 return $ Right (tc_result, Nothing)
577 _ -> do
578 (recomp_reqd, mb_checked_iface)
579 <- {-# SCC "checkOldIface" #-}
580 checkOldIface hsc_env mod_summary
581 source_modified mb_old_iface
582 -- save the interface that comes back from checkOldIface.
583 -- In one-shot mode we don't have the old iface until this
584 -- point, when checkOldIface reads it from the disk.
585 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
586
587 case mb_checked_iface of
588 Just iface | not (recompileRequired recomp_reqd) ->
589 -- If the module used TH splices when it was last compiled,
590 -- then the recompilation check is not accurate enough (#481)
591 -- and we must ignore it. However, if the module is stable
592 -- (none of the modules it depends on, directly or indirectly,
593 -- changed), then we *can* skip recompilation. This is why
594 -- the SourceModified type contains SourceUnmodifiedAndStable,
595 -- and it's pretty important: otherwise ghc --make would
596 -- always recompile TH modules, even if nothing at all has
597 -- changed. Stability is just the same check that make is
598 -- doing for us in one-shot mode.
599 case m_tc_result of
600 Nothing
601 | mi_used_th iface && not stable ->
602 compile mb_old_hash (RecompBecause "TH")
603 _ ->
604 skip iface
605 _ ->
606 case m_tc_result of
607 Nothing -> compile mb_old_hash recomp_reqd
608 Just tc_result ->
609 return $ Right (tc_result, mb_old_hash)
610
611 genericHscFrontend :: ModSummary -> Hsc TcGblEnv
612 genericHscFrontend mod_summary
613 | ExtCoreFile <- ms_hsc_src mod_summary =
614 panic "GHC does not currently support reading External Core files"
615 | otherwise = do
616 hscFileFrontEnd mod_summary
617
618 --------------------------------------------------------------
619 -- Compilers
620 --------------------------------------------------------------
621
622 -- Compile Haskell, boot and extCore in OneShot mode.
623 hscCompileOneShot :: HscEnv
624 -> ModSummary
625 -> SourceModified
626 -> IO HscStatus
627 hscCompileOneShot hsc_env mod_summary src_changed
628 = do
629 -- One-shot mode needs a knot-tying mutable variable for interface
630 -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
631 type_env_var <- newIORef emptyNameEnv
632 let mod = ms_mod mod_summary
633 hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
634
635 msg what = oneShotMsg hsc_env' what
636
637 skip = do msg UpToDate
638 dumpIfaceStats hsc_env'
639 return HscUpToDate
640
641 compile mb_old_hash reason = runHsc hsc_env' $ do
642 liftIO $ msg reason
643 tc_result <- genericHscFrontend mod_summary
644 dflags <- getDynFlags
645 case hscTarget dflags of
646 HscNothing -> return HscNotGeneratingCode
647 _ ->
648 case ms_hsc_src mod_summary of
649 HsBootFile ->
650 do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash
651 liftIO $ hscWriteIface dflags iface changed mod_summary
652 return HscUpdateBoot
653 _ ->
654 do guts0 <- hscDesugar' (ms_location mod_summary) tc_result
655 guts <- hscSimplify' guts0
656 (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
657 liftIO $ hscWriteIface dflags iface changed mod_summary
658 (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary
659 return $ HscRecomp outputFilename mStub
660
661 stable = case src_changed of
662 SourceUnmodifiedAndStable -> True
663 _ -> False
664
665 (recomp_reqd, mb_checked_iface)
666 <- {-# SCC "checkOldIface" #-}
667 checkOldIface hsc_env' mod_summary src_changed Nothing
668 -- save the interface that comes back from checkOldIface.
669 -- In one-shot mode we don't have the old iface until this
670 -- point, when checkOldIface reads it from the disk.
671 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
672
673 case mb_checked_iface of
674 Just iface | not (recompileRequired recomp_reqd) ->
675 -- If the module used TH splices when it was last compiled,
676 -- then the recompilation check is not accurate enough (#481)
677 -- and we must ignore it. However, if the module is stable
678 -- (none of the modules it depends on, directly or indirectly,
679 -- changed), then we *can* skip recompilation. This is why
680 -- the SourceModified type contains SourceUnmodifiedAndStable,
681 -- and it's pretty important: otherwise ghc --make would
682 -- always recompile TH modules, even if nothing at all has
683 -- changed. Stability is just the same check that make is
684 -- doing for us in one-shot mode.
685 if mi_used_th iface && not stable
686 then compile mb_old_hash (RecompBecause "TH")
687 else skip
688 _ ->
689 compile mb_old_hash recomp_reqd
690
691 --------------------------------------------------------------
692 -- NoRecomp handlers
693 --------------------------------------------------------------
694
695 genModDetails :: HscEnv -> ModIface -> IO ModDetails
696 genModDetails hsc_env old_iface
697 = do
698 new_details <- {-# SCC "tcRnIface" #-}
699 initIfaceCheck hsc_env (typecheckIface old_iface)
700 dumpIfaceStats hsc_env
701 return new_details
702
703 --------------------------------------------------------------
704 -- Progress displayers.
705 --------------------------------------------------------------
706
707 oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
708 oneShotMsg hsc_env recomp =
709 case recomp of
710 UpToDate ->
711 compilationProgressMsg (hsc_dflags hsc_env) $
712 "compilation IS NOT required"
713 _ ->
714 return ()
715
716 batchMsg :: Messager
717 batchMsg hsc_env mod_index recomp mod_summary =
718 case recomp of
719 MustCompile -> showMsg "Compiling " ""
720 UpToDate
721 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
722 | otherwise -> return ()
723 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
724 where
725 dflags = hsc_dflags hsc_env
726 showMsg msg reason =
727 compilationProgressMsg dflags $
728 (showModuleIndex mod_index ++
729 msg ++ showModMsg dflags (hscTarget dflags)
730 (recompileRequired recomp) mod_summary)
731 ++ reason
732
733 --------------------------------------------------------------
734 -- FrontEnds
735 --------------------------------------------------------------
736
737 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
738 hscFileFrontEnd mod_summary = do
739 hpm <- hscParse' mod_summary
740 hsc_env <- getHscEnv
741 tcg_env <- tcRnModule' hsc_env mod_summary False hpm
742 return tcg_env
743
744 --------------------------------------------------------------
745 -- Safe Haskell
746 --------------------------------------------------------------
747
748 -- Note [Safe Haskell Trust Check]
749 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
750 -- Safe Haskell checks that an import is trusted according to the following
751 -- rules for an import of module M that resides in Package P:
752 --
753 -- * If M is recorded as Safe and all its trust dependencies are OK
754 -- then M is considered safe.
755 -- * If M is recorded as Trustworthy and P is considered trusted and
756 -- all M's trust dependencies are OK then M is considered safe.
757 --
758 -- By trust dependencies we mean that the check is transitive. So if
759 -- a module M that is Safe relies on a module N that is trustworthy,
760 -- importing module M will first check (according to the second case)
761 -- that N is trusted before checking M is trusted.
762 --
763 -- This is a minimal description, so please refer to the user guide
764 -- for more details. The user guide is also considered the authoritative
765 -- source in this matter, not the comments or code.
766
767
768 -- Note [Safe Haskell Inference]
769 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
770 -- Safe Haskell does Safe inference on modules that don't have any specific
771 -- safe haskell mode flag. The basic aproach to this is:
772 -- * When deciding if we need to do a Safe language check, treat
773 -- an unmarked module as having -XSafe mode specified.
774 -- * For checks, don't throw errors but return them to the caller.
775 -- * Caller checks if there are errors:
776 -- * For modules explicitly marked -XSafe, we throw the errors.
777 -- * For unmarked modules (inference mode), we drop the errors
778 -- and mark the module as being Unsafe.
779
780
781 -- | Check that the safe imports of the module being compiled are valid.
782 -- If not we either issue a compilation error if the module is explicitly
783 -- using Safe Haskell, or mark the module as unsafe if we're in safe
784 -- inference mode.
785 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
786 hscCheckSafeImports tcg_env = do
787 dflags <- getDynFlags
788 tcg_env' <- checkSafeImports dflags tcg_env
789 case safeLanguageOn dflags of
790 True -> do
791 -- we nuke user written RULES in -XSafe
792 logWarnings $ warns dflags (tcg_rules tcg_env')
793 return tcg_env' { tcg_rules = [] }
794 False
795 -- user defined RULES, so not safe or already unsafe
796 | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
797 safeHaskell dflags == Sf_None
798 -> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env')
799
800 -- trustworthy OR safe inferred with no RULES
801 | otherwise
802 -> return tcg_env'
803
804 where
805 warns dflags rules = listToBag $ map (warnRules dflags) rules
806 warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
807 mkPlainWarnMsg dflags loc $
808 text "Rule \"" <> ftext n <> text "\" ignored" $+$
809 text "User defined rules are disabled under Safe Haskell"
810
811 -- | Validate that safe imported modules are actually safe. For modules in the
812 -- HomePackage (the package the module we are compiling in resides) this just
813 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
814 -- that reside in another package we also must check that the external pacakge
815 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
816 -- information.
817 --
818 -- The code for this is quite tricky as the whole algorithm is done in a few
819 -- distinct phases in different parts of the code base. See
820 -- RnNames.rnImportDecl for where package trust dependencies for a module are
821 -- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
822 -- Transitively] and the Note [RnNames . Trust Own Package].
823 checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
824 checkSafeImports dflags tcg_env
825 = do
826 -- We want to use the warning state specifically for detecting if safe
827 -- inference has failed, so store and clear any existing warnings.
828 oldErrs <- getWarnings
829 clearWarnings
830
831 imps <- mapM condense imports'
832 pkgs <- mapM checkSafe imps
833
834 -- grab any safe haskell specific errors and restore old warnings
835 errs <- getWarnings
836 clearWarnings
837 logWarnings oldErrs
838
839 -- See the Note [Safe Haskell Inference]
840 case (not $ isEmptyBag errs) of
841
842 -- We have errors!
843 True ->
844 -- did we fail safe inference or fail -XSafe?
845 case safeInferOn dflags of
846 True -> wipeTrust tcg_env errs
847 False -> liftIO . throwIO . mkSrcErr $ errs
848
849 -- All good matey!
850 False -> do
851 when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
852 -- add in trusted package requirements for this module
853 let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
854 return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
855
856 where
857 imp_info = tcg_imports tcg_env -- ImportAvails
858 imports = imp_mods imp_info -- ImportedMods
859 imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
860 pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
861
862 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
863 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
864 condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
865 -- we turn all imports into safe ones when
866 -- inference mode is on.
867 let s' = if safeInferOn dflags then True else s
868 return (m, l, s')
869
870 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
871 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
872 cond' v1@(m1,_,l1,s1) (_,_,_,s2)
873 | s1 /= s2
874 = throwErrors $ unitBag $ mkPlainErrMsg dflags l1
875 (text "Module" <+> ppr m1 <+>
876 (text $ "is imported both as a safe and unsafe import!"))
877 | otherwise
878 = return v1
879
880 -- easier interface to work with
881 checkSafe (_, _, False) = return Nothing
882 checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
883
884 -- | Check that a module is safe to import.
885 --
886 -- We return True to indicate the import is safe and False otherwise
887 -- although in the False case an exception may be thrown first.
888 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
889 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
890 dflags <- getDynFlags
891 pkgs <- snd `fmap` hscCheckSafe' dflags m l
892 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
893 errs <- getWarnings
894 return $ isEmptyBag errs
895
896 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
897 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageId])
898 hscGetSafe hsc_env m l = runHsc hsc_env $ do
899 dflags <- getDynFlags
900 (self, pkgs) <- hscCheckSafe' dflags m l
901 good <- isEmptyBag `fmap` getWarnings
902 clearWarnings -- don't want them printed...
903 let pkgs' | Just p <- self = p:pkgs
904 | otherwise = pkgs
905 return (good, pkgs')
906
907 -- | Is a module trusted? If not, throw or log errors depending on the type.
908 -- Return (regardless of trusted or not) if the trust type requires the modules
909 -- own package be trusted and a list of other packages required to be trusted
910 -- (these later ones haven't been checked) but the own package trust has been.
911 hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
912 hscCheckSafe' dflags m l = do
913 (tw, pkgs) <- isModSafe m l
914 case tw of
915 False -> return (Nothing, pkgs)
916 True | isHomePkg m -> return (Nothing, pkgs)
917 | otherwise -> return (Just $ modulePackageId m, pkgs)
918 where
919 isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
920 isModSafe m l = do
921 iface <- lookup' m
922 case iface of
923 -- can't load iface to check trust!
924 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
925 $ text "Can't load the interface file for" <+> ppr m
926 <> text ", to check that it can be safely imported"
927
928 -- got iface, check trust
929 Just iface' ->
930 let trust = getSafeMode $ mi_trust iface'
931 trust_own_pkg = mi_trust_pkg iface'
932 -- check module is trusted
933 safeM = trust `elem` [Sf_SafeInferred, Sf_Safe, Sf_Trustworthy]
934 -- check package is trusted
935 safeP = packageTrusted trust trust_own_pkg m
936 -- pkg trust reqs
937 pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
938 -- General errors we throw but Safe errors we log
939 errs = case (safeM, safeP) of
940 (True, True ) -> emptyBag
941 (True, False) -> pkgTrustErr
942 (False, _ ) -> modTrustErr
943 in do
944 logWarnings errs
945 return (trust == Sf_Trustworthy, pkgRs)
946
947 where
948 pkgTrustErr = unitBag $ mkPlainErrMsg dflags l $
949 sep [ ppr (moduleName m)
950 <> text ": Can't be safely imported!"
951 , text "The package (" <> ppr (modulePackageId m)
952 <> text ") the module resides in isn't trusted."
953 ]
954 modTrustErr = unitBag $ mkPlainErrMsg dflags l $
955 sep [ ppr (moduleName m)
956 <> text ": Can't be safely imported!"
957 , text "The module itself isn't safe." ]
958
959 -- | Check the package a module resides in is trusted. Safe compiled
960 -- modules are trusted without requiring that their package is trusted. For
961 -- trustworthy modules, modules in the home package are trusted but
962 -- otherwise we check the package trust flag.
963 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
964 packageTrusted Sf_None _ _ = False -- shouldn't hit these cases
965 packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness.
966 packageTrusted _ _ _
967 | not (packageTrustOn dflags) = True
968 packageTrusted Sf_Safe False _ = True
969 packageTrusted Sf_SafeInferred False _ = True
970 packageTrusted _ _ m
971 | isHomePkg m = True
972 | otherwise = trusted $ getPackageDetails (pkgState dflags)
973 (modulePackageId m)
974
975 lookup' :: Module -> Hsc (Maybe ModIface)
976 lookup' m = do
977 hsc_env <- getHscEnv
978 hsc_eps <- liftIO $ hscEPS hsc_env
979 let pkgIfaceT = eps_PIT hsc_eps
980 homePkgT = hsc_HPT hsc_env
981 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
982 #ifdef GHCI
983 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
984 -- as the compiler hasn't filled in the various module tables
985 -- so we need to call 'getModuleInterface' to load from disk
986 iface' <- case iface of
987 Just _ -> return iface
988 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
989 return iface'
990 #else
991 return iface
992 #endif
993
994
995 isHomePkg :: Module -> Bool
996 isHomePkg m
997 | thisPackage dflags == modulePackageId m = True
998 | otherwise = False
999
1000 -- | Check the list of packages are trusted.
1001 checkPkgTrust :: DynFlags -> [PackageId] -> Hsc ()
1002 checkPkgTrust dflags pkgs =
1003 case errors of
1004 [] -> return ()
1005 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1006 where
1007 errors = catMaybes $ map go pkgs
1008 go pkg
1009 | trusted $ getPackageDetails (pkgState dflags) pkg
1010 = Nothing
1011 | otherwise
1012 = Just $ mkPlainErrMsg dflags noSrcSpan
1013 $ text "The package (" <> ppr pkg <> text ") is required" <>
1014 text " to be trusted but it isn't!"
1015
1016 -- | Set module to unsafe and wipe trust information.
1017 --
1018 -- Make sure to call this method to set a module to inferred unsafe,
1019 -- it should be a central and single failure method.
1020 wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1021 wipeTrust tcg_env whyUnsafe = do
1022 dflags <- getDynFlags
1023
1024 when (wopt Opt_WarnUnsafe dflags)
1025 (logWarnings $ unitBag $
1026 mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
1027
1028 liftIO $ writeIORef (tcg_safeInfer tcg_env) False
1029 return $ tcg_env { tcg_imports = wiped_trust }
1030
1031 where
1032 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
1033 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1034 whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
1035 , text "Reason:"
1036 , nest 4 $ (vcat $ badFlags df) $+$
1037 (vcat $ pprErrMsgBagWithLoc whyUnsafe)
1038 ]
1039 badFlags df = concat $ map (badFlag df) unsafeFlags
1040 badFlag df (str,loc,on,_)
1041 | on df = [mkLocMessage SevOutput (loc df) $
1042 text str <+> text "is not allowed in Safe Haskell"]
1043 | otherwise = []
1044
1045 -- | Figure out the final correct safe haskell mode
1046 hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
1047 hscGetSafeMode tcg_env = do
1048 dflags <- getDynFlags
1049 liftIO $ finalSafeMode dflags tcg_env
1050
1051 --------------------------------------------------------------
1052 -- Simplifiers
1053 --------------------------------------------------------------
1054
1055 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1056 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1057
1058 hscSimplify' :: ModGuts -> Hsc ModGuts
1059 hscSimplify' ds_result = do
1060 hsc_env <- getHscEnv
1061 {-# SCC "Core2Core" #-}
1062 liftIO $ core2core hsc_env ds_result
1063
1064 --------------------------------------------------------------
1065 -- Interface generators
1066 --------------------------------------------------------------
1067
1068 hscSimpleIface :: HscEnv
1069 -> TcGblEnv
1070 -> Maybe Fingerprint
1071 -> IO (ModIface, Bool, ModDetails)
1072 hscSimpleIface hsc_env tc_result mb_old_iface
1073 = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
1074
1075 hscSimpleIface' :: TcGblEnv
1076 -> Maybe Fingerprint
1077 -> Hsc (ModIface, Bool, ModDetails)
1078 hscSimpleIface' tc_result mb_old_iface = do
1079 hsc_env <- getHscEnv
1080 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1081 safe_mode <- hscGetSafeMode tc_result
1082 (new_iface, no_change)
1083 <- {-# SCC "MkFinalIface" #-}
1084 ioMsgMaybe $
1085 mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
1086 -- And the answer is ...
1087 liftIO $ dumpIfaceStats hsc_env
1088 return (new_iface, no_change, details)
1089
1090 hscNormalIface :: HscEnv
1091 -> ModGuts
1092 -> Maybe Fingerprint
1093 -> IO (ModIface, Bool, ModDetails, CgGuts)
1094 hscNormalIface hsc_env simpl_result mb_old_iface =
1095 runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
1096
1097 hscNormalIface' :: ModGuts
1098 -> Maybe Fingerprint
1099 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1100 hscNormalIface' simpl_result mb_old_iface = do
1101 hsc_env <- getHscEnv
1102 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1103 liftIO $ tidyProgram hsc_env simpl_result
1104
1105 -- BUILD THE NEW ModIface and ModDetails
1106 -- and emit external core if necessary
1107 -- This has to happen *after* code gen so that the back-end
1108 -- info has been set. Not yet clear if it matters waiting
1109 -- until after code output
1110 (new_iface, no_change)
1111 <- {-# SCC "MkFinalIface" #-}
1112 ioMsgMaybe $
1113 mkIface hsc_env mb_old_iface details simpl_result
1114
1115 -- Emit external core
1116 -- This should definitely be here and not after CorePrep,
1117 -- because CorePrep produces unqualified constructor wrapper declarations,
1118 -- so its output isn't valid External Core (without some preprocessing).
1119 liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
1120 liftIO $ dumpIfaceStats hsc_env
1121
1122 -- Return the prepared code.
1123 return (new_iface, no_change, details, cg_guts)
1124
1125 --------------------------------------------------------------
1126 -- BackEnd combinators
1127 --------------------------------------------------------------
1128
1129 hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
1130 hscWriteIface dflags iface no_change mod_summary = do
1131 let ifaceFile = ml_hi_file (ms_location mod_summary)
1132 unless no_change $
1133 {-# SCC "writeIface" #-}
1134 writeIfaceFile dflags ifaceFile iface
1135 whenGeneratingDynamicToo dflags $ do
1136 -- TODO: We should do a no_change check for the dynamic
1137 -- interface file too
1138 let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
1139 dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
1140 dynDflags = doDynamicToo dflags
1141 writeIfaceFile dynDflags dynIfaceFile' iface
1142
1143 -- | Compile to hard-code.
1144 hscGenHardCode :: HscEnv -> CgGuts -> ModSummary
1145 -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1146 hscGenHardCode hsc_env cgguts mod_summary = do
1147 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1148 -- From now on, we just use the bits we need.
1149 cg_module = this_mod,
1150 cg_binds = core_binds,
1151 cg_tycons = tycons,
1152 cg_foreign = foreign_stubs0,
1153 cg_dep_pkgs = dependencies,
1154 cg_hpc_info = hpc_info } = cgguts
1155 dflags = hsc_dflags hsc_env
1156 location = ms_location mod_summary
1157 data_tycons = filter isDataTyCon tycons
1158 -- cg_tycons includes newtypes, for the benefit of External Core,
1159 -- but we don't generate any code for newtypes
1160
1161 -------------------
1162 -- PREPARE FOR CODE GENERATION
1163 -- Do saturation and convert to A-normal form
1164 prepd_binds <- {-# SCC "CorePrep" #-}
1165 corePrepPgm dflags hsc_env core_binds data_tycons ;
1166 ----------------- Convert to STG ------------------
1167 (stg_binds, cost_centre_info)
1168 <- {-# SCC "CoreToStg" #-}
1169 myCoreToStg dflags this_mod prepd_binds
1170
1171 let prof_init = profilingInitCode this_mod cost_centre_info
1172 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1173
1174 ------------------ Code generation ------------------
1175
1176 cmms <- {-# SCC "NewCodeGen" #-}
1177 tryNewCodeGen hsc_env this_mod data_tycons
1178 cost_centre_info
1179 stg_binds hpc_info
1180
1181 ------------------ Code output -----------------------
1182 rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
1183 cmmToRawCmm dflags cmms
1184
1185 let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
1186 (ppr a)
1187 return a
1188 rawcmms1 = Stream.mapM dump rawcmms0
1189
1190 (output_filename, (_stub_h_exists, stub_c_exists))
1191 <- {-# SCC "codeOutput" #-}
1192 codeOutput dflags this_mod location foreign_stubs
1193 dependencies rawcmms1
1194 return (output_filename, stub_c_exists)
1195
1196
1197 hscInteractive :: HscEnv
1198 -> CgGuts
1199 -> ModSummary
1200 -> IO (Maybe FilePath, CompiledByteCode, ModBreaks)
1201 #ifdef GHCI
1202 hscInteractive hsc_env cgguts mod_summary = do
1203 let dflags = hsc_dflags hsc_env
1204 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1205 -- From now on, we just use the bits we need.
1206 cg_module = this_mod,
1207 cg_binds = core_binds,
1208 cg_tycons = tycons,
1209 cg_foreign = foreign_stubs,
1210 cg_modBreaks = mod_breaks } = cgguts
1211
1212 location = ms_location mod_summary
1213 data_tycons = filter isDataTyCon tycons
1214 -- cg_tycons includes newtypes, for the benefit of External Core,
1215 -- but we don't generate any code for newtypes
1216
1217 -------------------
1218 -- PREPARE FOR CODE GENERATION
1219 -- Do saturation and convert to A-normal form
1220 prepd_binds <- {-# SCC "CorePrep" #-}
1221 corePrepPgm dflags hsc_env core_binds data_tycons
1222 ----------------- Generate byte code ------------------
1223 comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
1224 ------------------ Create f-x-dynamic C-side stuff ---
1225 (_istub_h_exists, istub_c_exists)
1226 <- outputForeignStubs dflags this_mod location foreign_stubs
1227 return (istub_c_exists, comp_bc, mod_breaks)
1228 #else
1229 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1230 #endif
1231
1232 ------------------------------
1233
1234 hscCompileCmmFile :: HscEnv -> FilePath -> IO ()
1235 hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
1236 let dflags = hsc_dflags hsc_env
1237 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1238 liftIO $ do
1239 us <- mkSplitUniqSupply 'S'
1240 let initTopSRT = initUs_ us emptySRT
1241 dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm)
1242 (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
1243 rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
1244 _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
1245 return ()
1246 where
1247 no_mod = panic "hscCmmFile: no_mod"
1248 no_loc = ModLocation{ ml_hs_file = Just filename,
1249 ml_hi_file = panic "hscCmmFile: no hi file",
1250 ml_obj_file = panic "hscCmmFile: no obj file" }
1251
1252 -------------------- Stuff for new code gen ---------------------
1253
1254 tryNewCodeGen :: HscEnv -> Module -> [TyCon]
1255 -> CollectedCCs
1256 -> [StgBinding]
1257 -> HpcInfo
1258 -> IO (Stream IO CmmGroup ())
1259 -- Note we produce a 'Stream' of CmmGroups, so that the
1260 -- backend can be run incrementally. Otherwise it generates all
1261 -- the C-- up front, which has a significant space cost.
1262 tryNewCodeGen hsc_env this_mod data_tycons
1263 cost_centre_info stg_binds hpc_info = do
1264 let dflags = hsc_dflags hsc_env
1265
1266 let cmm_stream :: Stream IO CmmGroup ()
1267 cmm_stream = {-# SCC "StgCmm" #-}
1268 StgCmm.codeGen dflags this_mod data_tycons
1269 cost_centre_info stg_binds hpc_info
1270
1271 -- codegen consumes a stream of CmmGroup, and produces a new
1272 -- stream of CmmGroup (not necessarily synchronised: one
1273 -- CmmGroup on input may produce many CmmGroups on output due
1274 -- to proc-point splitting).
1275
1276 let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
1277 "Cmm produced by new codegen" (ppr a)
1278 return a
1279
1280 ppr_stream1 = Stream.mapM dump1 cmm_stream
1281
1282 -- We are building a single SRT for the entire module, so
1283 -- we must thread it through all the procedures as we cps-convert them.
1284 us <- mkSplitUniqSupply 'S'
1285
1286 -- When splitting, we generate one SRT per split chunk, otherwise
1287 -- we generate one SRT for the whole module.
1288 let
1289 pipeline_stream
1290 | gopt Opt_SplitObjs dflags
1291 = {-# SCC "cmmPipeline" #-}
1292 let run_pipeline us cmmgroup = do
1293 let (topSRT', us') = initUs us emptySRT
1294 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
1295 let srt | isEmptySRT topSRT = []
1296 | otherwise = srtToData topSRT
1297 return (us', srt ++ cmmgroup)
1298
1299 in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
1300 return ()
1301
1302 | otherwise
1303 = {-# SCC "cmmPipeline" #-}
1304 let initTopSRT = initUs_ us emptySRT in
1305
1306 let run_pipeline topSRT cmmgroup = do
1307 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
1308 return (topSRT,cmmgroup)
1309
1310 in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
1311 Stream.yield (srtToData topSRT)
1312
1313 let
1314 dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a
1315 return a
1316
1317 ppr_stream2 = Stream.mapM dump2 pipeline_stream
1318
1319 return ppr_stream2
1320
1321
1322
1323 myCoreToStg :: DynFlags -> Module -> CoreProgram
1324 -> IO ( [StgBinding] -- output program
1325 , CollectedCCs) -- cost centre info (declared and used)
1326 myCoreToStg dflags this_mod prepd_binds = do
1327 stg_binds
1328 <- {-# SCC "Core2Stg" #-}
1329 coreToStg dflags prepd_binds
1330
1331 (stg_binds2, cost_centre_info)
1332 <- {-# SCC "Stg2Stg" #-}
1333 stg2stg dflags this_mod stg_binds
1334
1335 return (stg_binds2, cost_centre_info)
1336
1337
1338 {- **********************************************************************
1339 %* *
1340 \subsection{Compiling a do-statement}
1341 %* *
1342 %********************************************************************* -}
1343
1344 {-
1345 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1346 you run it you get a list of HValues that should be the same length as the list
1347 of names; add them to the ClosureEnv.
1348
1349 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1350 IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver
1351 -}
1352
1353 #ifdef GHCI
1354 -- | Compile a stmt all the way to an HValue, but don't run it
1355 --
1356 -- We return Nothing to indicate an empty statement (or comment only), not a
1357 -- parse error.
1358 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1359 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1360
1361 -- | Compile a stmt all the way to an HValue, but don't run it
1362 --
1363 -- We return Nothing to indicate an empty statement (or comment only), not a
1364 -- parse error.
1365 hscStmtWithLocation :: HscEnv
1366 -> String -- ^ The statement
1367 -> String -- ^ The source
1368 -> Int -- ^ Starting line
1369 -> IO (Maybe ([Id], IO [HValue], FixityEnv))
1370 hscStmtWithLocation hsc_env0 stmt source linenumber =
1371 runInteractiveHsc hsc_env0 $ do
1372 hsc_env <- getHscEnv
1373 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1374 case maybe_stmt of
1375 Nothing -> return Nothing
1376
1377 Just parsed_stmt -> do
1378 let icntxt = hsc_IC hsc_env
1379 rdr_env = ic_rn_gbl_env icntxt
1380 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
1381 src_span = srcLocSpan interactiveSrcLoc
1382
1383 -- Rename and typecheck it
1384 -- Here we lift the stmt into the IO monad, see Note
1385 -- [Interactively-bound Ids in GHCi] in TcRnDriver
1386 (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
1387
1388 -- Desugar it
1389 ds_expr <- ioMsgMaybe $
1390 deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1391 handleWarnings
1392
1393 -- Then code-gen, and link it
1394 hsc_env <- getHscEnv
1395 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1396 let hval_io = unsafeCoerce# hval :: IO [HValue]
1397
1398 return $ Just (ids, hval_io, fix_env)
1399
1400 -- | Compile a decls
1401 hscDecls :: HscEnv
1402 -> String -- ^ The statement
1403 -> IO ([TyThing], InteractiveContext)
1404 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1405
1406 -- | Compile a decls
1407 hscDeclsWithLocation :: HscEnv
1408 -> String -- ^ The statement
1409 -> String -- ^ The source
1410 -> Int -- ^ Starting line
1411 -> IO ([TyThing], InteractiveContext)
1412 hscDeclsWithLocation hsc_env0 str source linenumber =
1413 runInteractiveHsc hsc_env0 $ do
1414 hsc_env <- getHscEnv
1415 L _ (HsModule{ hsmodDecls = decls }) <-
1416 hscParseThingWithLocation source linenumber parseModule str
1417
1418 {- Rename and typecheck it -}
1419 let icontext = hsc_IC hsc_env
1420 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env icontext decls
1421
1422 {- Grab the new instances -}
1423 -- We grab the whole environment because of the overlapping that may have
1424 -- been done. See the notes at the definition of InteractiveContext
1425 -- (ic_instances) for more details.
1426 let finsts = tcg_fam_insts tc_gblenv
1427 insts = tcg_insts tc_gblenv
1428
1429 let defaults = tcg_default tc_gblenv
1430
1431 {- Desugar it -}
1432 -- We use a basically null location for iNTERACTIVE
1433 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1434 ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
1435 ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
1436 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1437
1438 {- Simplify -}
1439 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1440
1441 {- Tidy -}
1442 (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1443
1444 let dflags = hsc_dflags hsc_env
1445 !CgGuts{ cg_module = this_mod,
1446 cg_binds = core_binds,
1447 cg_tycons = tycons,
1448 cg_modBreaks = mod_breaks } = tidy_cg
1449 data_tycons = filter isDataTyCon tycons
1450
1451 {- Prepare For Code Generation -}
1452 -- Do saturation and convert to A-normal form
1453 prepd_binds <- {-# SCC "CorePrep" #-}
1454 liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons
1455
1456 {- Generate byte code -}
1457 cbc <- liftIO $ byteCodeGen dflags this_mod
1458 prepd_binds data_tycons mod_breaks
1459
1460 let src_span = srcLocSpan interactiveSrcLoc
1461 hsc_env <- getHscEnv
1462 liftIO $ linkDecls hsc_env src_span cbc
1463
1464 let tcs = filter (not . isImplicitTyCon) $ (mg_tcs simpl_mg)
1465
1466 ext_vars = filter (isExternalName . idName) $
1467 bindersOfBinds core_binds
1468
1469 (sys_vars, user_vars) = partition is_sys_var ext_vars
1470 is_sys_var id = isDFunId id
1471 || isRecordSelector id
1472 || isJust (isClassOpId_maybe id)
1473 -- we only need to keep around the external bindings
1474 -- (as decided by TidyPgm), since those are the only ones
1475 -- that might be referenced elsewhere.
1476
1477 tythings = map AnId user_vars
1478 ++ map ATyCon tcs
1479
1480 let ictxt1 = extendInteractiveContext icontext tythings
1481 ictxt = ictxt1 { ic_sys_vars = sys_vars ++ ic_sys_vars ictxt1,
1482 ic_instances = (insts, finsts),
1483 ic_default = defaults }
1484
1485 return (tythings, ictxt)
1486
1487 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1488 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1489 (L _ (HsModule{hsmodImports=is})) <-
1490 hscParseThing parseModule str
1491 case is of
1492 [i] -> return (unLoc i)
1493 _ -> liftIO $ throwOneError $
1494 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
1495 ptext (sLit "parse error in import declaration")
1496
1497 -- | Typecheck an expression (but don't run it)
1498 -- Returns its most general type
1499 hscTcExpr :: HscEnv
1500 -> String -- ^ The expression
1501 -> IO Type
1502 hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
1503 hsc_env <- getHscEnv
1504 maybe_stmt <- hscParseStmt expr
1505 case maybe_stmt of
1506 Just (L _ (BodyStmt expr _ _ _)) ->
1507 ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
1508 _ ->
1509 throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
1510 (text "not an expression:" <+> quotes (text expr))
1511
1512 -- | Find the kind of a type
1513 -- Currently this does *not* generalise the kinds of the type
1514 hscKcType
1515 :: HscEnv
1516 -> Bool -- ^ Normalise the type
1517 -> String -- ^ The type as a string
1518 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1519 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1520 hsc_env <- getHscEnv
1521 ty <- hscParseType str
1522 ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty
1523
1524 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName))
1525 hscParseStmt = hscParseThing parseStmt
1526
1527 hscParseStmtWithLocation :: String -> Int -> String
1528 -> Hsc (Maybe (GhciLStmt RdrName))
1529 hscParseStmtWithLocation source linenumber stmt =
1530 hscParseThingWithLocation source linenumber parseStmt stmt
1531
1532 hscParseType :: String -> Hsc (LHsType RdrName)
1533 hscParseType = hscParseThing parseType
1534 #endif
1535
1536 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1537 hscParseIdentifier hsc_env str =
1538 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1539
1540 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1541 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1542
1543 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1544 -> Lexer.P thing -> String -> Hsc thing
1545 hscParseThingWithLocation source linenumber parser str
1546 = {-# SCC "Parser" #-} do
1547 dflags <- getDynFlags
1548 liftIO $ showPass dflags "Parser"
1549
1550 let buf = stringToStringBuffer str
1551 loc = mkRealSrcLoc (fsLit source) linenumber 1
1552
1553 case unP parser (mkPState dflags buf loc) of
1554 PFailed span err -> do
1555 let msg = mkPlainErrMsg dflags span err
1556 throwErrors $ unitBag msg
1557
1558 POk pst thing -> do
1559 logWarningsReportErrors (getMessages pst)
1560 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1561 return thing
1562
1563 hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
1564 -> CoreProgram -> IO ()
1565 hscCompileCore hsc_env simplify safe_mode mod_summary binds
1566 = runHsc hsc_env $ do
1567 guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
1568 (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing
1569 liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary
1570 _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary
1571 return ()
1572
1573 where
1574 maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1575 | otherwise = return mod_guts
1576
1577 -- Makes a "vanilla" ModGuts.
1578 mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts
1579 mkModGuts mod safe binds =
1580 ModGuts {
1581 mg_module = mod,
1582 mg_boot = False,
1583 mg_exports = [],
1584 mg_deps = noDependencies,
1585 mg_dir_imps = emptyModuleEnv,
1586 mg_used_names = emptyNameSet,
1587 mg_used_th = False,
1588 mg_rdr_env = emptyGlobalRdrEnv,
1589 mg_fix_env = emptyFixityEnv,
1590 mg_tcs = [],
1591 mg_insts = [],
1592 mg_fam_insts = [],
1593 mg_rules = [],
1594 mg_vect_decls = [],
1595 mg_binds = binds,
1596 mg_foreign = NoStubs,
1597 mg_warns = NoWarnings,
1598 mg_anns = [],
1599 mg_hpc_info = emptyHpcInfo False,
1600 mg_modBreaks = emptyModBreaks,
1601 mg_vect_info = noVectInfo,
1602 mg_inst_env = emptyInstEnv,
1603 mg_fam_inst_env = emptyFamInstEnv,
1604 mg_safe_haskell = safe,
1605 mg_trust_pkg = False,
1606 mg_dependent_files = []
1607 }
1608
1609
1610 {- **********************************************************************
1611 %* *
1612 Desugar, simplify, convert to bytecode, and link an expression
1613 %* *
1614 %********************************************************************* -}
1615
1616 #ifdef GHCI
1617 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1618 hscCompileCoreExpr hsc_env srcspan ds_expr
1619 | rtsIsProfiled
1620 = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1621 -- Otherwise you get a seg-fault when you run it
1622
1623 | otherwise = do
1624 let dflags = hsc_dflags hsc_env
1625 let lint_on = gopt Opt_DoCoreLinting dflags
1626
1627 {- Simplify it -}
1628 simpl_expr <- simplifyExpr dflags ds_expr
1629
1630 {- Tidy it (temporary, until coreSat does cloning) -}
1631 let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1632
1633 {- Prepare for codegen -}
1634 prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
1635
1636 {- Lint if necessary -}
1637 -- ToDo: improve SrcLoc
1638 when lint_on $
1639 let ictxt = hsc_IC hsc_env
1640 te = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
1641 tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
1642 vars = typeEnvIds te
1643 in case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of
1644 Just err -> pprPanic "hscCompileCoreExpr" err
1645 Nothing -> return ()
1646
1647 {- Convert to BCOs -}
1648 bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr
1649
1650 {- link it -}
1651 hval <- linkExpr hsc_env srcspan bcos
1652
1653 return hval
1654 #endif
1655
1656
1657 {- **********************************************************************
1658 %* *
1659 Statistics on reading interfaces
1660 %* *
1661 %********************************************************************* -}
1662
1663 dumpIfaceStats :: HscEnv -> IO ()
1664 dumpIfaceStats hsc_env = do
1665 eps <- readIORef (hsc_EPS hsc_env)
1666 dumpIfSet dflags (dump_if_trace || dump_rn_stats)
1667 "Interface statistics"
1668 (ifaceStats eps)
1669 where
1670 dflags = hsc_dflags hsc_env
1671 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1672 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1673
1674
1675 {- **********************************************************************
1676 %* *
1677 Progress Messages: Module i of n
1678 %* *
1679 %********************************************************************* -}
1680
1681 showModuleIndex :: (Int, Int) -> String
1682 showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1683 where
1684 n_str = show n
1685 i_str = show i
1686 padded = replicate (length n_str - length i_str) ' ' ++ i_str
1687