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