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