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