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     , hscRnImportDecls
  62 #ifdef GHCI
  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 #endif
 298
 299 -- -----------------------------------------------------------------------------
 300 -- | Rename some import declarations
 301
 302 hscRnImportDecls
 303         :: HscEnv
 304         -> Module
 305         -> [LImportDecl RdrName]
 306         -> IO GlobalRdrEnv
 307
 308 -- It is important that we use tcRnImports instead of calling rnImports directly
 309 -- because tcRnImports will force-load any orphan modules necessary, making extra
 310 -- instances/family instances visible (GHC #4832)
 311 hscRnImportDecls hsc_env this_mod import_decls
 312   = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
 313           fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls
 314
 315 -- -----------------------------------------------------------------------------
 316 -- | parse a file, returning the abstract syntax
 317
 318 hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName))
 319 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
 320
 321 -- internal version, that doesn't fail due to -Werror
 322 hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName))
 323 hscParse' mod_summary
 324  = do
 325    dflags <- getDynFlags
 326    let
 327        src_filename  = ms_hspp_file mod_summary
 328        maybe_src_buf = ms_hspp_buf  mod_summary
 329
 330    --------------------------  Parser  ----------------
 331    liftIO $ showPass dflags "Parser"
 332    {-# SCC "Parser" #-} do
 333
 334         -- sometimes we already have the buffer in memory, perhaps
 335         -- because we needed to parse the imports out of it, or get the
 336         -- module name.
 337    buf <- case maybe_src_buf of
 338             Just b  -> return b
 339             Nothing -> liftIO $ hGetStringBuffer src_filename
 340
 341    let loc  = mkSrcLoc (mkFastString src_filename) 1 1
 342
 343    case unP parseModule (mkPState dflags buf loc) of
 344      PFailed span err ->
 345          liftIO $ throwOneError (mkPlainErrMsg span err)
 346
 347      POk pst rdr_module -> do
 348          logWarningsReportErrors (getMessages pst)
 349          liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
 350                                 ppr rdr_module
 351          liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
 352                                 ppSourceStats False rdr_module
 353          return rdr_module
 354           -- ToDo: free the string buffer later.
 355
 356 -- XXX: should this really be a Maybe X?  Check under which circumstances this
 357 -- can become a Nothing and decide whether this should instead throw an
 358 -- exception/signal an error.
 359 type RenamedStuff =
 360         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
 361                 Maybe LHsDocString))
 362
 363 -- | Rename and typecheck a module, additionally returning the renamed syntax
 364 hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName)
 365                    -> IO (TcGblEnv, RenamedStuff)
 366 hscTypecheckRename hsc_env mod_summary rdr_module
 367   = runHsc hsc_env $ do
 368       tc_result
 369           <- {-# SCC "Typecheck-Rename" #-}
 370               ioMsgMaybe $
 371                   tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
 372
 373       let -- This 'do' is in the Maybe monad!
 374           rn_info = do decl <- tcg_rn_decls tc_result
 375                        let imports = tcg_rn_imports tc_result
 376                            exports = tcg_rn_exports tc_result
 377                            doc_hdr  = tcg_doc_hdr tc_result
 378                        return (decl,imports,exports,doc_hdr)
 379
 380       return (tc_result, rn_info)
 381
 382 -- | Convert a typechecked module to Core
 383 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
 384 hscDesugar hsc_env mod_summary tc_result
 385   = runHsc hsc_env $ hscDesugar' mod_summary tc_result
 386
 387 hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts
 388 hscDesugar' mod_summary tc_result
 389  = do
 390       hsc_env <- getHscEnv
 391       r <- ioMsgMaybe $
 392              deSugar hsc_env (ms_location mod_summary) tc_result
 393
 394       handleWarnings
 395                 -- always check -Werror after desugaring, this is
 396                 -- the last opportunity for warnings to arise before
 397                 -- the backend.
 398       return r
 399
 400 -- | Make a 'ModIface' from the results of typechecking.  Used when
 401 -- not optimising, and the interface doesn't need to contain any
 402 -- unfoldings or other cross-module optimisation info.
 403 -- ToDo: the old interface is only needed to get the version numbers,
 404 -- we should use fingerprint versions instead.
 405 makeSimpleIface :: HscEnv ->
 406                    Maybe ModIface -> TcGblEnv -> ModDetails
 407                 -> IO (ModIface,Bool)
 408 makeSimpleIface hsc_env maybe_old_iface tc_result details
 409   = runHsc hsc_env $
 410      ioMsgMaybe $
 411        mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
 412
 413 -- | Make a 'ModDetails' from the results of typechecking.  Used when
 414 -- typechecking only, as opposed to full compilation.
 415 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
 416 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
 417 \end{code}
 418
 419 %************************************************************************
 420 %*                                                                      *
 421                 The main compiler pipeline
 422 %*                                                                      *
 423 %************************************************************************
 424
 425                    --------------------------------
 426                         The compilation proper
 427                    --------------------------------
 428
 429
 430 It's the task of the compilation proper to compile Haskell, hs-boot and
 431 core files to either byte-code, hard-code (C, asm, Java, ect) or to
 432 nothing at all (the module is still parsed and type-checked. This
 433 feature is mostly used by IDE's and the likes).
 434 Compilation can happen in either 'one-shot', 'batch', 'nothing',
 435 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
 436 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
 437 targets byte-code.
 438 The modes are kept separate because of their different types and meanings.
 439 In 'one-shot' mode, we're only compiling a single file and can therefore
 440 discard the new ModIface and ModDetails. This is also the reason it only
 441 targets hard-code; compiling to byte-code or nothing doesn't make sense
 442 when we discard the result.
 443 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
 444 and ModDetails. 'Batch' mode doesn't target byte-code since that require
 445 us to return the newly compiled byte-code.
 446 'Nothing' mode has exactly the same type as 'batch' mode but they're still
 447 kept separate. This is because compiling to nothing is fairly special: We
 448 don't output any interface files, we don't run the simplifier and we don't
 449 generate any code.
 450 'Interactive' mode is similar to 'batch' mode except that we return the
 451 compiled byte-code together with the ModIface and ModDetails.
 452
 453 Trying to compile a hs-boot file to byte-code will result in a run-time
 454 error. This is the only thing that isn't caught by the type-system.
 455
 456 \begin{code}
 457
 458 -- Status of a compilation to hard-code or nothing.
 459 data HscStatus' a
 460     = HscNoRecomp
 461     | HscRecomp
 462        Bool -- Has stub files.  This is a hack. We can't compile C files here
 463             -- since it's done in DriverPipeline. For now we just return True
 464             -- if we want the caller to compile them for us.
 465        a
 466
 467 -- This is a bit ugly.  Since we use a typeclass below and would like to avoid
 468 -- functional dependencies, we have to parameterise the typeclass over the
 469 -- result type.  Therefore we need to artificially distinguish some types.  We
 470 -- do this by adding type tags which will simply be ignored by the caller.
 471 type HscStatus         = HscStatus' ()
 472 type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
 473     -- INVARIANT: result is @Nothing@ <=> input was a boot file
 474
 475 type OneShotResult     = HscStatus
 476 type BatchResult       = (HscStatus, ModIface, ModDetails)
 477 type NothingResult     = (HscStatus, ModIface, ModDetails)
 478 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
 479
 480 -- FIXME: The old interface and module index are only using in 'batch' and
 481 --        'interactive' mode. They should be removed from 'oneshot' mode.
 482 type Compiler result =  HscEnv
 483                      -> ModSummary
 484                      -> Bool                -- True <=> source unchanged
 485                      -> Maybe ModIface      -- Old interface, if available
 486                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
 487                      -> IO result
 488
 489 data HsCompiler a
 490   = HsCompiler {
 491     -- | Called when no recompilation is necessary.
 492     hscNoRecomp :: ModIface
 493                 -> Hsc a,
 494
 495     -- | Called to recompile the module.
 496     hscRecompile :: ModSummary -> Maybe Fingerprint
 497                  -> Hsc a,
 498
 499     hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint
 500                -> Hsc a,
 501
 502     -- | Code generation for Boot modules.
 503     hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint
 504                      -> Hsc a,
 505
 506     -- | Code generation for normal modules.
 507     hscGenOutput :: ModGuts  -> ModSummary -> Maybe Fingerprint
 508                  -> Hsc a
 509   }
 510
 511 genericHscCompile :: HsCompiler a
 512                   -> (HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ())
 513                   -> HscEnv -> ModSummary -> Bool
 514                   -> Maybe ModIface -> Maybe (Int, Int)
 515                   -> IO a
 516 genericHscCompile compiler hscMessage hsc_env
 517                   mod_summary source_unchanged
 518                   mb_old_iface0 mb_mod_index
 519  = do
 520      (recomp_reqd, mb_checked_iface)
 521          <- {-# SCC "checkOldIface" #-}
 522             checkOldIface hsc_env mod_summary
 523                           source_unchanged mb_old_iface0
 524      -- save the interface that comes back from checkOldIface.
 525      -- In one-shot mode we don't have the old iface until this
 526      -- point, when checkOldIface reads it from the disk.
 527      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
 528      case mb_checked_iface of
 529        Just iface | not recomp_reqd
 530            -> do hscMessage hsc_env mb_mod_index False mod_summary
 531                  runHsc hsc_env $ hscNoRecomp compiler iface
 532        _otherwise
 533            -> do hscMessage hsc_env mb_mod_index True mod_summary
 534                  runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
 535
 536 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
 537 hscCheckRecompBackend compiler tc_result
 538                    hsc_env mod_summary source_unchanged mb_old_iface _m_of_n
 539   = do
 540      (recomp_reqd, mb_checked_iface)
 541          <- {-# SCC "checkOldIface" #-}
 542             checkOldIface hsc_env mod_summary
 543                           source_unchanged mb_old_iface
 544
 545      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
 546      case mb_checked_iface of
 547        Just iface | not recomp_reqd
 548            -> runHsc hsc_env $
 549                  hscNoRecomp compiler
 550                              iface{ mi_globals = Just (tcg_rdr_env tc_result) }
 551        _otherwise
 552            -> runHsc hsc_env $
 553                  hscBackend compiler tc_result mod_summary mb_old_hash
 554
 555 genericHscRecompile :: HsCompiler a
 556                     -> ModSummary -> Maybe Fingerprint
 557                     -> Hsc a
 558 genericHscRecompile compiler mod_summary mb_old_hash
 559   | ExtCoreFile <- ms_hsc_src mod_summary =
 560       panic "GHC does not currently support reading External Core files"
 561   | otherwise = do
 562       tc_result <- hscFileFrontEnd mod_summary
 563       hscBackend compiler tc_result mod_summary mb_old_hash
 564
 565 genericHscBackend :: HsCompiler a
 566                   -> TcGblEnv -> ModSummary -> Maybe Fingerprint
 567                   -> Hsc a
 568 genericHscBackend compiler tc_result mod_summary mb_old_hash
 569   | HsBootFile <- ms_hsc_src mod_summary =
 570       hscGenBootOutput compiler tc_result mod_summary mb_old_hash
 571   | otherwise = do
 572       guts <- hscDesugar' mod_summary tc_result
 573       hscGenOutput compiler guts mod_summary mb_old_hash
 574
 575 compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
 576 compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ =
 577   runHsc hsc_env $
 578     hscBackend comp tcg ms' Nothing
 579
 580 --------------------------------------------------------------
 581 -- Compilers
 582 --------------------------------------------------------------
 583
 584 hscOneShotCompiler :: HsCompiler OneShotResult
 585 hscOneShotCompiler =
 586   HsCompiler {
 587
 588     hscNoRecomp = \_old_iface -> do
 589       hsc_env <- getHscEnv
 590       liftIO $ dumpIfaceStats hsc_env
 591       return HscNoRecomp
 592
 593   , hscRecompile = genericHscRecompile hscOneShotCompiler
 594
 595   , hscBackend = \ tc_result mod_summary mb_old_hash -> do
 596        dflags <- getDynFlags
 597        case hscTarget dflags of
 598          HscNothing -> return (HscRecomp False ())
 599          _otherw    -> genericHscBackend hscOneShotCompiler
 600                                          tc_result mod_summary mb_old_hash
 601
 602   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 603        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
 604        hscWriteIface iface changed mod_summary
 605        return (HscRecomp False ())
 606
 607   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 608        guts <- hscSimplify' guts0
 609        (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface
 610        hscWriteIface iface changed mod_summary
 611        hasStub <- hscGenHardCode cgguts mod_summary
 612        return (HscRecomp hasStub ())
 613   }
 614
 615 -- Compile Haskell, boot and extCore in OneShot mode.
 616 hscCompileOneShot :: Compiler OneShotResult
 617 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
 618   = do
 619        -- One-shot mode needs a knot-tying mutable variable for interface
 620        -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
 621       type_env_var <- newIORef emptyNameEnv
 622       let
 623          mod = ms_mod mod_summary
 624          hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
 625       ---
 626       genericHscCompile hscOneShotCompiler
 627                         oneShotMsg hsc_env' mod_summary src_changed
 628                         mb_old_iface mb_i_of_n
 629
 630
 631 hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult
 632 hscOneShotBackendOnly = compilerBackend hscOneShotCompiler
 633
 634 --------------------------------------------------------------
 635
 636 hscBatchCompiler :: HsCompiler BatchResult
 637 hscBatchCompiler =
 638   HsCompiler {
 639
 640     hscNoRecomp = \iface -> do
 641        details <- genModDetails iface
 642        return (HscNoRecomp, iface, details)
 643
 644   , hscRecompile = genericHscRecompile hscBatchCompiler
 645
 646   , hscBackend = genericHscBackend hscBatchCompiler
 647
 648   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 649        (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
 650        hscWriteIface iface changed mod_summary
 651        return (HscRecomp False (), iface, details)
 652
 653   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 654        guts <- hscSimplify' guts0
 655        (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface
 656        hscWriteIface iface changed mod_summary
 657        hasStub <- hscGenHardCode cgguts mod_summary
 658        return (HscRecomp hasStub (), iface, details)
 659   }
 660
 661 -- Compile Haskell, boot and extCore in batch mode.
 662 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
 663 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
 664
 665 hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult
 666 hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler
 667
 668 --------------------------------------------------------------
 669
 670 hscInteractiveCompiler :: HsCompiler InteractiveResult
 671 hscInteractiveCompiler =
 672   HsCompiler {
 673     hscNoRecomp = \iface -> do
 674        details <- genModDetails iface
 675        return (HscNoRecomp, iface, details)
 676
 677   , hscRecompile = genericHscRecompile hscInteractiveCompiler
 678
 679   , hscBackend = genericHscBackend hscInteractiveCompiler
 680
 681   , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
 682        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 683        return (HscRecomp False Nothing, iface, details)
 684
 685   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 686        guts <- hscSimplify' guts0
 687        (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface
 688        hscInteractive (iface, details, cgguts) mod_summary
 689   }
 690
 691 -- Compile Haskell, extCore to bytecode.
 692 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
 693 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
 694
 695 hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult
 696 hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler
 697
 698 --------------------------------------------------------------
 699
 700 hscNothingCompiler :: HsCompiler NothingResult
 701 hscNothingCompiler =
 702   HsCompiler {
 703     hscNoRecomp = \iface -> do
 704        details <- genModDetails iface
 705        return (HscNoRecomp, iface, details)
 706
 707   , hscRecompile = genericHscRecompile hscNothingCompiler
 708
 709   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
 710        handleWarnings
 711        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 712        return (HscRecomp False (), iface, details)
 713
 714   , hscGenBootOutput = \_ _ _ ->
 715         panic "hscCompileNothing: hscGenBootOutput should not be called"
 716
 717   , hscGenOutput = \_ _ _ ->
 718         panic "hscCompileNothing: hscGenOutput should not be called"
 719   }
 720
 721 -- Type-check Haskell and .hs-boot only (no external core)
 722 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
 723 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
 724
 725 hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult
 726 hscNothingBackendOnly = compilerBackend hscNothingCompiler
 727
 728 --------------------------------------------------------------
 729 -- NoRecomp handlers
 730 --------------------------------------------------------------
 731
 732 genModDetails :: ModIface -> Hsc ModDetails
 733 genModDetails old_iface
 734   = do
 735       hsc_env <- getHscEnv
 736       new_details <- {-# SCC "tcRnIface" #-}
 737                      liftIO $ initIfaceCheck hsc_env $
 738                               typecheckIface old_iface
 739       liftIO $ dumpIfaceStats hsc_env
 740       return new_details
 741
 742 --------------------------------------------------------------
 743 -- Progress displayers.
 744 --------------------------------------------------------------
 745
 746 oneShotMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
 747 oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
 748          if recomp
 749             then return ()
 750             else compilationProgressMsg (hsc_dflags hsc_env) $
 751                      "compilation IS NOT required"
 752
 753 batchMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
 754 batchMsg hsc_env mb_mod_index recomp mod_summary
 755   = do
 756          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
 757                            (showModuleIndex mb_mod_index ++
 758                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
 759          if recomp
 760             then showMsg "Compiling "
 761             else if verbosity (hsc_dflags hsc_env) >= 2
 762                     then showMsg "Skipping  "
 763                     else return ()
 764
 765 --------------------------------------------------------------
 766 -- FrontEnds
 767 --------------------------------------------------------------
 768
 769 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
 770 hscFileFrontEnd mod_summary =
 771     do rdr_module <- hscParse' mod_summary
 772        hsc_env <- getHscEnv
 773        {-# SCC "Typecheck-Rename" #-}
 774          ioMsgMaybe $
 775              tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 776
 777 --------------------------------------------------------------
 778 -- Simplifiers
 779 --------------------------------------------------------------
 780
 781 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
 782 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
 783
 784 hscSimplify' :: ModGuts -> Hsc ModGuts
 785 hscSimplify' ds_result
 786   = do hsc_env <- getHscEnv
 787        {-# SCC "Core2Core" #-}
 788          liftIO $ core2core hsc_env ds_result
 789
 790 --------------------------------------------------------------
 791 -- Interface generators
 792 --------------------------------------------------------------
 793
 794 hscSimpleIface :: TcGblEnv
 795                -> Maybe Fingerprint
 796                -> Hsc (ModIface, Bool, ModDetails)
 797 hscSimpleIface tc_result mb_old_iface
 798   = do
 799        hsc_env <- getHscEnv
 800        details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
 801        (new_iface, no_change)
 802            <- {-# SCC "MkFinalIface" #-}
 803               ioMsgMaybe $
 804                 mkIfaceTc hsc_env mb_old_iface details tc_result
 805        -- And the answer is ...
 806        liftIO $ dumpIfaceStats hsc_env
 807        return (new_iface, no_change, details)
 808
 809 hscNormalIface :: ModGuts
 810                -> Maybe Fingerprint
 811                -> Hsc (ModIface, Bool, ModDetails, CgGuts)
 812 hscNormalIface simpl_result mb_old_iface
 813   = do
 814        hsc_env <- getHscEnv
 815        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
 816                              liftIO $ tidyProgram hsc_env simpl_result
 817
 818             -- BUILD THE NEW ModIface and ModDetails
 819             --  and emit external core if necessary
 820             -- This has to happen *after* code gen so that the back-end
 821             -- info has been set.  Not yet clear if it matters waiting
 822             -- until after code output
 823        (new_iface, no_change)
 824            <- {-# SCC "MkFinalIface" #-}
 825               ioMsgMaybe $
 826                    mkIface hsc_env mb_old_iface details simpl_result
 827
 828        -- Emit external core
 829        -- This should definitely be here and not after CorePrep,
 830        -- because CorePrep produces unqualified constructor wrapper declarations,
 831        -- so its output isn't valid External Core (without some preprocessing).
 832        liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
 833        liftIO $ dumpIfaceStats hsc_env
 834
 835             -- Return the prepared code.
 836        return (new_iface, no_change, details, cg_guts)
 837
 838 --------------------------------------------------------------
 839 -- BackEnd combinators
 840 --------------------------------------------------------------
 841
 842 hscWriteIface :: ModIface
 843               -> Bool
 844               -> ModSummary
 845               -> Hsc ()
 846
 847 hscWriteIface iface no_change mod_summary
 848     = do dflags <- getDynFlags
 849          unless no_change
 850            $ liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
 851
 852 -- | Compile to hard-code.
 853 hscGenHardCode :: CgGuts -> ModSummary
 854                -> Hsc Bool -- ^ @True@ <=> stub.c exists
 855 hscGenHardCode cgguts mod_summary
 856   = do
 857     hsc_env <- getHscEnv
 858     liftIO $ do
 859          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 860                      -- From now on, we just use the bits we need.
 861                      cg_module   = this_mod,
 862                      cg_binds    = core_binds,
 863                      cg_tycons   = tycons,
 864                      cg_dir_imps = dir_imps,
 865                      cg_foreign  = foreign_stubs,
 866                      cg_dep_pkgs = dependencies,
 867                      cg_hpc_info = hpc_info } = cgguts
 868              dflags = hsc_dflags hsc_env
 869              location = ms_location mod_summary
 870              data_tycons = filter isDataTyCon tycons
 871              -- cg_tycons includes newtypes, for the benefit of External Core,
 872              -- but we don't generate any code for newtypes
 873
 874          -------------------
 875          -- PREPARE FOR CODE GENERATION
 876          -- Do saturation and convert to A-normal form
 877          prepd_binds <- {-# SCC "CorePrep" #-}
 878                         corePrepPgm dflags core_binds data_tycons ;
 879          -----------------  Convert to STG ------------------
 880          (stg_binds, cost_centre_info)
 881              <- {-# SCC "CoreToStg" #-}
 882                 myCoreToStg dflags this_mod prepd_binds
 883
 884          ------------------  Code generation ------------------
 885
 886          cmms <- if dopt Opt_TryNewCodeGen dflags
 887                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
 888                                  dir_imps cost_centre_info
 889                                  stg_binds hpc_info
 890                          return cmms
 891                  else {-# SCC "CodeGen" #-}
 892                        codeGen dflags this_mod data_tycons
 893                                dir_imps cost_centre_info
 894                                stg_binds hpc_info
 895
 896          --- Optionally run experimental Cmm transformations ---
 897          cmms <- optionallyConvertAndOrCPS hsc_env cmms
 898                  -- unless certain dflags are on, the identity function
 899          ------------------  Code output -----------------------
 900          rawcmms <- cmmToRawCmm cmms
 901          dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms)
 902          (_stub_h_exists, stub_c_exists)
 903              <- codeOutput dflags this_mod location foreign_stubs
 904                 dependencies rawcmms
 905          return stub_c_exists
 906
 907 hscInteractive :: (ModIface, ModDetails, CgGuts)
 908                -> ModSummary
 909                -> Hsc (InteractiveStatus, ModIface, ModDetails)
 910 #ifdef GHCI
 911 hscInteractive (iface, details, cgguts) mod_summary
 912     = do
 913          dflags <- getDynFlags
 914          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 915                      -- From now on, we just use the bits we need.
 916                      cg_module   = this_mod,
 917                      cg_binds    = core_binds,
 918                      cg_tycons   = tycons,
 919                      cg_foreign  = foreign_stubs,
 920                      cg_modBreaks = mod_breaks } = cgguts
 921
 922              location = ms_location mod_summary
 923              data_tycons = filter isDataTyCon tycons
 924              -- cg_tycons includes newtypes, for the benefit of External Core,
 925              -- but we don't generate any code for newtypes
 926
 927          -------------------
 928          -- PREPARE FOR CODE GENERATION
 929          -- Do saturation and convert to A-normal form
 930          prepd_binds <- {-# SCC "CorePrep" #-}
 931                         liftIO $ corePrepPgm dflags core_binds data_tycons ;
 932          -----------------  Generate byte code ------------------
 933          comp_bc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks
 934          ------------------ Create f-x-dynamic C-side stuff ---
 935          (_istub_h_exists, istub_c_exists)
 936              <- liftIO $ outputForeignStubs dflags this_mod
 937                                             location foreign_stubs
 938          return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
 939                 , iface, details)
 940 #else
 941 hscInteractive _ _ = panic "GHC not compiled with interpreter"
 942 #endif
 943
 944 ------------------------------
 945
 946 hscCompileCmmFile :: HscEnv -> FilePath -> IO ()
 947 hscCompileCmmFile hsc_env filename
 948   = runHsc hsc_env $ do
 949       let dflags = hsc_dflags hsc_env
 950       cmm <- ioMsgMaybe $ parseCmmFile dflags filename
 951       liftIO $ do
 952         cmms <- optionallyConvertAndOrCPS hsc_env [cmm]
 953         rawCmms <- cmmToRawCmm cmms
 954         _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
 955         return ()
 956   where
 957         no_mod = panic "hscCmmFile: no_mod"
 958         no_loc = ModLocation{ ml_hs_file  = Just filename,
 959                               ml_hi_file  = panic "hscCmmFile: no hi file",
 960                               ml_obj_file = panic "hscCmmFile: no obj file" }
 961
 962 -------------------- Stuff for new code gen ---------------------
 963
 964 tryNewCodeGen   :: HscEnv -> Module -> [TyCon] -> [Module]
 965                 -> CollectedCCs
 966                 -> [(StgBinding,[(Id,[Id])])]
 967                 -> HpcInfo
 968                 -> IO [Cmm]
 969 tryNewCodeGen hsc_env this_mod data_tycons imported_mods
 970               cost_centre_info stg_binds hpc_info =
 971   do    { let dflags = hsc_dflags hsc_env
 972         ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods
 973                          cost_centre_info stg_binds hpc_info
 974         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
 975                 (pprCmms prog)
 976
 977         ; prog <- return $ map runCmmContFlowOpts prog
 978                 -- Control flow optimisation
 979
 980         -- We are building a single SRT for the entire module, so
 981         -- we must thread it through all the procedures as we cps-convert them.
 982         ; us <- mkSplitUniqSupply 'S'
 983         ; let topSRT = initUs_ us emptySRT
 984         ; (topSRT, prog) <- foldM (protoCmmCPS hsc_env) (topSRT, []) prog
 985                 -- The main CPS conversion
 986
 987         ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog)
 988                 -- Control flow optimisation, again
 989
 990         ; let prog' = map cmmOfZgraph prog
 991         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
 992         ; return prog' }
 993
 994
 995 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
 996 optionallyConvertAndOrCPS hsc_env cmms =
 997     do let dflags = hsc_dflags hsc_env
 998         --------  Optionally convert to and from zipper ------
 999        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
1000                then mapM (testCmmConversion hsc_env) cmms
1001                else return cmms
1002        return cmms
1003
1004
1005 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
1006 testCmmConversion hsc_env cmm =
1007     do let dflags = hsc_dflags hsc_env
1008        showPass dflags "CmmToCmm"
1009        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
1010        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
1011        us <- mkSplitUniqSupply 'C'
1012        let cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm
1013        let zgraph = initUs_ us cvtm
1014        us <- mkSplitUniqSupply 'S'
1015        let topSRT = initUs_ us emptySRT
1016        (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) zgraph
1017        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
1018        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
1019        showPass dflags "Convert from Z back to Cmm"
1020        let cvt = cmmOfZgraph $ runCmmContFlowOpts $ chosen_graph
1021        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
1022        return cvt
1023
1024 myCoreToStg :: DynFlags -> Module -> [CoreBind]
1025             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
1026                   , CollectedCCs) -- cost centre info (declared and used)
1027
1028 myCoreToStg dflags this_mod prepd_binds
1029  = do
1030       stg_binds <- {-# SCC "Core2Stg" #-}
1031              coreToStg (thisPackage dflags) prepd_binds
1032
1033       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
1034              stg2stg dflags this_mod stg_binds
1035
1036       return (stg_binds2, cost_centre_info)
1037 \end{code}
1038
1039
1040 %************************************************************************
1041 %*                                                                      *
1042 \subsection{Compiling a do-statement}
1043 %*                                                                      *
1044 %************************************************************************
1045
1046 When the UnlinkedBCOExpr is linked you get an HValue of type
1047         IO [HValue]
1048 When you run it you get a list of HValues that should be
1049 the same length as the list of names; add them to the ClosureEnv.
1050
1051 A naked expression returns a singleton Name [it].
1052
1053         What you type                   The IO [HValue] that hscStmt returns
1054         -------------                   ------------------------------------
1055         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1056                                         bindings: [x,y,...]
1057
1058         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1059                                         bindings: [x,y,...]
1060
1061         expr (of IO type)       ==>     expr >>= \ v -> return [v]
1062           [NB: result not printed]      bindings: [it]
1063
1064
1065         expr (of non-IO type,
1066           result showable)      ==>     let v = expr in print v >> return [v]
1067                                         bindings: [it]
1068
1069         expr (of non-IO type,
1070           result not showable)  ==>     error
1071
1072 \begin{code}
1073 #ifdef GHCI
1074 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
1075   :: HscEnv
1076   -> String                     -- The statement
1077   -> IO (Maybe ([Id], HValue))
1078      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
1079 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1080
1081 hscStmtWithLocation     -- Compile a stmt all the way to an HValue, but don't run it
1082   :: HscEnv
1083   -> String                     -- The statement
1084   -> String                     -- the source
1085   -> Int                        -- ^ starting line
1086   -> IO (Maybe ([Id], HValue))
1087      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
1088 hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
1089     maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1090     case maybe_stmt of
1091       Nothing -> return Nothing
1092       Just parsed_stmt -> do  -- The real stuff
1093
1094              -- Rename and typecheck it
1095         let icontext = hsc_IC hsc_env
1096         (ids, tc_expr) <- ioMsgMaybe $
1097                             tcRnStmt hsc_env icontext parsed_stmt
1098             -- Desugar it
1099         let rdr_env  = ic_rn_gbl_env icontext
1100             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
1101         ds_expr <- ioMsgMaybe $
1102                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1103         handleWarnings
1104
1105         -- Then desugar, code gen, and link it
1106         let src_span = srcLocSpan interactiveSrcLoc
1107         hsc_env <- getHscEnv
1108         hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1109
1110         return $ Just (ids, hval)
1111
1112 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1113 hscImport hsc_env str = runHsc hsc_env $ do
1114     (L _ (HsModule{hsmodImports=is})) <-
1115        hscParseThing parseModule str
1116     case is of
1117         [i] -> return (unLoc i)
1118         _ -> liftIO $ throwOneError $
1119                 mkPlainErrMsg noSrcSpan $
1120                     ptext (sLit "parse error in import declaration")
1121
1122 hscTcExpr       -- Typecheck an expression (but don't run it)
1123   :: HscEnv
1124   -> String                     -- The expression
1125   -> IO Type
1126
1127 hscTcExpr hsc_env expr = runHsc hsc_env $ do
1128     maybe_stmt <- hscParseStmt expr
1129     case maybe_stmt of
1130       Just (L _ (ExprStmt expr _ _)) ->
1131           ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
1132       _ ->
1133           liftIO $ throwIO $ mkSrcErr $ unitBag $
1134               mkPlainErrMsg noSrcSpan
1135                             (text "not an expression:" <+> quotes (text expr))
1136
1137 -- | Find the kind of a type
1138 hscKcType
1139   :: HscEnv
1140   -> String                     -- ^ The type
1141   -> IO Kind
1142
1143 hscKcType hsc_env str = runHsc hsc_env $ do
1144     ty <- hscParseType str
1145     ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) ty
1146
1147 #endif
1148 \end{code}
1149
1150 \begin{code}
1151 #ifdef GHCI
1152 hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
1153 hscParseStmt = hscParseThing parseStmt
1154
1155 hscParseStmtWithLocation :: String -> Int
1156                          -> String -> Hsc (Maybe (LStmt RdrName))
1157 hscParseStmtWithLocation source linenumber stmt =
1158   hscParseThingWithLocation source linenumber parseStmt stmt
1159
1160 hscParseType :: String -> Hsc (LHsType RdrName)
1161 hscParseType = hscParseThing parseType
1162 #endif
1163
1164 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1165 hscParseIdentifier hsc_env str = runHsc hsc_env $
1166                                    hscParseThing parseIdentifier str
1167
1168 hscParseThing :: (Outputable thing)
1169               => Lexer.P thing
1170               -> String
1171               -> Hsc thing
1172 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1173
1174 hscParseThingWithLocation :: (Outputable thing)
1175               => String -> Int
1176               -> Lexer.P thing
1177               -> String
1178               -> Hsc thing
1179 hscParseThingWithLocation source linenumber parser str
1180  = {-# SCC "Parser" #-} do
1181       dflags <- getDynFlags
1182       liftIO $ showPass dflags "Parser"
1183
1184       let buf = stringToStringBuffer str
1185           loc  = mkSrcLoc (fsLit source) linenumber 1
1186
1187       case unP parser (mkPState dflags buf loc) of
1188
1189         PFailed span err -> do
1190           let msg = mkPlainErrMsg span err
1191           liftIO $ throwIO (mkSrcErr (unitBag msg))
1192
1193         POk pst thing -> do
1194           logWarningsReportErrors (getMessages pst)
1195           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1196           return thing
1197 \end{code}
1198
1199 \begin{code}
1200 hscCompileCore :: HscEnv
1201                -> Bool
1202                -> ModSummary
1203                -> [CoreBind]
1204                -> IO ()
1205
1206 hscCompileCore hsc_env simplify mod_summary binds
1207   = runHsc hsc_env $ do
1208       let maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1209                                   | otherwise = return mod_guts
1210       guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds)
1211       (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
1212       hscWriteIface iface changed mod_summary
1213       _ <- hscGenHardCode cgguts mod_summary
1214       return ()
1215
1216 -- Makes a "vanilla" ModGuts.
1217 mkModGuts :: Module -> [CoreBind] -> ModGuts
1218 mkModGuts mod binds = ModGuts {
1219   mg_module = mod,
1220   mg_boot = False,
1221   mg_exports = [],
1222   mg_deps = noDependencies,
1223   mg_dir_imps = emptyModuleEnv,
1224   mg_used_names = emptyNameSet,
1225   mg_rdr_env = emptyGlobalRdrEnv,
1226   mg_fix_env = emptyFixityEnv,
1227   mg_types = emptyTypeEnv,
1228   mg_insts = [],
1229   mg_fam_insts = [],
1230   mg_rules = [],
1231   mg_vect_decls = [],
1232   mg_binds = binds,
1233   mg_foreign = NoStubs,
1234   mg_warns = NoWarnings,
1235   mg_anns = [],
1236   mg_hpc_info = emptyHpcInfo False,
1237   mg_modBreaks = emptyModBreaks,
1238   mg_vect_info = noVectInfo,
1239   mg_inst_env = emptyInstEnv,
1240   mg_fam_inst_env = emptyFamInstEnv
1241 }
1242 \end{code}
1243
1244 %************************************************************************
1245 %*                                                                      *
1246         Desugar, simplify, convert to bytecode, and link an expression
1247 %*                                                                      *
1248 %************************************************************************
1249
1250 \begin{code}
1251 #ifdef GHCI
1252 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1253 hscCompileCoreExpr hsc_env srcspan ds_expr
1254   | rtsIsProfiled
1255   = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1256           -- Otherwise you get a seg-fault when you run it
1257
1258   | otherwise = do
1259     let dflags = hsc_dflags hsc_env
1260     let lint_on = dopt Opt_DoCoreLinting dflags
1261
1262         -- Simplify it
1263     simpl_expr <- simplifyExpr dflags ds_expr
1264
1265         -- Tidy it (temporary, until coreSat does cloning)
1266     let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1267
1268         -- Prepare for codegen
1269     prepd_expr <- corePrepExpr dflags tidy_expr
1270
1271         -- Lint if necessary
1272         -- ToDo: improve SrcLoc
1273     when lint_on $
1274        let ictxt = hsc_IC hsc_env
1275            tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
1276        in
1277            case lintUnfolding noSrcLoc tyvars prepd_expr of
1278               Just err -> pprPanic "hscCompileCoreExpr" err
1279               Nothing  -> return ()
1280
1281           -- Convert to BCOs
1282     bcos <- coreExprToBCOs dflags prepd_expr
1283
1284         -- link it
1285     hval <- linkExpr hsc_env srcspan bcos
1286
1287     return hval
1288 #endif
1289 \end{code}
1290
1291
1292 %************************************************************************
1293 %*                                                                      *
1294         Statistics on reading interfaces
1295 %*                                                                      *
1296 %************************************************************************
1297
1298 \begin{code}
1299 dumpIfaceStats :: HscEnv -> IO ()
1300 dumpIfaceStats hsc_env
1301   = do  { eps <- readIORef (hsc_EPS hsc_env)
1302         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1303                     "Interface statistics"
1304                     (ifaceStats eps) }
1305   where
1306     dflags = hsc_dflags hsc_env
1307     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1308     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1309 \end{code}
1310
1311 %************************************************************************
1312 %*                                                                      *
1313         Progress Messages: Module i of n
1314 %*                                                                      *
1315 %************************************************************************
1316
1317 \begin{code}
1318 showModuleIndex :: Maybe (Int, Int) -> String
1319 showModuleIndex Nothing = ""
1320 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1321     where
1322         n_str = show n
1323         i_str = show i
1324         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1325 \end{code}