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