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