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