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, hscTcExpr, hscImport, hscKcType
  66     , hscCompileCoreExpr
  67 #endif
  68
  69     ) where
  70
  71 #ifdef GHCI
  72 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  73 import Linker           ( HValue, linkExpr )
  74 import CoreTidy         ( tidyExpr )
  75 import Type             ( Type )
  76 import TcType           ( tyVarsOfTypes )
  77 import PrelNames        ( iNTERACTIVE )
  78 import {- Kind parts of -} Type         ( Kind )
  79 import Id               ( idType )
  80 import CoreLint         ( lintUnfolding )
  81 import DsMeta           ( templateHaskellNames )
  82 import VarSet
  83 import VarEnv           ( emptyTidyEnv )
  84 import Panic
  85 #endif
  86
  87 import Id               ( Id )
  88 import Module           ( emptyModuleEnv, ModLocation(..), Module )
  89 import RdrName
  90 import HsSyn
  91 import CoreSyn
  92 import StringBuffer
  93 import Parser
  94 import Lexer hiding (getDynFlags)
  95 import SrcLoc
  96 import TcRnDriver
  97 import TcIface          ( typecheckIface )
  98 import TcRnMonad
  99 import RnNames          ( rnImports )
 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 Cmm              ( Cmm )
 117 import PprCmm           ( pprCmms )
 118 import CmmParse         ( parseCmmFile )
 119 import CmmBuildInfoTables
 120 import CmmCPS
 121 import CmmCPSZ
 122 import CmmInfo
 123 import OptimizationFuel ( initOptFuelState )
 124 import CmmCvt
 125 import CmmTx
 126 import CmmContFlowOpt
 127 import CodeOutput
 128 import NameEnv          ( emptyNameEnv )
 129 import NameSet          ( emptyNameSet )
 130 import InstEnv
 131 import FamInstEnv       ( emptyFamInstEnv )
 132 import Fingerprint      ( Fingerprint )
 133
 134 import DynFlags
 135 import ErrUtils
 136 import UniqSupply       ( mkSplitUniqSupply )
 137
 138 import MonadUtils
 139 import Outputable
 140 import HscStats         ( ppSourceStats )
 141 import HscTypes
 142 import MkExternalCore   ( emitExternalCore )
 143 import FastString
 144 import UniqFM           ( emptyUFM )
 145 import UniqSupply       ( initUs_ )
 146 import Bag
 147 import Exception
 148 -- import MonadUtils
 149
 150 import Control.Monad
 151 -- import System.IO
 152 import Data.IORef
 153 \end{code}
 154 #include "HsVersions.h"
 155
 156
 157 %************************************************************************
 158 %*                                                                      *
 159                 Initialisation
 160 %*                                                                      *
 161 %************************************************************************
 162
 163 \begin{code}
 164 newHscEnv :: DynFlags -> IO HscEnv
 165 newHscEnv dflags
 166   = do  { eps_var <- newIORef initExternalPackageState
 167         ; us      <- mkSplitUniqSupply 'r'
 168         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
 169         ; fc_var  <- newIORef emptyUFM
 170         ; mlc_var <- newIORef emptyModuleEnv
 171         ; optFuel <- initOptFuelState
 172         ; return (HscEnv { hsc_dflags = dflags,
 173                            hsc_targets = [],
 174                            hsc_mod_graph = [],
 175                            hsc_IC      = emptyInteractiveContext,
 176                            hsc_HPT     = emptyHomePackageTable,
 177                            hsc_EPS     = eps_var,
 178                            hsc_NC      = nc_var,
 179                            hsc_FC      = fc_var,
 180                            hsc_MLC     = mlc_var,
 181                            hsc_OptFuel = optFuel,
 182                            hsc_type_env_var = Nothing } ) }
 183
 184
 185 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
 186                         -- where templateHaskellNames are defined
 187 knownKeyNames = map getName wiredInThings
 188               ++ basicKnownKeyNames
 189 #ifdef GHCI
 190               ++ templateHaskellNames
 191 #endif
 192
 193 -- -----------------------------------------------------------------------------
 194 -- The Hsc monad: collecting warnings
 195
 196 newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
 197
 198 instance Monad Hsc where
 199   return a = Hsc $ \_ w -> return (a, w)
 200   Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
 201                                  case k a of
 202                                     Hsc k' -> k' e w1
 203
 204 instance MonadIO Hsc where
 205   liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
 206
 207 runHsc :: HscEnv -> Hsc a -> IO a
 208 runHsc hsc_env (Hsc hsc) = do
 209   (a, w) <- hsc hsc_env emptyBag
 210   printOrThrowWarnings (hsc_dflags hsc_env) w
 211   return a
 212
 213 getWarnings :: Hsc WarningMessages
 214 getWarnings = Hsc $ \_ w -> return (w, w)
 215
 216 clearWarnings :: Hsc ()
 217 clearWarnings = Hsc $ \_ _w -> return ((), emptyBag)
 218
 219 logWarnings :: WarningMessages -> Hsc ()
 220 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
 221
 222 getHscEnv :: Hsc HscEnv
 223 getHscEnv = Hsc $ \e w -> return (e, w)
 224
 225 getDynFlags :: Hsc DynFlags
 226 getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
 227
 228 handleWarnings :: Hsc ()
 229 handleWarnings = do
 230   dflags <- getDynFlags
 231   w <- getWarnings
 232   liftIO $ printOrThrowWarnings dflags w
 233   clearWarnings
 234
 235 -- | log warning in the monad, and if there are errors then
 236 -- throw a SourceError exception.
 237 logWarningsReportErrors :: Messages -> Hsc ()
 238 logWarningsReportErrors (warns,errs) = do
 239   logWarnings warns
 240   when (not (isEmptyBag errs)) $ do
 241     liftIO $ throwIO $ mkSrcErr errs
 242
 243 -- | Deal with errors and warnings returned by a compilation step
 244 --
 245 -- In order to reduce dependencies to other parts of the compiler, functions
 246 -- outside the "main" parts of GHC return warnings and errors as a parameter
 247 -- and signal success via by wrapping the result in a 'Maybe' type.  This
 248 -- function logs the returned warnings and propagates errors as exceptions
 249 -- (of type 'SourceError').
 250 --
 251 -- This function assumes the following invariants:
 252 --
 253 --  1. If the second result indicates success (is of the form 'Just x'),
 254 --     there must be no error messages in the first result.
 255 --
 256 --  2. If there are no error messages, but the second result indicates failure
 257 --     there should be warnings in the first result.  That is, if the action
 258 --     failed, it must have been due to the warnings (i.e., @-Werror@).
 259 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
 260 ioMsgMaybe ioA = do
 261   ((warns,errs), mb_r) <- liftIO $ ioA
 262   logWarnings warns
 263   case mb_r of
 264     Nothing -> liftIO $ throwIO (mkSrcErr errs)
 265     Just r  -> ASSERT( isEmptyBag errs ) return r
 266
 267 -- | like ioMsgMaybe, except that we ignore error messages and return
 268 -- 'Nothing' instead.
 269 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
 270 ioMsgMaybe' ioA = do
 271   ((warns,_errs), mb_r) <- liftIO $ ioA
 272   logWarnings warns
 273   return mb_r
 274
 275 -- -----------------------------------------------------------------------------
 276 -- | Lookup things in the compiler's environment
 277
 278 #ifdef GHCI
 279 hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
 280 hscTcRnLookupRdrName hsc_env rdr_name =
 281   runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
 282 #endif
 283
 284 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 285 hscTcRcLookupName hsc_env name =
 286   runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name
 287     -- ignore errors: the only error we're likely to get is
 288     -- "name not found", and the Maybe in the return type
 289     -- is used to indicate that.
 290
 291 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance]))
 292 hscTcRnGetInfo hsc_env name =
 293   runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name
 294
 295 #ifdef GHCI
 296 hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo])
 297 hscGetModuleExports hsc_env mdl =
 298   runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl
 299 #endif
 300
 301 -- -----------------------------------------------------------------------------
 302 -- | Rename some import declarations
 303
 304 hscRnImportDecls
 305         :: HscEnv
 306         -> Module
 307         -> [LImportDecl RdrName]
 308         -> IO GlobalRdrEnv
 309
 310 hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ do
 311   (_, r, _, _) <-
 312        ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
 313           rnImports import_decls
 314   return r
 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_cmmz "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 (runTx $ runCmmOpts cmmCfgOptsZ) 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 (protoCmmCPSZ hsc_env) (topSRT, []) prog
 986                 -- The main CPS conversion
 987
 988         ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (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          ---------  Optionally convert to CPS (MDA) -----------
1004        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
1005                   dopt Opt_RunCPS dflags
1006                then cmmCPS dflags cmms
1007                else return cmms
1008        return cmms
1009
1010
1011 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
1012 testCmmConversion hsc_env cmm =
1013     do let dflags = hsc_dflags hsc_env
1014        showPass dflags "CmmToCmm"
1015        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
1016        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
1017        us <- mkSplitUniqSupply 'C'
1018        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
1019        let cvtm = do g <- cmmToZgraph cmm
1020                      return $ cfopts g
1021        let zgraph = initUs_ us cvtm
1022        us <- mkSplitUniqSupply 'S'
1023        let topSRT = initUs_ us emptySRT
1024        (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
1025        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
1026        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
1027        showPass dflags "Convert from Z back to Cmm"
1028        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
1029        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
1030        return cvt
1031
1032 myCoreToStg :: DynFlags -> Module -> [CoreBind]
1033             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
1034                   , CollectedCCs) -- cost centre info (declared and used)
1035
1036 myCoreToStg dflags this_mod prepd_binds
1037  = do
1038       stg_binds <- {-# SCC "Core2Stg" #-}
1039              coreToStg (thisPackage dflags) prepd_binds
1040
1041       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
1042              stg2stg dflags this_mod stg_binds
1043
1044       return (stg_binds2, cost_centre_info)
1045 \end{code}
1046
1047
1048 %************************************************************************
1049 %*                                                                      *
1050 \subsection{Compiling a do-statement}
1051 %*                                                                      *
1052 %************************************************************************
1053
1054 When the UnlinkedBCOExpr is linked you get an HValue of type
1055         IO [HValue]
1056 When you run it you get a list of HValues that should be
1057 the same length as the list of names; add them to the ClosureEnv.
1058
1059 A naked expression returns a singleton Name [it].
1060
1061         What you type                   The IO [HValue] that hscStmt returns
1062         -------------                   ------------------------------------
1063         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1064                                         bindings: [x,y,...]
1065
1066         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1067                                         bindings: [x,y,...]
1068
1069         expr (of IO type)       ==>     expr >>= \ v -> return [v]
1070           [NB: result not printed]      bindings: [it]
1071
1072
1073         expr (of non-IO type,
1074           result showable)      ==>     let v = expr in print v >> return [v]
1075                                         bindings: [it]
1076
1077         expr (of non-IO type,
1078           result not showable)  ==>     error
1079
1080 \begin{code}
1081 #ifdef GHCI
1082 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
1083   :: HscEnv
1084   -> String                     -- The statement
1085   -> IO (Maybe ([Id], HValue))
1086      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
1087 hscStmt hsc_env stmt = runHsc hsc_env $ do
1088     maybe_stmt <- hscParseStmt stmt
1089     case maybe_stmt of
1090       Nothing -> return Nothing
1091       Just parsed_stmt -> do  -- The real stuff
1092
1093              -- Rename and typecheck it
1094         let icontext = hsc_IC hsc_env
1095         (ids, tc_expr) <- ioMsgMaybe $
1096                             tcRnStmt hsc_env icontext parsed_stmt
1097             -- Desugar it
1098         let rdr_env  = ic_rn_gbl_env icontext
1099             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
1100         ds_expr <- ioMsgMaybe $
1101                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1102         handleWarnings
1103
1104         -- Then desugar, code gen, and link it
1105         let src_span = srcLocSpan interactiveSrcLoc
1106         hsc_env <- getHscEnv
1107         hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1108
1109         return $ Just (ids, hval)
1110
1111 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1112 hscImport hsc_env str = runHsc hsc_env $ do
1113     (L _ (HsModule{hsmodImports=is})) <-
1114        hscParseThing parseModule str
1115     case is of
1116         [i] -> return (unLoc i)
1117         _ -> liftIO $ throwOneError $
1118                 mkPlainErrMsg noSrcSpan $
1119                     ptext (sLit "parse error in import declaration")
1120
1121 hscTcExpr       -- Typecheck an expression (but don't run it)
1122   :: HscEnv
1123   -> String                     -- The expression
1124   -> IO Type
1125
1126 hscTcExpr hsc_env expr = runHsc hsc_env $ do
1127     maybe_stmt <- hscParseStmt expr
1128     case maybe_stmt of
1129       Just (L _ (ExprStmt expr _ _)) ->
1130           ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
1131       _ ->
1132           liftIO $ throwIO $ mkSrcErr $ unitBag $
1133               mkPlainErrMsg noSrcSpan
1134                             (text "not an expression:" <+> quotes (text expr))
1135
1136 -- | Find the kind of a type
1137 hscKcType
1138   :: HscEnv
1139   -> String                     -- ^ The type
1140   -> IO Kind
1141
1142 hscKcType hsc_env str = runHsc hsc_env $ do
1143     ty <- hscParseType str
1144     ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) ty
1145
1146 #endif
1147 \end{code}
1148
1149 \begin{code}
1150 #ifdef GHCI
1151 hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
1152 hscParseStmt = hscParseThing parseStmt
1153
1154 hscParseType :: String -> Hsc (LHsType RdrName)
1155 hscParseType = hscParseThing parseType
1156 #endif
1157
1158 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1159 hscParseIdentifier hsc_env str = runHsc hsc_env $
1160                                    hscParseThing parseIdentifier str
1161
1162
1163 hscParseThing :: (Outputable thing)
1164               => Lexer.P thing
1165               -> String
1166               -> Hsc thing
1167
1168 hscParseThing parser str
1169  = {-# SCC "Parser" #-} do
1170       dflags <- getDynFlags
1171       liftIO $ showPass dflags "Parser"
1172
1173       let buf = stringToStringBuffer str
1174           loc = mkSrcLoc (fsLit "<interactive>") 1 1
1175
1176       case unP parser (mkPState dflags buf loc) of
1177
1178         PFailed span err -> do
1179           let msg = mkPlainErrMsg span err
1180           liftIO $ throwIO (mkSrcErr (unitBag msg))
1181
1182         POk pst thing -> do
1183           logWarningsReportErrors (getMessages pst)
1184           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1185           return thing
1186 \end{code}
1187
1188 \begin{code}
1189 hscCompileCore :: HscEnv
1190                -> Bool
1191                -> ModSummary
1192                -> [CoreBind]
1193                -> IO ()
1194
1195 hscCompileCore hsc_env simplify mod_summary binds
1196   = runHsc hsc_env $ do
1197       let maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1198                                   | otherwise = return mod_guts
1199       guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds)
1200       (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
1201       hscWriteIface iface changed mod_summary
1202       _ <- hscGenHardCode cgguts mod_summary
1203       return ()
1204
1205 -- Makes a "vanilla" ModGuts.
1206 mkModGuts :: Module -> [CoreBind] -> ModGuts
1207 mkModGuts mod binds = ModGuts {
1208   mg_module = mod,
1209   mg_boot = False,
1210   mg_exports = [],
1211   mg_deps = noDependencies,
1212   mg_dir_imps = emptyModuleEnv,
1213   mg_used_names = emptyNameSet,
1214   mg_rdr_env = emptyGlobalRdrEnv,
1215   mg_fix_env = emptyFixityEnv,
1216   mg_types = emptyTypeEnv,
1217   mg_insts = [],
1218   mg_fam_insts = [],
1219   mg_rules = [],
1220   mg_binds = binds,
1221   mg_foreign = NoStubs,
1222   mg_warns = NoWarnings,
1223   mg_anns = [],
1224   mg_hpc_info = emptyHpcInfo False,
1225   mg_modBreaks = emptyModBreaks,
1226   mg_vect_info = noVectInfo,
1227   mg_inst_env = emptyInstEnv,
1228   mg_fam_inst_env = emptyFamInstEnv
1229 }
1230 \end{code}
1231
1232 %************************************************************************
1233 %*                                                                      *
1234         Desugar, simplify, convert to bytecode, and link an expression
1235 %*                                                                      *
1236 %************************************************************************
1237
1238 \begin{code}
1239 #ifdef GHCI
1240 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1241 hscCompileCoreExpr hsc_env srcspan ds_expr
1242   | rtsIsProfiled
1243   = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1244           -- Otherwise you get a seg-fault when you run it
1245
1246   | otherwise = do
1247     let dflags = hsc_dflags hsc_env
1248     let lint_on = dopt Opt_DoCoreLinting dflags
1249
1250         -- Simplify it
1251     simpl_expr <- simplifyExpr dflags ds_expr
1252
1253         -- Tidy it (temporary, until coreSat does cloning)
1254     let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1255
1256         -- Prepare for codegen
1257     prepd_expr <- corePrepExpr dflags tidy_expr
1258
1259         -- Lint if necessary
1260         -- ToDo: improve SrcLoc
1261     if lint_on then
1262        let ictxt = hsc_IC hsc_env
1263            tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
1264        in
1265            case lintUnfolding noSrcLoc tyvars prepd_expr of
1266               Just err -> pprPanic "hscCompileCoreExpr" err
1267               Nothing  -> return ()
1268     else
1269        return ()
1270
1271           -- Convert to BCOs
1272     bcos <- coreExprToBCOs dflags prepd_expr
1273
1274         -- link it
1275     hval <- linkExpr hsc_env srcspan bcos
1276
1277     return hval
1278 #endif
1279 \end{code}
1280
1281
1282 %************************************************************************
1283 %*                                                                      *
1284         Statistics on reading interfaces
1285 %*                                                                      *
1286 %************************************************************************
1287
1288 \begin{code}
1289 dumpIfaceStats :: HscEnv -> IO ()
1290 dumpIfaceStats hsc_env
1291   = do  { eps <- readIORef (hsc_EPS hsc_env)
1292         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1293                     "Interface statistics"
1294                     (ifaceStats eps) }
1295   where
1296     dflags = hsc_dflags hsc_env
1297     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1298     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1299 \end{code}
1300
1301 %************************************************************************
1302 %*                                                                      *
1303         Progress Messages: Module i of n
1304 %*                                                                      *
1305 %************************************************************************
1306
1307 \begin{code}
1308 showModuleIndex :: Maybe (Int, Int) -> String
1309 showModuleIndex Nothing = ""
1310 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1311     where
1312         n_str = show n
1313         i_str = show i
1314         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1315 \end{code}