compiler/main/HscMain.lhs

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