Make mkPState and pragState take their arguments in the same order
[ghc.git] / compiler / main / HscMain.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
3 %
4 \begin{code}
5 -- | Main driver for the compiling plain Haskell source code.
6 --
7 -- This module implements compilation of a Haskell-only source file.  It is
8 -- /not/ concerned with preprocessing of source files; this is handled in
9 -- "DriverPipeline".
10 --
11 module HscMain
12     ( newHscEnv, hscCmmFile
13     , hscParseIdentifier
14     , hscSimplify
15     , hscNormalIface, hscWriteIface, hscGenHardCode
16 #ifdef GHCI
17     , hscStmt, hscTcExpr, hscImport, hscKcType
18     , compileExpr
19 #endif
20     , HsCompiler(..)
21     , hscOneShotCompiler, hscNothingCompiler
22     , hscInteractiveCompiler, hscBatchCompiler
23     , hscCompileOneShot     -- :: Compiler HscStatus
24     , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
25     , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
26     , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
27     , hscCheckRecompBackend
28     , HscStatus' (..)
29     , InteractiveStatus, HscStatus
30
31     -- The new interface
32     , hscParse
33     , hscTypecheck
34     , hscTypecheckRename
35     , hscDesugar
36     , makeSimpleIface
37     , makeSimpleDetails
38     ) where
39
40 #ifdef GHCI
41 import CodeOutput       ( outputForeignStubs )
42 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
43 import Linker           ( HValue, linkExpr )
44 import CoreTidy         ( tidyExpr )
45 import CorePrep         ( corePrepExpr )
46 import Desugar          ( deSugarExpr )
47 import SimplCore        ( simplifyExpr )
48 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnType ) 
49 import Type             ( Type )
50 import PrelNames        ( iNTERACTIVE )
51 import {- Kind parts of -} Type         ( Kind )
52 import CoreLint         ( lintUnfolding )
53 import DsMeta           ( templateHaskellNames )
54 import SrcLoc           ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
55 import VarSet
56 import VarEnv           ( emptyTidyEnv )
57 #endif
58
59 import Id               ( Id )
60 import Module           ( emptyModuleEnv, ModLocation(..), Module )
61 import RdrName
62 import HsSyn
63 import CoreSyn
64 import SrcLoc           ( Located(..) )
65 import StringBuffer
66 import Parser
67 import Lexer
68 import SrcLoc           ( mkSrcLoc )
69 import TcRnDriver       ( tcRnModule )
70 import TcIface          ( typecheckIface )
71 import TcRnMonad        ( initIfaceCheck, TcGblEnv(..) )
72 import IfaceEnv         ( initNameCache )
73 import LoadIface        ( ifaceStats, initExternalPackageState )
74 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
75 import MkIface
76 import Desugar          ( deSugar )
77 import SimplCore        ( core2core )
78 import TidyPgm
79 import CorePrep         ( corePrepPgm )
80 import CoreToStg        ( coreToStg )
81 import qualified StgCmm ( codeGen )
82 import StgSyn
83 import CostCentre
84 import TyCon            ( TyCon, isDataTyCon )
85 import Name             ( Name, NamedThing(..) )
86 import SimplStg         ( stg2stg )
87 import CodeGen          ( codeGen )
88 import Cmm              ( Cmm )
89 import PprCmm           ( pprCmms )
90 import CmmParse         ( parseCmmFile )
91 import CmmBuildInfoTables
92 import CmmCPS
93 import CmmCPSZ
94 import CmmInfo
95 import OptimizationFuel ( initOptFuelState )
96 import CmmCvt
97 import CmmTx
98 import CmmContFlowOpt
99 import CodeOutput       ( codeOutput )
100 import NameEnv          ( emptyNameEnv )
101 import Fingerprint      ( Fingerprint )
102
103 import DynFlags
104 import ErrUtils
105 import UniqSupply       ( mkSplitUniqSupply )
106
107 import Outputable
108 import HscStats         ( ppSourceStats )
109 import HscTypes
110 import MkExternalCore   ( emitExternalCore )
111 import FastString
112 import UniqFM           ( emptyUFM )
113 import UniqSupply       ( initUs_ )
114 import Bag              ( unitBag )
115 import Exception
116 -- import MonadUtils
117
118 import Control.Monad
119 -- import System.IO
120 import Data.IORef
121 \end{code}
122 #include "HsVersions.h"
123
124
125 %************************************************************************
126 %*                                                                      *
127                 Initialisation
128 %*                                                                      *
129 %************************************************************************
130
131 \begin{code}
132 newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv
133 newHscEnv callbacks dflags
134   = do  { eps_var <- newIORef initExternalPackageState
135         ; us      <- mkSplitUniqSupply 'r'
136         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
137         ; fc_var  <- newIORef emptyUFM
138         ; mlc_var <- newIORef emptyModuleEnv
139         ; optFuel <- initOptFuelState
140         ; return (HscEnv { hsc_dflags = dflags,
141                            hsc_callbacks = callbacks,
142                            hsc_targets = [],
143                            hsc_mod_graph = [],
144                            hsc_IC      = emptyInteractiveContext,
145                            hsc_HPT     = emptyHomePackageTable,
146                            hsc_EPS     = eps_var,
147                            hsc_NC      = nc_var,
148                            hsc_FC      = fc_var,
149                            hsc_MLC     = mlc_var,
150                            hsc_OptFuel = optFuel,
151                            hsc_type_env_var = Nothing,
152                            hsc_global_rdr_env = emptyGlobalRdrEnv,
153                            hsc_global_type_env = emptyNameEnv } ) }
154
155
156 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
157                         -- where templateHaskellNames are defined
158 knownKeyNames = map getName wiredInThings 
159               ++ basicKnownKeyNames
160 #ifdef GHCI
161               ++ templateHaskellNames
162 #endif
163 \end{code}
164
165
166 \begin{code}
167 -- | parse a file, returning the abstract syntax
168 hscParse :: GhcMonad m =>
169             ModSummary
170          -> m (Located (HsModule RdrName))
171 hscParse mod_summary = do
172    hsc_env <- getSession
173    let dflags        = hsc_dflags hsc_env
174        src_filename  = ms_hspp_file mod_summary
175        maybe_src_buf = ms_hspp_buf  mod_summary
176    --------------------------  Parser  ----------------
177    liftIO $ showPass dflags "Parser"
178    {-# SCC "Parser" #-} do
179
180         -- sometimes we already have the buffer in memory, perhaps
181         -- because we needed to parse the imports out of it, or get the
182         -- module name.
183    buf <- case maybe_src_buf of
184             Just b  -> return b
185             Nothing -> liftIO $ hGetStringBuffer src_filename
186
187    let loc  = mkSrcLoc (mkFastString src_filename) 1 1
188
189    case unP parseModule (mkPState dflags buf loc) of
190      PFailed span err ->
191          throwOneError (mkPlainErrMsg span err)
192
193      POk pst rdr_module -> do
194          let ms@(warns,errs) = getMessages pst
195          logWarnings warns
196          if errorsFound dflags ms then
197            liftIO $ throwIO $ mkSrcErr errs
198           else liftIO $ do
199            dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
200            dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
201                                (ppSourceStats False rdr_module) ;
202            return rdr_module
203           -- ToDo: free the string buffer later.
204
205 -- | Rename and typecheck a module
206 hscTypecheck :: GhcMonad m =>
207                 ModSummary -> Located (HsModule RdrName)
208              -> m TcGblEnv
209 hscTypecheck mod_summary rdr_module = do
210       hsc_env <- getSession
211       r <- {-# SCC "Typecheck-Rename" #-}
212            ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
213       return r
214
215 -- XXX: should this really be a Maybe X?  Check under which circumstances this
216 -- can become a Nothing and decide whether this should instead throw an
217 -- exception/signal an error.
218 type RenamedStuff = 
219         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
220                 Maybe LHsDocString))
221
222 -- | Rename and typecheck a module, additionally returning the renamed syntax
223 hscTypecheckRename ::
224        GhcMonad m =>
225        ModSummary -> Located (HsModule RdrName)
226     -> m (TcGblEnv, RenamedStuff)
227 hscTypecheckRename mod_summary rdr_module = do
228     hsc_env <- getSession
229     tc_result
230           <- {-# SCC "Typecheck-Rename" #-}
231              ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
232
233     let -- This 'do' is in the Maybe monad!
234         rn_info = do { decl <- tcg_rn_decls tc_result
235                      ; let imports = tcg_rn_imports tc_result
236                            exports = tcg_rn_exports tc_result
237                            doc_hdr  = tcg_doc_hdr tc_result
238                      ; return (decl,imports,exports,doc_hdr) }
239
240     return (tc_result, rn_info)
241
242 -- | Convert a typechecked module to Core
243 hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts
244 hscDesugar mod_summary tc_result =
245   withSession $ \hsc_env ->
246     ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result
247
248 -- | Make a 'ModIface' from the results of typechecking.  Used when
249 -- not optimising, and the interface doesn't need to contain any
250 -- unfoldings or other cross-module optimisation info.
251 -- ToDo: the old interface is only needed to get the version numbers,
252 -- we should use fingerprint versions instead.
253 makeSimpleIface :: GhcMonad m =>
254                    Maybe ModIface -> TcGblEnv -> ModDetails
255                 -> m (ModIface,Bool)
256 makeSimpleIface maybe_old_iface tc_result details =
257   withSession $ \hsc_env ->
258   ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
259
260 -- | Make a 'ModDetails' from the results of typechecking.  Used when
261 -- typechecking only, as opposed to full compilation.
262 makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails
263 makeSimpleDetails tc_result =
264     withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result
265 \end{code}
266
267 %************************************************************************
268 %*                                                                      *
269                 The main compiler pipeline
270 %*                                                                      *
271 %************************************************************************
272
273                    --------------------------------
274                         The compilation proper
275                    --------------------------------
276
277
278 It's the task of the compilation proper to compile Haskell, hs-boot and
279 core files to either byte-code, hard-code (C, asm, Java, ect) or to
280 nothing at all (the module is still parsed and type-checked. This
281 feature is mostly used by IDE's and the likes).
282 Compilation can happen in either 'one-shot', 'batch', 'nothing',
283 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
284 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
285 targets byte-code.
286 The modes are kept separate because of their different types and meanings.
287 In 'one-shot' mode, we're only compiling a single file and can therefore
288 discard the new ModIface and ModDetails. This is also the reason it only
289 targets hard-code; compiling to byte-code or nothing doesn't make sense
290 when we discard the result.
291 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
292 and ModDetails. 'Batch' mode doesn't target byte-code since that require
293 us to return the newly compiled byte-code.
294 'Nothing' mode has exactly the same type as 'batch' mode but they're still
295 kept separate. This is because compiling to nothing is fairly special: We
296 don't output any interface files, we don't run the simplifier and we don't
297 generate any code.
298 'Interactive' mode is similar to 'batch' mode except that we return the
299 compiled byte-code together with the ModIface and ModDetails.
300
301 Trying to compile a hs-boot file to byte-code will result in a run-time
302 error. This is the only thing that isn't caught by the type-system.
303
304 \begin{code}
305
306 -- Status of a compilation to hard-code or nothing.
307 data HscStatus' a
308     = HscNoRecomp
309     | HscRecomp
310        Bool -- Has stub files.  This is a hack. We can't compile C files here
311             -- since it's done in DriverPipeline. For now we just return True
312             -- if we want the caller to compile them for us.
313        a
314
315 -- This is a bit ugly.  Since we use a typeclass below and would like to avoid
316 -- functional dependencies, we have to parameterise the typeclass over the
317 -- result type.  Therefore we need to artificially distinguish some types.  We
318 -- do this by adding type tags which will simply be ignored by the caller.
319 type HscStatus         = HscStatus' ()
320 type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
321     -- INVARIANT: result is @Nothing@ <=> input was a boot file
322
323 type OneShotResult     = HscStatus
324 type BatchResult       = (HscStatus, ModIface, ModDetails)
325 type NothingResult     = (HscStatus, ModIface, ModDetails)
326 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
327
328 -- FIXME: The old interface and module index are only using in 'batch' and
329 --        'interactive' mode. They should be removed from 'oneshot' mode.
330 type Compiler result =  GhcMonad m =>
331                         HscEnv
332                      -> ModSummary
333                      -> Bool                -- True <=> source unchanged
334                      -> Maybe ModIface      -- Old interface, if available
335                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
336                      -> m result
337
338 data HsCompiler a
339   = HsCompiler {
340     -- | Called when no recompilation is necessary.
341     hscNoRecomp :: GhcMonad m =>
342                    ModIface -> m a,
343
344     -- | Called to recompile the module.
345     hscRecompile :: GhcMonad m =>
346                     ModSummary -> Maybe Fingerprint -> m a,
347
348     hscBackend :: GhcMonad m =>
349                   TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
350
351     -- | Code generation for Boot modules.
352     hscGenBootOutput :: GhcMonad m =>
353                         TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
354
355     -- | Code generation for normal modules.
356     hscGenOutput :: GhcMonad m =>
357                     ModGuts  -> ModSummary -> Maybe Fingerprint -> m a
358   }
359
360 genericHscCompile :: GhcMonad m =>
361                      HsCompiler a
362                   -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
363                   -> HscEnv -> ModSummary -> Bool
364                   -> Maybe ModIface -> Maybe (Int, Int)
365                   -> m a
366 genericHscCompile compiler hscMessage
367                   hsc_env mod_summary source_unchanged
368                   mb_old_iface0 mb_mod_index =
369    withTempSession (\_ -> hsc_env) $ do
370      (recomp_reqd, mb_checked_iface)
371          <- {-# SCC "checkOldIface" #-}
372             liftIO $ checkOldIface hsc_env mod_summary
373                                    source_unchanged mb_old_iface0
374      -- save the interface that comes back from checkOldIface.
375      -- In one-shot mode we don't have the old iface until this
376      -- point, when checkOldIface reads it from the disk.
377      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
378      case mb_checked_iface of
379        Just iface | not recomp_reqd
380            -> do hscMessage mb_mod_index False mod_summary
381                  hscNoRecomp compiler iface
382        _otherwise
383            -> do hscMessage mb_mod_index True mod_summary
384                  hscRecompile compiler mod_summary mb_old_hash
385
386 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
387 hscCheckRecompBackend compiler tc_result 
388                    hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
389    withTempSession (\_ -> hsc_env) $ do
390      (recomp_reqd, mb_checked_iface)
391          <- {-# SCC "checkOldIface" #-}
392             liftIO $ checkOldIface hsc_env mod_summary
393                                    source_unchanged mb_old_iface
394
395      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
396      case mb_checked_iface of
397        Just iface | not recomp_reqd
398            -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
399        _otherwise
400            -> hscBackend compiler tc_result mod_summary mb_old_hash
401
402 genericHscRecompile :: GhcMonad m =>
403                        HsCompiler a
404                     -> ModSummary -> Maybe Fingerprint
405                     -> m a
406 genericHscRecompile compiler mod_summary mb_old_hash
407   | ExtCoreFile <- ms_hsc_src mod_summary =
408       panic "GHC does not currently support reading External Core files"
409   | otherwise = do
410       tc_result <- hscFileFrontEnd mod_summary
411       hscBackend compiler tc_result mod_summary mb_old_hash
412
413 genericHscBackend :: GhcMonad m =>
414                      HsCompiler a
415                   -> TcGblEnv -> ModSummary -> Maybe Fingerprint
416                   -> m a
417 genericHscBackend compiler tc_result mod_summary mb_old_hash
418   | HsBootFile <- ms_hsc_src mod_summary =
419       hscGenBootOutput compiler tc_result mod_summary mb_old_hash
420   | otherwise = do
421       guts <- hscDesugar mod_summary tc_result
422       hscGenOutput compiler guts mod_summary mb_old_hash
423
424 --------------------------------------------------------------
425 -- Compilers
426 --------------------------------------------------------------
427
428 hscOneShotCompiler :: HsCompiler OneShotResult
429 hscOneShotCompiler =
430   HsCompiler {
431
432     hscNoRecomp = \_old_iface -> do
433       withSession (liftIO . dumpIfaceStats)
434       return HscNoRecomp
435
436   , hscRecompile = genericHscRecompile hscOneShotCompiler
437
438   , hscBackend = \ tc_result mod_summary mb_old_hash -> do
439        hsc_env <- getSession
440        case hscTarget (hsc_dflags hsc_env) of
441          HscNothing -> return (HscRecomp False ())
442          _otherw    -> genericHscBackend hscOneShotCompiler 
443                                          tc_result mod_summary mb_old_hash
444
445   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
446        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
447        hscWriteIface iface changed mod_summary
448        return (HscRecomp False ())
449
450   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
451        guts <- hscSimplify guts0
452        (iface, changed, _details, cgguts)
453            <- hscNormalIface guts mb_old_iface
454        hscWriteIface iface changed mod_summary
455        hasStub <- hscGenHardCode cgguts mod_summary
456        return (HscRecomp hasStub ())
457   }
458
459 -- Compile Haskell, boot and extCore in OneShot mode.
460 hscCompileOneShot :: Compiler OneShotResult
461 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
462        -- One-shot mode needs a knot-tying mutable variable for interface
463        -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
464       type_env_var <- liftIO $ newIORef emptyNameEnv
465       let
466          mod = ms_mod mod_summary
467          hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
468       ---
469       genericHscCompile hscOneShotCompiler
470                         oneShotMsg hsc_env' mod_summary src_changed
471                         mb_old_iface mb_i_of_n
472
473
474 --------------------------------------------------------------
475
476 hscBatchCompiler :: HsCompiler BatchResult
477 hscBatchCompiler =
478   HsCompiler {
479
480     hscNoRecomp = \iface -> do
481        details <- genModDetails iface
482        return (HscNoRecomp, iface, details)
483
484   , hscRecompile = genericHscRecompile hscBatchCompiler
485
486   , hscBackend = genericHscBackend hscBatchCompiler
487
488   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
489        (iface, changed, details)
490            <- hscSimpleIface tc_result mb_old_iface
491        hscWriteIface iface changed mod_summary
492        return (HscRecomp False (), iface, details)
493
494   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
495        guts <- hscSimplify guts0
496        (iface, changed, details, cgguts)
497            <- hscNormalIface guts mb_old_iface
498        hscWriteIface iface changed mod_summary
499        hasStub <- hscGenHardCode cgguts mod_summary
500        return (HscRecomp hasStub (), iface, details)
501   }
502
503 -- Compile Haskell, boot and extCore in batch mode.
504 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
505 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
506
507 --------------------------------------------------------------
508
509 hscInteractiveCompiler :: HsCompiler InteractiveResult
510 hscInteractiveCompiler =
511   HsCompiler {
512     hscNoRecomp = \iface -> do
513        details <- genModDetails iface
514        return (HscNoRecomp, iface, details)
515
516   , hscRecompile = genericHscRecompile hscInteractiveCompiler
517
518   , hscBackend = genericHscBackend hscInteractiveCompiler
519
520   , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
521        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
522        return (HscRecomp False Nothing, iface, details)
523
524   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
525        guts <- hscSimplify guts0
526        (iface, _changed, details, cgguts)
527            <- hscNormalIface guts mb_old_iface
528        hscInteractive (iface, details, cgguts) mod_summary
529   }
530
531 -- Compile Haskell, extCore to bytecode.
532 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
533 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
534
535 --------------------------------------------------------------
536
537 hscNothingCompiler :: HsCompiler NothingResult
538 hscNothingCompiler =
539   HsCompiler {
540     hscNoRecomp = \iface -> do
541        details <- genModDetails iface
542        return (HscNoRecomp, iface, details)
543
544   , hscRecompile = genericHscRecompile hscNothingCompiler
545
546   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
547        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
548        return (HscRecomp False (), iface, details)
549
550   , hscGenBootOutput = \_ _ _ ->
551         panic "hscCompileNothing: hscGenBootOutput should not be called"
552
553   , hscGenOutput = \_ _ _ ->
554         panic "hscCompileNothing: hscGenOutput should not be called"
555   }
556
557 -- Type-check Haskell and .hs-boot only (no external core)
558 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
559 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
560
561 --------------------------------------------------------------
562 -- NoRecomp handlers
563 --------------------------------------------------------------
564
565 genModDetails :: GhcMonad m => ModIface -> m ModDetails
566 genModDetails old_iface =
567     withSession $ \hsc_env -> liftIO $ do
568       new_details <- {-# SCC "tcRnIface" #-}
569                      initIfaceCheck hsc_env $
570                      typecheckIface old_iface
571       dumpIfaceStats hsc_env
572       return new_details
573
574 --------------------------------------------------------------
575 -- Progress displayers.
576 --------------------------------------------------------------
577
578 oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
579 oneShotMsg _mb_mod_index recomp _mod_summary
580     = do hsc_env <- getSession
581          liftIO $ do
582          if recomp
583             then return ()
584             else compilationProgressMsg (hsc_dflags hsc_env) $
585                      "compilation IS NOT required"
586
587 batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
588 batchMsg mb_mod_index recomp mod_summary
589     = do hsc_env <- getSession
590          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
591                            (showModuleIndex mb_mod_index ++
592                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
593          liftIO $ do
594          if recomp
595             then showMsg "Compiling "
596             else if verbosity (hsc_dflags hsc_env) >= 2
597                     then showMsg "Skipping  "
598                     else return ()
599
600 --------------------------------------------------------------
601 -- FrontEnds
602 --------------------------------------------------------------
603 hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv
604 hscFileFrontEnd mod_summary =
605     do rdr_module <- hscParse mod_summary
606        hscTypecheck mod_summary rdr_module
607
608 --------------------------------------------------------------
609 -- Simplifiers
610 --------------------------------------------------------------
611
612 hscSimplify :: GhcMonad m => ModGuts -> m ModGuts
613 hscSimplify ds_result
614   = do hsc_env <- getSession
615        simpl_result <- {-# SCC "Core2Core" #-}
616                        liftIO $ core2core hsc_env ds_result
617        return simpl_result
618
619 --------------------------------------------------------------
620 -- Interface generators
621 --------------------------------------------------------------
622
623 hscSimpleIface :: GhcMonad m =>
624                   TcGblEnv
625                -> Maybe Fingerprint
626                -> m (ModIface, Bool, ModDetails)
627 hscSimpleIface tc_result mb_old_iface
628   = do hsc_env <- getSession
629        details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
630        (new_iface, no_change)
631            <- {-# SCC "MkFinalIface" #-}
632               ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result
633        -- And the answer is ...
634        liftIO $ dumpIfaceStats hsc_env
635        return (new_iface, no_change, details)
636
637 hscNormalIface :: GhcMonad m =>
638                   ModGuts
639                -> Maybe Fingerprint
640                -> m (ModIface, Bool, ModDetails, CgGuts)
641 hscNormalIface simpl_result mb_old_iface
642   = do hsc_env <- getSession
643
644        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
645                              liftIO $ tidyProgram hsc_env simpl_result
646
647             -- BUILD THE NEW ModIface and ModDetails
648             --  and emit external core if necessary
649             -- This has to happen *after* code gen so that the back-end
650             -- info has been set.  Not yet clear if it matters waiting
651             -- until after code output
652        (new_iface, no_change)
653            <- {-# SCC "MkFinalIface" #-}
654               ioMsgMaybe $ mkIface hsc_env mb_old_iface
655                                    details simpl_result
656         -- Emit external core
657        -- This should definitely be here and not after CorePrep,
658        -- because CorePrep produces unqualified constructor wrapper declarations,
659        -- so its output isn't valid External Core (without some preprocessing).
660        liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
661        liftIO $ dumpIfaceStats hsc_env
662
663             -- Return the prepared code.
664        return (new_iface, no_change, details, cg_guts)
665
666 --------------------------------------------------------------
667 -- BackEnd combinators
668 --------------------------------------------------------------
669
670 hscWriteIface :: GhcMonad m =>
671                  ModIface -> Bool
672               -> ModSummary
673               -> m ()
674 hscWriteIface iface no_change mod_summary
675     = do hsc_env <- getSession
676          let dflags = hsc_dflags hsc_env
677          liftIO $ do
678          unless no_change
679            $ writeIfaceFile dflags (ms_location mod_summary) iface
680
681 -- | Compile to hard-code.
682 hscGenHardCode :: GhcMonad m =>
683                   CgGuts -> ModSummary
684                -> m Bool -- ^ @True@ <=> stub.c exists
685 hscGenHardCode cgguts mod_summary
686     = withSession $ \hsc_env -> liftIO $ do
687          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
688                      -- From now on, we just use the bits we need.
689                      cg_module   = this_mod,
690                      cg_binds    = core_binds,
691                      cg_tycons   = tycons,
692                      cg_dir_imps = dir_imps,
693                      cg_foreign  = foreign_stubs,
694                      cg_dep_pkgs = dependencies,
695                      cg_hpc_info = hpc_info } = cgguts
696              dflags = hsc_dflags hsc_env
697              location = ms_location mod_summary
698              data_tycons = filter isDataTyCon tycons
699              -- cg_tycons includes newtypes, for the benefit of External Core,
700              -- but we don't generate any code for newtypes
701
702          -------------------
703          -- PREPARE FOR CODE GENERATION
704          -- Do saturation and convert to A-normal form
705          prepd_binds <- {-# SCC "CorePrep" #-}
706                         corePrepPgm dflags core_binds data_tycons ;
707          -----------------  Convert to STG ------------------
708          (stg_binds, cost_centre_info)
709              <- {-# SCC "CoreToStg" #-}
710                 myCoreToStg dflags this_mod prepd_binds 
711
712          ------------------  Code generation ------------------
713          cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
714                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
715                                  dir_imps cost_centre_info
716                                  stg_binds hpc_info
717                          return cmms
718                  else {-# SCC "CodeGen" #-}
719                        codeGen dflags this_mod data_tycons
720                                dir_imps cost_centre_info
721                                stg_binds hpc_info
722
723          --- Optionally run experimental Cmm transformations ---
724          -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
725                  -- unless certain dflags are on, the identity function
726          ------------------  Code output -----------------------
727          rawcmms <- cmmToRawCmm cmms
728          dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
729          (_stub_h_exists, stub_c_exists)
730              <- codeOutput dflags this_mod location foreign_stubs 
731                 dependencies rawcmms
732          return stub_c_exists
733
734 hscInteractive :: GhcMonad m =>
735                   (ModIface, ModDetails, CgGuts)
736                -> ModSummary
737                -> m (InteractiveStatus, ModIface, ModDetails)
738 #ifdef GHCI
739 hscInteractive (iface, details, cgguts) mod_summary
740     = do hsc_env <- getSession
741          liftIO $ do
742          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
743                      -- From now on, we just use the bits we need.
744                      cg_module   = this_mod,
745                      cg_binds    = core_binds,
746                      cg_tycons   = tycons,
747                      cg_foreign  = foreign_stubs,
748                      cg_modBreaks = mod_breaks } = cgguts
749              dflags = hsc_dflags hsc_env
750              location = ms_location mod_summary
751              data_tycons = filter isDataTyCon tycons
752              -- cg_tycons includes newtypes, for the benefit of External Core,
753              -- but we don't generate any code for newtypes
754
755          -------------------
756          -- PREPARE FOR CODE GENERATION
757          -- Do saturation and convert to A-normal form
758          prepd_binds <- {-# SCC "CorePrep" #-}
759                         corePrepPgm dflags core_binds data_tycons ;
760          -----------------  Generate byte code ------------------
761          comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
762          ------------------ Create f-x-dynamic C-side stuff ---
763          (_istub_h_exists, istub_c_exists) 
764              <- outputForeignStubs dflags this_mod location foreign_stubs
765          return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
766                 , iface, details)
767 #else
768 hscInteractive _ _ = panic "GHC not compiled with interpreter"
769 #endif
770
771 ------------------------------
772
773 hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
774 hscCmmFile hsc_env filename = do
775     dflags <- return $ hsc_dflags hsc_env
776     cmm <- ioMsgMaybe $
777              parseCmmFile dflags filename
778     cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
779     rawCmms <- liftIO $ cmmToRawCmm cmms
780     _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
781     return ()
782   where
783         no_mod = panic "hscCmmFile: no_mod"
784         no_loc = ModLocation{ ml_hs_file  = Just filename,
785                               ml_hi_file  = panic "hscCmmFile: no hi file",
786                               ml_obj_file = panic "hscCmmFile: no obj file" }
787
788 -------------------- Stuff for new code gen ---------------------
789
790 tryNewCodeGen   :: HscEnv -> Module -> [TyCon] -> [Module]
791                 -> CollectedCCs
792                 -> [(StgBinding,[(Id,[Id])])]
793                 -> HpcInfo
794                 -> IO [Cmm]
795 tryNewCodeGen hsc_env this_mod data_tycons imported_mods 
796               cost_centre_info stg_binds hpc_info =
797   do    { let dflags = hsc_dflags hsc_env
798         ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods 
799                          cost_centre_info stg_binds hpc_info
800         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
801                 (pprCmms prog)
802
803         ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
804                 -- Control flow optimisation
805
806         -- We are building a single SRT for the entire module, so
807         -- we must thread it through all the procedures as we cps-convert them.
808         ; us <- mkSplitUniqSupply 'S'
809         ; let topSRT = initUs_ us emptySRT
810         ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
811                 -- The main CPS conversion
812
813         ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
814                 -- Control flow optimisation, again
815
816         ; let prog' = map cmmOfZgraph prog
817         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
818         ; return prog' }
819
820
821 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
822 optionallyConvertAndOrCPS hsc_env cmms =
823     do let dflags = hsc_dflags hsc_env
824         --------  Optionally convert to and from zipper ------
825        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
826                then mapM (testCmmConversion hsc_env) cmms
827                else return cmms
828          ---------  Optionally convert to CPS (MDA) -----------
829        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
830                   dopt Opt_RunCPS dflags
831                then cmmCPS dflags cmms
832                else return cmms
833        return cmms
834
835
836 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
837 testCmmConversion hsc_env cmm =
838     do let dflags = hsc_dflags hsc_env
839        showPass dflags "CmmToCmm"
840        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
841        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
842        us <- mkSplitUniqSupply 'C'
843        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
844        let cvtm = do g <- cmmToZgraph cmm
845                      return $ cfopts g
846        let zgraph = initUs_ us cvtm
847        us <- mkSplitUniqSupply 'S'
848        let topSRT = initUs_ us emptySRT
849        (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
850        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
851        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
852        showPass dflags "Convert from Z back to Cmm"
853        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
854        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
855        return cvt
856
857 myCoreToStg :: DynFlags -> Module -> [CoreBind]
858             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
859                   , CollectedCCs) -- cost centre info (declared and used)
860
861 myCoreToStg dflags this_mod prepd_binds
862  = do 
863       stg_binds <- {-# SCC "Core2Stg" #-}
864              coreToStg (thisPackage dflags) prepd_binds
865
866       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
867              stg2stg dflags this_mod stg_binds
868
869       return (stg_binds2, cost_centre_info)
870 \end{code}
871
872
873 %************************************************************************
874 %*                                                                      *
875 \subsection{Compiling a do-statement}
876 %*                                                                      *
877 %************************************************************************
878
879 When the UnlinkedBCOExpr is linked you get an HValue of type
880         IO [HValue]
881 When you run it you get a list of HValues that should be 
882 the same length as the list of names; add them to the ClosureEnv.
883
884 A naked expression returns a singleton Name [it].
885
886         What you type                   The IO [HValue] that hscStmt returns
887         -------------                   ------------------------------------
888         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
889                                         bindings: [x,y,...]
890
891         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
892                                         bindings: [x,y,...]
893
894         expr (of IO type)       ==>     expr >>= \ v -> return [v]
895           [NB: result not printed]      bindings: [it]
896           
897
898         expr (of non-IO type, 
899           result showable)      ==>     let v = expr in print v >> return [v]
900                                         bindings: [it]
901
902         expr (of non-IO type, 
903           result not showable)  ==>     error
904
905 \begin{code}
906 #ifdef GHCI
907 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
908   :: GhcMonad m =>
909      HscEnv
910   -> String                     -- The statement
911   -> m (Maybe ([Id], HValue))
912      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
913 hscStmt hsc_env stmt = do
914     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
915     case maybe_stmt of
916       Nothing -> return Nothing
917       Just parsed_stmt -> do  -- The real stuff
918
919              -- Rename and typecheck it
920         let icontext = hsc_IC hsc_env
921         (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
922             -- Desugar it
923         let rdr_env  = ic_rn_gbl_env icontext
924             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
925         ds_expr <- ioMsgMaybe $
926                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
927
928         -- Then desugar, code gen, and link it
929         let src_span = srcLocSpan interactiveSrcLoc
930         hval <- liftIO $ compileExpr hsc_env src_span ds_expr
931
932         return $ Just (ids, hval)
933
934 hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
935 hscImport hsc_env str = do
936     (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
937     case is of
938         [i] -> return (unLoc i)
939         _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))
940
941 hscTcExpr       -- Typecheck an expression (but don't run it)
942   :: GhcMonad m =>
943      HscEnv
944   -> String                     -- The expression
945   -> m Type
946
947 hscTcExpr hsc_env expr = do
948     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
949     let icontext = hsc_IC hsc_env
950     case maybe_stmt of
951       Just (L _ (ExprStmt expr _ _)) -> do
952           ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
953           return ty
954       _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
955                         noSrcSpan
956                         (text "not an expression:" <+> quotes (text expr))
957
958 -- | Find the kind of a type
959 hscKcType
960   :: GhcMonad m =>
961      HscEnv
962   -> String                     -- ^ The type
963   -> m Kind
964
965 hscKcType hsc_env str = do
966     ty <- hscParseType (hsc_dflags hsc_env) str
967     let icontext = hsc_IC hsc_env
968     ioMsgMaybe $ tcRnType hsc_env icontext ty
969
970 #endif
971 \end{code}
972
973 \begin{code}
974 #ifdef GHCI
975 hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
976 hscParseStmt = hscParseThing parseStmt
977
978 hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
979 hscParseType = hscParseThing parseType
980 #endif
981
982 hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
983 hscParseIdentifier = hscParseThing parseIdentifier
984
985 hscParseThing :: (Outputable thing, GhcMonad m)
986               => Lexer.P thing
987               -> DynFlags -> String
988               -> m thing
989         -- Nothing => Parse error (message already printed)
990         -- Just x  => success
991 hscParseThing parser dflags str
992  = (liftIO $ showPass dflags "Parser") >>
993       {-# SCC "Parser" #-} do
994
995       buf <- liftIO $ stringToStringBuffer str
996
997       let loc  = mkSrcLoc (fsLit "<interactive>") 1 1
998
999       case unP parser (mkPState dflags buf loc) of
1000
1001         PFailed span err -> do
1002           let msg = mkPlainErrMsg span err
1003           throw (mkSrcErr (unitBag msg))
1004
1005         POk pst thing -> do
1006
1007           let ms@(warns, errs) = getMessages pst
1008           logWarnings warns
1009           when (errorsFound dflags ms) $ -- handle -Werror
1010             throw (mkSrcErr errs)
1011
1012           --ToDo: can't free the string buffer until we've finished this
1013           -- compilation sweep and all the identifiers have gone away.
1014           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1015           return thing
1016 \end{code}
1017
1018 %************************************************************************
1019 %*                                                                      *
1020         Desugar, simplify, convert to bytecode, and link an expression
1021 %*                                                                      *
1022 %************************************************************************
1023
1024 \begin{code}
1025 #ifdef GHCI
1026 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1027
1028 compileExpr hsc_env srcspan ds_expr
1029   = do  { let { dflags  = hsc_dflags hsc_env ;
1030                 lint_on = dopt Opt_DoCoreLinting dflags }
1031               
1032                 -- Simplify it
1033         ; simpl_expr <- simplifyExpr dflags ds_expr
1034
1035                 -- Tidy it (temporary, until coreSat does cloning)
1036         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1037
1038                 -- Prepare for codegen
1039         ; prepd_expr <- corePrepExpr dflags tidy_expr
1040
1041                 -- Lint if necessary
1042                 -- ToDo: improve SrcLoc
1043         ; if lint_on then 
1044                 let ictxt = hsc_IC hsc_env
1045                     tyvars = varSetElems (ic_tyvars ictxt)
1046                 in
1047                 case lintUnfolding noSrcLoc tyvars prepd_expr of
1048                    Just err -> pprPanic "compileExpr" err
1049                    Nothing  -> return ()
1050           else
1051                 return ()
1052
1053                 -- Convert to BCOs
1054         ; bcos <- coreExprToBCOs dflags prepd_expr
1055
1056                 -- link it
1057         ; hval <- linkExpr hsc_env srcspan bcos
1058
1059         ; return hval
1060      }
1061 #endif
1062 \end{code}
1063
1064
1065 %************************************************************************
1066 %*                                                                      *
1067         Statistics on reading interfaces
1068 %*                                                                      *
1069 %************************************************************************
1070
1071 \begin{code}
1072 dumpIfaceStats :: HscEnv -> IO ()
1073 dumpIfaceStats hsc_env
1074   = do  { eps <- readIORef (hsc_EPS hsc_env)
1075         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1076                     "Interface statistics"
1077                     (ifaceStats eps) }
1078   where
1079     dflags = hsc_dflags hsc_env
1080     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1081     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1082 \end{code}
1083
1084 %************************************************************************
1085 %*                                                                      *
1086         Progress Messages: Module i of n
1087 %*                                                                      *
1088 %************************************************************************
1089
1090 \begin{code}
1091 showModuleIndex :: Maybe (Int, Int) -> String
1092 showModuleIndex Nothing = ""
1093 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1094     where
1095         n_str = show n
1096         i_str = show i
1097         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1098 \end{code}