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