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