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