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