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