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