/ghc-7.0.4/compiler/main/HscMain.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
%
\begin{code}
-- | Main driver for the compiling plain Haskell source code.
--
-- This module implements compilation of a Haskell-only source file.  It is
-- /not/ concerned with preprocessing of source files; this is handled in
-- "DriverPipeline".
--
module HscMain
    ( newHscEnv, hscCmmFile
    , hscParseIdentifier
    , hscSimplify
    , hscNormalIface, hscWriteIface, hscGenHardCode
#ifdef GHCI
    , hscStmt, hscTcExpr, hscImport, hscKcType
    , compileExpr
#endif
    , HsCompiler(..)
    , hscOneShotCompiler, hscNothingCompiler
    , hscInteractiveCompiler, hscBatchCompiler
    , hscCompileOneShot     -- :: Compiler HscStatus
    , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
    , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
    , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
    , hscCheckRecompBackend
    , HscStatus' (..)
    , InteractiveStatus, HscStatus

    -- The new interface
    , hscParse
    , hscTypecheck
    , hscTypecheckRename
    , hscDesugar
    , makeSimpleIface
    , makeSimpleDetails
    ) where

#ifdef GHCI
import CodeOutput	( outputForeignStubs )
import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
import Linker		( HValue, linkExpr )
import CoreTidy		( tidyExpr )
import CorePrep		( corePrepExpr )
import Desugar          ( deSugarExpr )
import SimplCore        ( simplifyExpr )
import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnType ) 
import Type		( Type, tyVarsOfTypes )
import PrelNames	( iNTERACTIVE )
import {- Kind parts of -} Type		( Kind )
import Id      	     	( idType )
import CoreLint		( lintUnfolding )
import DsMeta		( templateHaskellNames )
import SrcLoc		( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
import VarSet
import VarEnv		( emptyTidyEnv )
import Panic
#endif

import Id		( Id )
import Module		( emptyModuleEnv, ModLocation(..), Module )
import RdrName
import HsSyn
import CoreSyn
import SrcLoc		( Located(..) )
import StringBuffer
import Parser
import Lexer
import SrcLoc		( mkSrcLoc )
import TcRnDriver	( tcRnModule )
import TcIface		( typecheckIface )
import TcRnMonad	( initIfaceCheck, TcGblEnv(..) )
import IfaceEnv		( initNameCache )
import LoadIface	( ifaceStats, initExternalPackageState )
import PrelInfo		( wiredInThings, basicKnownKeyNames )
import MkIface
import Desugar          ( deSugar )
import SimplCore        ( core2core )
import TidyPgm
import CorePrep		( corePrepPgm )
import CoreToStg	( coreToStg )
import qualified StgCmm	( codeGen )
import StgSyn
import CostCentre
import TyCon		( TyCon, isDataTyCon )
import Name		( Name, NamedThing(..) )
import SimplStg		( stg2stg )
import CodeGen		( codeGen )
import Cmm              ( Cmm )
import PprCmm		( pprCmms )
import CmmParse		( parseCmmFile )
import CmmBuildInfoTables
import CmmCPS
import CmmCPSZ
import CmmInfo
import OptimizationFuel ( initOptFuelState )
import CmmCvt
import CmmTx
import CmmContFlowOpt
import CodeOutput	( codeOutput )
import NameEnv          ( emptyNameEnv )
import Fingerprint      ( Fingerprint )

import DynFlags
import ErrUtils
import UniqSupply	( mkSplitUniqSupply )

import Outputable
import HscStats		( ppSourceStats )
import HscTypes
import MkExternalCore	( emitExternalCore )
import FastString
import UniqFM		( emptyUFM )
import UniqSupply       ( initUs_ )
import Bag		( unitBag )
import Exception
-- import MonadUtils

import Control.Monad
-- import System.IO
import Data.IORef
\end{code}
#include "HsVersions.h"


%************************************************************************
%*									*
		Initialisation
%*									*
%************************************************************************

\begin{code}
newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv
newHscEnv callbacks dflags
  = do 	{ eps_var <- newIORef initExternalPackageState
	; us      <- mkSplitUniqSupply 'r'
	; nc_var  <- newIORef (initNameCache us knownKeyNames)
	; fc_var  <- newIORef emptyUFM
	; mlc_var <- newIORef emptyModuleEnv
        ; optFuel <- initOptFuelState
	; return (HscEnv { hsc_dflags = dflags,
                           hsc_callbacks = callbacks,
			   hsc_targets = [],
			   hsc_mod_graph = [],
			   hsc_IC      = emptyInteractiveContext,
			   hsc_HPT     = emptyHomePackageTable,
			   hsc_EPS     = eps_var,
			   hsc_NC      = nc_var,
			   hsc_FC      = fc_var,
			   hsc_MLC     = mlc_var,
			   hsc_OptFuel = optFuel,
                           hsc_type_env_var = Nothing } ) }


knownKeyNames :: [Name]	-- Put here to avoid loops involving DsMeta,
			-- where templateHaskellNames are defined
knownKeyNames = map getName wiredInThings 
	      ++ basicKnownKeyNames
#ifdef GHCI
	      ++ templateHaskellNames
#endif
\end{code}


\begin{code}
-- | parse a file, returning the abstract syntax
hscParse :: GhcMonad m =>
            ModSummary
         -> m (Located (HsModule RdrName))
hscParse mod_summary = do
   hsc_env <- getSession
   let dflags        = hsc_dflags hsc_env
       src_filename  = ms_hspp_file mod_summary
       maybe_src_buf = ms_hspp_buf  mod_summary
   --------------------------  Parser  ----------------
   liftIO $ showPass dflags "Parser"
   {-# SCC "Parser" #-} do

	-- sometimes we already have the buffer in memory, perhaps
	-- because we needed to parse the imports out of it, or get the
	-- module name.
   buf <- case maybe_src_buf of
            Just b  -> return b
            Nothing -> liftIO $ hGetStringBuffer src_filename

   let loc  = mkSrcLoc (mkFastString src_filename) 1 1

   case unP parseModule (mkPState dflags buf loc) of
     PFailed span err ->
         throwOneError (mkPlainErrMsg span err)

     POk pst rdr_module -> do
         let ms@(warns,errs) = getMessages pst
         logWarnings warns
         if errorsFound dflags ms then
           liftIO $ throwIO $ mkSrcErr errs
          else liftIO $ do
           dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
           dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
                               (ppSourceStats False rdr_module) ;
           return rdr_module
          -- ToDo: free the string buffer later.

-- | Rename and typecheck a module
hscTypecheck :: GhcMonad m =>
                ModSummary -> Located (HsModule RdrName)
             -> m TcGblEnv
hscTypecheck mod_summary rdr_module = do
      hsc_env <- getSession
      r <- {-# SCC "Typecheck-Rename" #-}
           ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
      return r

-- XXX: should this really be a Maybe X?  Check under which circumstances this
-- can become a Nothing and decide whether this should instead throw an
-- exception/signal an error.
type RenamedStuff = 
        (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
                Maybe LHsDocString))

-- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename ::
       GhcMonad m =>
       ModSummary -> Located (HsModule RdrName)
    -> m (TcGblEnv, RenamedStuff)
hscTypecheckRename mod_summary rdr_module = do
    hsc_env <- getSession
    tc_result
          <- {-# SCC "Typecheck-Rename" #-}
             ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module

    let -- This 'do' is in the Maybe monad!
        rn_info = do { decl <- tcg_rn_decls tc_result
                     ; let imports = tcg_rn_imports tc_result
                           exports = tcg_rn_exports tc_result
                           doc_hdr  = tcg_doc_hdr tc_result
                     ; return (decl,imports,exports,doc_hdr) }

    return (tc_result, rn_info)

-- | Convert a typechecked module to Core
hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts
hscDesugar mod_summary tc_result =
  withSession $ \hsc_env ->
    ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result

-- | Make a 'ModIface' from the results of typechecking.  Used when
-- not optimising, and the interface doesn't need to contain any
-- unfoldings or other cross-module optimisation info.
-- ToDo: the old interface is only needed to get the version numbers,
-- we should use fingerprint versions instead.
makeSimpleIface :: GhcMonad m =>
                   Maybe ModIface -> TcGblEnv -> ModDetails
                -> m (ModIface,Bool)
makeSimpleIface maybe_old_iface tc_result details =
  withSession $ \hsc_env ->
  ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result

-- | Make a 'ModDetails' from the results of typechecking.  Used when
-- typechecking only, as opposed to full compilation.
makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails
makeSimpleDetails tc_result =
    withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result
\end{code}

%************************************************************************
%*									*
		The main compiler pipeline
%*									*
%************************************************************************

                   --------------------------------
                        The compilation proper
                   --------------------------------


It's the task of the compilation proper to compile Haskell, hs-boot and
core files to either byte-code, hard-code (C, asm, Java, ect) or to
nothing at all (the module is still parsed and type-checked. This
feature is mostly used by IDE's and the likes).
Compilation can happen in either 'one-shot', 'batch', 'nothing',
or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
targets byte-code.
The modes are kept separate because of their different types and meanings.
In 'one-shot' mode, we're only compiling a single file and can therefore
discard the new ModIface and ModDetails. This is also the reason it only
targets hard-code; compiling to byte-code or nothing doesn't make sense
when we discard the result.
'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
and ModDetails. 'Batch' mode doesn't target byte-code since that require
us to return the newly compiled byte-code.
'Nothing' mode has exactly the same type as 'batch' mode but they're still
kept separate. This is because compiling to nothing is fairly special: We
don't output any interface files, we don't run the simplifier and we don't
generate any code.
'Interactive' mode is similar to 'batch' mode except that we return the
compiled byte-code together with the ModIface and ModDetails.

Trying to compile a hs-boot file to byte-code will result in a run-time
error. This is the only thing that isn't caught by the type-system.

\begin{code}

-- Status of a compilation to hard-code or nothing.
data HscStatus' a
    = HscNoRecomp
    | HscRecomp
       Bool -- Has stub files.  This is a hack. We can't compile C files here
            -- since it's done in DriverPipeline. For now we just return True
            -- if we want the caller to compile them for us.
       a

-- This is a bit ugly.  Since we use a typeclass below and would like to avoid
-- functional dependencies, we have to parameterise the typeclass over the
-- result type.  Therefore we need to artificially distinguish some types.  We
-- do this by adding type tags which will simply be ignored by the caller.
type HscStatus         = HscStatus' ()
type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
    -- INVARIANT: result is @Nothing@ <=> input was a boot file

type OneShotResult     = HscStatus
type BatchResult       = (HscStatus, ModIface, ModDetails)
type NothingResult     = (HscStatus, ModIface, ModDetails)
type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)

-- FIXME: The old interface and module index are only using in 'batch' and
--        'interactive' mode. They should be removed from 'oneshot' mode.
type Compiler result =  GhcMonad m =>
                        HscEnv
                     -> ModSummary
                     -> Bool                -- True <=> source unchanged
                     -> Maybe ModIface      -- Old interface, if available
                     -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
                     -> m result

data HsCompiler a
  = HsCompiler {
    -- | Called when no recompilation is necessary.
    hscNoRecomp :: GhcMonad m =>
                   ModIface -> m a,

    -- | Called to recompile the module.
    hscRecompile :: GhcMonad m =>
                    ModSummary -> Maybe Fingerprint -> m a,

    hscBackend :: GhcMonad m =>
                  TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,

    -- | Code generation for Boot modules.
    hscGenBootOutput :: GhcMonad m =>
                        TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,

    -- | Code generation for normal modules.
    hscGenOutput :: GhcMonad m =>
                    ModGuts  -> ModSummary -> Maybe Fingerprint -> m a
  }

genericHscCompile :: GhcMonad m =>
                     HsCompiler a
                  -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
                  -> HscEnv -> ModSummary -> Bool
                  -> Maybe ModIface -> Maybe (Int, Int)
                  -> m a
genericHscCompile compiler hscMessage
                  hsc_env mod_summary source_unchanged
                  mb_old_iface0 mb_mod_index =
   withTempSession (\_ -> hsc_env) $ do
     (recomp_reqd, mb_checked_iface)
         <- {-# SCC "checkOldIface" #-}
            liftIO $ checkOldIface hsc_env mod_summary
                                   source_unchanged mb_old_iface0
     -- save the interface that comes back from checkOldIface.
     -- In one-shot mode we don't have the old iface until this
     -- point, when checkOldIface reads it from the disk.
     let mb_old_hash = fmap mi_iface_hash mb_checked_iface
     case mb_checked_iface of
       Just iface | not recomp_reqd
           -> do hscMessage mb_mod_index False mod_summary
                 hscNoRecomp compiler iface
       _otherwise
           -> do hscMessage mb_mod_index True mod_summary
                 hscRecompile compiler mod_summary mb_old_hash

hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
hscCheckRecompBackend compiler tc_result 
                   hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
   withTempSession (\_ -> hsc_env) $ do
     (recomp_reqd, mb_checked_iface)
         <- {-# SCC "checkOldIface" #-}
            liftIO $ checkOldIface hsc_env mod_summary
                                   source_unchanged mb_old_iface

     let mb_old_hash = fmap mi_iface_hash mb_checked_iface
     case mb_checked_iface of
       Just iface | not recomp_reqd
           -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
       _otherwise
           -> hscBackend compiler tc_result mod_summary mb_old_hash

genericHscRecompile :: GhcMonad m =>
                       HsCompiler a
                    -> ModSummary -> Maybe Fingerprint
                    -> m a
genericHscRecompile compiler mod_summary mb_old_hash
  | ExtCoreFile <- ms_hsc_src mod_summary =
      panic "GHC does not currently support reading External Core files"
  | otherwise = do
      tc_result <- hscFileFrontEnd mod_summary
      hscBackend compiler tc_result mod_summary mb_old_hash

genericHscBackend :: GhcMonad m =>
                     HsCompiler a
                  -> TcGblEnv -> ModSummary -> Maybe Fingerprint
                  -> m a
genericHscBackend compiler tc_result mod_summary mb_old_hash
  | HsBootFile <- ms_hsc_src mod_summary =
      hscGenBootOutput compiler tc_result mod_summary mb_old_hash
  | otherwise = do
      guts <- hscDesugar mod_summary tc_result
      hscGenOutput compiler guts mod_summary mb_old_hash

--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------

hscOneShotCompiler :: HsCompiler OneShotResult
hscOneShotCompiler =
  HsCompiler {

    hscNoRecomp = \_old_iface -> do
      withSession (liftIO . dumpIfaceStats)
      return HscNoRecomp

  , hscRecompile = genericHscRecompile hscOneShotCompiler

  , hscBackend = \ tc_result mod_summary mb_old_hash -> do
       hsc_env <- getSession
       case hscTarget (hsc_dflags hsc_env) of
         HscNothing -> return (HscRecomp False ())
         _otherw    -> genericHscBackend hscOneShotCompiler 
                                         tc_result mod_summary mb_old_hash

  , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
       (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
       hscWriteIface iface changed mod_summary
       return (HscRecomp False ())

  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
       guts <- hscSimplify guts0
       (iface, changed, _details, cgguts)
           <- hscNormalIface guts mb_old_iface
       hscWriteIface iface changed mod_summary
       hasStub <- hscGenHardCode cgguts mod_summary
       return (HscRecomp hasStub ())
  }

-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler OneShotResult
hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
       -- One-shot mode needs a knot-tying mutable variable for interface
       -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
      type_env_var <- liftIO $ newIORef emptyNameEnv
      let
         mod = ms_mod mod_summary
         hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
      ---
      genericHscCompile hscOneShotCompiler
                        oneShotMsg hsc_env' mod_summary src_changed
                        mb_old_iface mb_i_of_n


--------------------------------------------------------------

hscBatchCompiler :: HsCompiler BatchResult
hscBatchCompiler =
  HsCompiler {

    hscNoRecomp = \iface -> do
       details <- genModDetails iface
       return (HscNoRecomp, iface, details)

  , hscRecompile = genericHscRecompile hscBatchCompiler

  , hscBackend = genericHscBackend hscBatchCompiler

  , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
       (iface, changed, details)
           <- hscSimpleIface tc_result mb_old_iface
       hscWriteIface iface changed mod_summary
       return (HscRecomp False (), iface, details)

  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
       guts <- hscSimplify guts0
       (iface, changed, details, cgguts)
           <- hscNormalIface guts mb_old_iface
       hscWriteIface iface changed mod_summary
       hasStub <- hscGenHardCode cgguts mod_summary
       return (HscRecomp hasStub (), iface, details)
  }

-- Compile Haskell, boot and extCore in batch mode.
hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg

--------------------------------------------------------------

hscInteractiveCompiler :: HsCompiler InteractiveResult
hscInteractiveCompiler =
  HsCompiler {
    hscNoRecomp = \iface -> do
       details <- genModDetails iface
       return (HscNoRecomp, iface, details)

  , hscRecompile = genericHscRecompile hscInteractiveCompiler

  , hscBackend = genericHscBackend hscInteractiveCompiler

  , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
       (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
       return (HscRecomp False Nothing, iface, details)

  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
       guts <- hscSimplify guts0
       (iface, _changed, details, cgguts)
           <- hscNormalIface guts mb_old_iface
       hscInteractive (iface, details, cgguts) mod_summary
  }

-- Compile Haskell, extCore to bytecode.
hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg

--------------------------------------------------------------

hscNothingCompiler :: HsCompiler NothingResult
hscNothingCompiler =
  HsCompiler {
    hscNoRecomp = \iface -> do
       details <- genModDetails iface
       return (HscNoRecomp, iface, details)

  , hscRecompile = genericHscRecompile hscNothingCompiler

  , hscBackend = \tc_result _mod_summary mb_old_iface -> do
       (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
       return (HscRecomp False (), iface, details)

  , hscGenBootOutput = \_ _ _ ->
        panic "hscCompileNothing: hscGenBootOutput should not be called"

  , hscGenOutput = \_ _ _ ->
        panic "hscCompileNothing: hscGenOutput should not be called"
  }

-- Type-check Haskell and .hs-boot only (no external core)
hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg

--------------------------------------------------------------
-- NoRecomp handlers
--------------------------------------------------------------

genModDetails :: GhcMonad m => ModIface -> m ModDetails
genModDetails old_iface =
    withSession $ \hsc_env -> liftIO $ do
      new_details <- {-# SCC "tcRnIface" #-}
                     initIfaceCheck hsc_env $
                     typecheckIface old_iface
      dumpIfaceStats hsc_env
      return new_details

--------------------------------------------------------------
-- Progress displayers.
--------------------------------------------------------------

oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
oneShotMsg _mb_mod_index recomp _mod_summary
    = do hsc_env <- getSession
         liftIO $ do
         if recomp
            then return ()
            else compilationProgressMsg (hsc_dflags hsc_env) $
                     "compilation IS NOT required"

batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
batchMsg mb_mod_index recomp mod_summary
    = do hsc_env <- getSession
         let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
                           (showModuleIndex mb_mod_index ++
                            msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
         liftIO $ do
         if recomp
            then showMsg "Compiling "
            else if verbosity (hsc_dflags hsc_env) >= 2
                    then showMsg "Skipping  "
                    else return ()

--------------------------------------------------------------
-- FrontEnds
--------------------------------------------------------------
hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv
hscFileFrontEnd mod_summary =
    do rdr_module <- hscParse mod_summary
       hscTypecheck mod_summary rdr_module

--------------------------------------------------------------
-- Simplifiers
--------------------------------------------------------------

hscSimplify :: GhcMonad m => ModGuts -> m ModGuts
hscSimplify ds_result
  = do hsc_env <- getSession
       simpl_result <- {-# SCC "Core2Core" #-}
                       liftIO $ core2core hsc_env ds_result
       return simpl_result

--------------------------------------------------------------
-- Interface generators
--------------------------------------------------------------

hscSimpleIface :: GhcMonad m =>
                  TcGblEnv
               -> Maybe Fingerprint
               -> m (ModIface, Bool, ModDetails)
hscSimpleIface tc_result mb_old_iface
  = do hsc_env <- getSession
       details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
       (new_iface, no_change)
           <- {-# SCC "MkFinalIface" #-}
              ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result
       -- And the answer is ...
       liftIO $ dumpIfaceStats hsc_env
       return (new_iface, no_change, details)

hscNormalIface :: GhcMonad m =>
                  ModGuts
               -> Maybe Fingerprint
               -> m (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface simpl_result mb_old_iface
  = do hsc_env <- getSession

       (cg_guts, details) <- {-# SCC "CoreTidy" #-}
                             liftIO $ tidyProgram hsc_env simpl_result

	    -- BUILD THE NEW ModIface and ModDetails
	    --	and emit external core if necessary
	    -- This has to happen *after* code gen so that the back-end
	    -- info has been set.  Not yet clear if it matters waiting
	    -- until after code output
       (new_iface, no_change)
	   <- {-# SCC "MkFinalIface" #-}
	      ioMsgMaybe $ mkIface hsc_env mb_old_iface
                                   details simpl_result
	-- Emit external core
       -- This should definitely be here and not after CorePrep,
       -- because CorePrep produces unqualified constructor wrapper declarations,
       -- so its output isn't valid External Core (without some preprocessing).
       liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
       liftIO $ dumpIfaceStats hsc_env

 	    -- Return the prepared code.
       return (new_iface, no_change, details, cg_guts)

--------------------------------------------------------------
-- BackEnd combinators
--------------------------------------------------------------

hscWriteIface :: GhcMonad m =>
                 ModIface -> Bool
              -> ModSummary
              -> m ()
hscWriteIface iface no_change mod_summary
    = do hsc_env <- getSession
         let dflags = hsc_dflags hsc_env
         liftIO $ do
         unless no_change
           $ writeIfaceFile dflags (ms_location mod_summary) iface

-- | Compile to hard-code.
hscGenHardCode :: GhcMonad m =>
                  CgGuts -> ModSummary
               -> m Bool -- ^ @True@ <=> stub.c exists
hscGenHardCode cgguts mod_summary
    = withSession $ \hsc_env -> liftIO $ do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                     -- From now on, we just use the bits we need.
                     cg_module   = this_mod,
                     cg_binds    = core_binds,
                     cg_tycons   = tycons,
                     cg_dir_imps = dir_imps,
                     cg_foreign  = foreign_stubs,
                     cg_dep_pkgs = dependencies,
                     cg_hpc_info = hpc_info } = cgguts
             dflags = hsc_dflags hsc_env
             location = ms_location mod_summary
             data_tycons = filter isDataTyCon tycons
             -- cg_tycons includes newtypes, for the benefit of External Core,
             -- but we don't generate any code for newtypes

         -------------------
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
         prepd_binds <- {-# SCC "CorePrep" #-}
                        corePrepPgm dflags core_binds data_tycons ;
         -----------------  Convert to STG ------------------
         (stg_binds, cost_centre_info)
             <- {-# SCC "CoreToStg" #-}
                myCoreToStg dflags this_mod prepd_binds	

         ------------------  Code generation ------------------
         cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
                 then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
                                 dir_imps cost_centre_info
                                 stg_binds hpc_info
                         return cmms
                 else {-# SCC "CodeGen" #-}
                       codeGen dflags this_mod data_tycons
                               dir_imps cost_centre_info
                               stg_binds hpc_info

         --- Optionally run experimental Cmm transformations ---
         -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
                 -- unless certain dflags are on, the identity function
         ------------------  Code output -----------------------
         rawcmms <- cmmToRawCmm cmms
         dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
         (_stub_h_exists, stub_c_exists)
             <- codeOutput dflags this_mod location foreign_stubs 
                dependencies rawcmms
         return stub_c_exists

hscInteractive :: GhcMonad m =>
                  (ModIface, ModDetails, CgGuts)
               -> ModSummary
               -> m (InteractiveStatus, ModIface, ModDetails)
#ifdef GHCI
hscInteractive (iface, details, cgguts) mod_summary
    = do hsc_env <- getSession
         liftIO $ do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                     -- From now on, we just use the bits we need.
                     cg_module   = this_mod,
                     cg_binds    = core_binds,
                     cg_tycons   = tycons,
                     cg_foreign  = foreign_stubs,
                     cg_modBreaks = mod_breaks } = cgguts
             dflags = hsc_dflags hsc_env
             location = ms_location mod_summary
             data_tycons = filter isDataTyCon tycons
             -- cg_tycons includes newtypes, for the benefit of External Core,
             -- but we don't generate any code for newtypes

         -------------------
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
         prepd_binds <- {-# SCC "CorePrep" #-}
                        corePrepPgm dflags core_binds data_tycons ;
         -----------------  Generate byte code ------------------
         comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
         ------------------ Create f-x-dynamic C-side stuff ---
         (_istub_h_exists, istub_c_exists) 
             <- outputForeignStubs dflags this_mod location foreign_stubs
         return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
                , iface, details)
#else
hscInteractive _ _ = panic "GHC not compiled with interpreter"
#endif

------------------------------

hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
hscCmmFile hsc_env filename = do
    dflags <- return $ hsc_dflags hsc_env
    cmm <- ioMsgMaybe $
             parseCmmFile dflags filename
    cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
    rawCmms <- liftIO $ cmmToRawCmm cmms
    _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
    return ()
  where
	no_mod = panic "hscCmmFile: no_mod"
	no_loc = ModLocation{ ml_hs_file  = Just filename,
                              ml_hi_file  = panic "hscCmmFile: no hi file",
                              ml_obj_file = panic "hscCmmFile: no obj file" }

-------------------- Stuff for new code gen ---------------------

tryNewCodeGen	:: HscEnv -> Module -> [TyCon] -> [Module]
		-> CollectedCCs
		-> [(StgBinding,[(Id,[Id])])]
		-> HpcInfo
		-> IO [Cmm]
tryNewCodeGen hsc_env this_mod data_tycons imported_mods 
	      cost_centre_info stg_binds hpc_info =
  do	{ let dflags = hsc_dflags hsc_env
        ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods 
		 	 cost_centre_info stg_binds hpc_info
	; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
		(pprCmms prog)

	; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
		-- Control flow optimisation

        -- We are building a single SRT for the entire module, so
        -- we must thread it through all the procedures as we cps-convert them.
        ; us <- mkSplitUniqSupply 'S'
        ; let topSRT = initUs_ us emptySRT
	; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
		-- The main CPS conversion

	; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
		-- Control flow optimisation, again

	; let prog' = map cmmOfZgraph prog
	; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
	; return prog' }


optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
optionallyConvertAndOrCPS hsc_env cmms =
    do let dflags = hsc_dflags hsc_env
        --------  Optionally convert to and from zipper ------
       cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
               then mapM (testCmmConversion hsc_env) cmms
               else return cmms
         ---------  Optionally convert to CPS (MDA) -----------
       cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
                  dopt Opt_RunCPS dflags
               then cmmCPS dflags cmms
               else return cmms
       return cmms


testCmmConversion :: HscEnv -> Cmm -> IO Cmm
testCmmConversion hsc_env cmm =
    do let dflags = hsc_dflags hsc_env
       showPass dflags "CmmToCmm"
       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
       --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
       us <- mkSplitUniqSupply 'C'
       let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
       let cvtm = do g <- cmmToZgraph cmm
                     return $ cfopts g
       let zgraph = initUs_ us cvtm
       us <- mkSplitUniqSupply 'S'
       let topSRT = initUs_ us emptySRT
       (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
       let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
       dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
       showPass dflags "Convert from Z back to Cmm"
       let cvt = cmmOfZgraph $ cfopts $ chosen_graph
       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
       return cvt

myCoreToStg :: DynFlags -> Module -> [CoreBind]
            -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
	          , CollectedCCs) -- cost centre info (declared and used)

myCoreToStg dflags this_mod prepd_binds
 = do 
      stg_binds <- {-# SCC "Core2Stg" #-}
	     coreToStg (thisPackage dflags) prepd_binds

      (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
	     stg2stg dflags this_mod stg_binds

      return (stg_binds2, cost_centre_info)
\end{code}


%************************************************************************
%*									*
\subsection{Compiling a do-statement}
%*									*
%************************************************************************

When the UnlinkedBCOExpr is linked you get an HValue of type
	IO [HValue]
When you run it you get a list of HValues that should be 
the same length as the list of names; add them to the ClosureEnv.

A naked expression returns a singleton Name [it].

	What you type			The IO [HValue] that hscStmt returns
	-------------			------------------------------------
	let pat = expr		==> 	let pat = expr in return [coerce HVal x, coerce HVal y, ...]
					bindings: [x,y,...]

	pat <- expr		==> 	expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
					bindings: [x,y,...]

	expr (of IO type)	==>	expr >>= \ v -> return [v]
	  [NB: result not printed]	bindings: [it]
	  

	expr (of non-IO type, 
	  result showable)	==>	let v = expr in print v >> return [v]
	  				bindings: [it]

	expr (of non-IO type, 
	  result not showable)	==>	error

\begin{code}
#ifdef GHCI
hscStmt		-- Compile a stmt all the way to an HValue, but don't run it
  :: GhcMonad m =>
     HscEnv
  -> String			-- The statement
  -> m (Maybe ([Id], HValue))
     -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
hscStmt hsc_env stmt = do
    maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
    case maybe_stmt of
      Nothing -> return Nothing
      Just parsed_stmt -> do  -- The real stuff

             -- Rename and typecheck it
	let icontext = hsc_IC hsc_env
	(ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
	    -- Desugar it
	let rdr_env  = ic_rn_gbl_env icontext
	    type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
	ds_expr <- ioMsgMaybe $
                     deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr

	-- Then desugar, code gen, and link it
	let src_span = srcLocSpan interactiveSrcLoc
	hval <- liftIO $ compileExpr hsc_env src_span ds_expr

	return $ Just (ids, hval)

hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
hscImport hsc_env str = do
    (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
    case is of
        [i] -> return (unLoc i)
        _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))

hscTcExpr	-- Typecheck an expression (but don't run it)
  :: GhcMonad m =>
     HscEnv
  -> String			-- The expression
  -> m Type

hscTcExpr hsc_env expr = do
    maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
    let icontext = hsc_IC hsc_env
    case maybe_stmt of
      Just (L _ (ExprStmt expr _ _)) -> do
          ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
          return ty
      _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
                        noSrcSpan
                        (text "not an expression:" <+> quotes (text expr))

-- | Find the kind of a type
hscKcType
  :: GhcMonad m =>
     HscEnv
  -> String			-- ^ The type
  -> m Kind

hscKcType hsc_env str = do
    ty <- hscParseType (hsc_dflags hsc_env) str
    let icontext = hsc_IC hsc_env
    ioMsgMaybe $ tcRnType hsc_env icontext ty

#endif
\end{code}

\begin{code}
#ifdef GHCI
hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
hscParseStmt = hscParseThing parseStmt

hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
hscParseType = hscParseThing parseType
#endif

hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
hscParseIdentifier = hscParseThing parseIdentifier

hscParseThing :: (Outputable thing, GhcMonad m)
	      => Lexer.P thing
	      -> DynFlags -> String
	      -> m thing
	-- Nothing => Parse error (message already printed)
	-- Just x  => success
hscParseThing parser dflags str
 = (liftIO $ showPass dflags "Parser") >>
      {-# SCC "Parser" #-} do

      buf <- liftIO $ stringToStringBuffer str

      let loc  = mkSrcLoc (fsLit "<interactive>") 1 1

      case unP parser (mkPState dflags buf loc) of

	PFailed span err -> do
          let msg = mkPlainErrMsg span err
          throw (mkSrcErr (unitBag msg))

	POk pst thing -> do

          let ms@(warns, errs) = getMessages pst
          logWarnings warns
          when (errorsFound dflags ms) $ -- handle -Werror
            throw (mkSrcErr errs)

          --ToDo: can't free the string buffer until we've finished this
          -- compilation sweep and all the identifiers have gone away.
          liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
          return thing
\end{code}

%************************************************************************
%*									*
	Desugar, simplify, convert to bytecode, and link an expression
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI
compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue

compileExpr hsc_env srcspan ds_expr
  | rtsIsProfiled
  = throwIO (InstallationError "You can't call compileExpr in a profiled compiler")
    	  -- Otherwise you get a seg-fault when you run it

  | otherwise
  = do	{ let { dflags  = hsc_dflags hsc_env ;
		lint_on = dopt Opt_DoCoreLinting dflags }
	      
		-- Simplify it
	; simpl_expr <- simplifyExpr dflags ds_expr

		-- Tidy it (temporary, until coreSat does cloning)
	; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr

		-- Prepare for codegen
	; prepd_expr <- corePrepExpr dflags tidy_expr

		-- Lint if necessary
		-- ToDo: improve SrcLoc
	; if lint_on then 
                let ictxt = hsc_IC hsc_env
                    tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
                in
		case lintUnfolding noSrcLoc tyvars prepd_expr of
		   Just err -> pprPanic "compileExpr" err
		   Nothing  -> return ()
	  else
		return ()

		-- Convert to BCOs
	; bcos <- coreExprToBCOs dflags prepd_expr

		-- link it
	; hval <- linkExpr hsc_env srcspan bcos

	; return hval
     }
#endif
\end{code}


%************************************************************************
%*									*
	Statistics on reading interfaces
%*									*
%************************************************************************

\begin{code}
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env
  = do	{ eps <- readIORef (hsc_EPS hsc_env)
	; dumpIfSet (dump_if_trace || dump_rn_stats)
	      	    "Interface statistics"
	      	    (ifaceStats eps) }
  where
    dflags = hsc_dflags hsc_env
    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
    dump_if_trace = dopt Opt_D_dump_if_trace dflags
\end{code}

%************************************************************************
%*									*
	Progress Messages: Module i of n
%*									*
%************************************************************************

\begin{code}
showModuleIndex :: Maybe (Int, Int) -> String
showModuleIndex Nothing = ""
showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
    where
        n_str = show n
        i_str = show i
        padded = replicate (length n_str - length i_str) ' ' ++ i_str
\end{code}