compiler/main/HscMain.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \begin{code}
   5 -- | Main driver for the compiling plain Haskell source code.
   6 --
   7 -- This module implements compilation of a Haskell-only source file.  It is
   8 -- /not/ concerned with preprocessing of source files; this is handled in
   9 -- "DriverPipeline".
  10 --
  11 module HscMain
  12     ( newHscEnv, hscCmmFile
  13     , hscParseIdentifier
  14     , hscSimplify
  15     , hscNormalIface, hscWriteIface, hscGenHardCode
  16 #ifdef GHCI
  17     , hscStmt, hscTcExpr, hscImport, hscKcType
  18     , compileExpr
  19 #endif
  20     , HsCompiler(..)
  21     , hscOneShotCompiler, hscNothingCompiler
  22     , hscInteractiveCompiler, hscBatchCompiler
  23     , hscCompileOneShot     -- :: Compiler HscStatus
  24     , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
  25     , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
  26     , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
  27     , hscCheckRecompBackend
  28     , HscStatus' (..)
  29     , InteractiveStatus, HscStatus
  30
  31     -- The new interface
  32     , hscParse
  33     , hscTypecheck
  34     , hscTypecheckRename
  35     , hscDesugar
  36     , makeSimpleIface
  37     , makeSimpleDetails
  38     ) where
  39
  40 #ifdef GHCI
  41 import CodeOutput       ( outputForeignStubs )
  42 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  43 import Linker           ( HValue, linkExpr )
  44 import CoreTidy         ( tidyExpr )
  45 import CorePrep         ( corePrepExpr )
  46 import Desugar          ( deSugarExpr )
  47 import SimplCore        ( simplifyExpr )
  48 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnType )
  49 import Type             ( Type )
  50 import PrelNames        ( iNTERACTIVE )
  51 import {- Kind parts of -} Type         ( Kind )
  52 import CoreLint         ( lintUnfolding )
  53 import DsMeta           ( templateHaskellNames )
  54 import SrcLoc           ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
  55 import VarSet
  56 import VarEnv           ( emptyTidyEnv )
  57 #endif
  58
  59 import Id               ( Id )
  60 import Module           ( emptyModuleEnv, ModLocation(..), Module )
  61 import RdrName
  62 import HsSyn
  63 import CoreSyn
  64 import SrcLoc           ( Located(..) )
  65 import StringBuffer
  66 import Parser
  67 import Lexer
  68 import SrcLoc           ( mkSrcLoc )
  69 import TcRnDriver       ( tcRnModule )
  70 import TcIface          ( typecheckIface )
  71 import TcRnMonad        ( initIfaceCheck, TcGblEnv(..) )
  72 import IfaceEnv         ( initNameCache )
  73 import LoadIface        ( ifaceStats, initExternalPackageState )
  74 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
  75 import MkIface
  76 import Desugar          ( deSugar )
  77 import SimplCore        ( core2core )
  78 import TidyPgm
  79 import CorePrep         ( corePrepPgm )
  80 import CoreToStg        ( coreToStg )
  81 import qualified StgCmm ( codeGen )
  82 import StgSyn
  83 import CostCentre
  84 import TyCon            ( TyCon, isDataTyCon )
  85 import Name             ( Name, NamedThing(..) )
  86 import SimplStg         ( stg2stg )
  87 import CodeGen          ( codeGen )
  88 import Cmm              ( Cmm )
  89 import PprCmm           ( pprCmms )
  90 import CmmParse         ( parseCmmFile )
  91 import CmmBuildInfoTables
  92 import CmmCPS
  93 import CmmCPSZ
  94 import CmmInfo
  95 import OptimizationFuel ( initOptFuelState )
  96 import CmmCvt
  97 import CmmTx
  98 import CmmContFlowOpt
  99 import CodeOutput       ( codeOutput )
 100 import NameEnv          ( emptyNameEnv )
 101 import Fingerprint      ( Fingerprint )
 102
 103 import DynFlags
 104 import ErrUtils
 105 import UniqSupply       ( mkSplitUniqSupply )
 106
 107 import Outputable
 108 import HscStats         ( ppSourceStats )
 109 import HscTypes
 110 import MkExternalCore   ( emitExternalCore )
 111 import FastString
 112 import UniqFM           ( emptyUFM )
 113 import UniqSupply       ( initUs_ )
 114 import Bag              ( unitBag )
 115 import Exception
 116 -- import MonadUtils
 117
 118 import Control.Monad
 119 -- import System.IO
 120 import Data.IORef
 121 \end{code}
 122 #include "HsVersions.h"
 123
 124
 125 %************************************************************************
 126 %*                                                                      *
 127                 Initialisation
 128 %*                                                                      *
 129 %************************************************************************
 130
 131 \begin{code}
 132 newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv
 133 newHscEnv callbacks dflags
 134   = do  { eps_var <- newIORef initExternalPackageState
 135         ; us      <- mkSplitUniqSupply 'r'
 136         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
 137         ; fc_var  <- newIORef emptyUFM
 138         ; mlc_var <- newIORef emptyModuleEnv
 139         ; optFuel <- initOptFuelState
 140         ; return (HscEnv { hsc_dflags = dflags,
 141                            hsc_callbacks = callbacks,
 142                            hsc_targets = [],
 143                            hsc_mod_graph = [],
 144                            hsc_IC      = emptyInteractiveContext,
 145                            hsc_HPT     = emptyHomePackageTable,
 146                            hsc_EPS     = eps_var,
 147                            hsc_NC      = nc_var,
 148                            hsc_FC      = fc_var,
 149                            hsc_MLC     = mlc_var,
 150                            hsc_OptFuel = optFuel,
 151                            hsc_type_env_var = Nothing,
 152                            hsc_global_rdr_env = emptyGlobalRdrEnv,
 153                            hsc_global_type_env = emptyNameEnv } ) }
 154
 155
 156 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
 157                         -- where templateHaskellNames are defined
 158 knownKeyNames = map getName wiredInThings
 159               ++ basicKnownKeyNames
 160 #ifdef GHCI
 161               ++ templateHaskellNames
 162 #endif
 163 \end{code}
 164
 165
 166 \begin{code}
 167 -- | parse a file, returning the abstract syntax
 168 hscParse :: GhcMonad m =>
 169             ModSummary
 170          -> m (Located (HsModule RdrName))
 171 hscParse mod_summary = do
 172    hsc_env <- getSession
 173    let dflags        = hsc_dflags hsc_env
 174        src_filename  = ms_hspp_file mod_summary
 175        maybe_src_buf = ms_hspp_buf  mod_summary
 176    --------------------------  Parser  ----------------
 177    liftIO $ showPass dflags "Parser"
 178    {-# SCC "Parser" #-} do
 179
 180         -- sometimes we already have the buffer in memory, perhaps
 181         -- because we needed to parse the imports out of it, or get the
 182         -- module name.
 183    buf <- case maybe_src_buf of
 184             Just b  -> return b
 185             Nothing -> liftIO $ hGetStringBuffer src_filename
 186
 187    let loc  = mkSrcLoc (mkFastString src_filename) 1 1
 188
 189    case unP parseModule (mkPState dflags buf loc) of
 190      PFailed span err ->
 191          throwOneError (mkPlainErrMsg span err)
 192
 193      POk pst rdr_module -> do
 194          let ms@(warns,errs) = getMessages pst
 195          logWarnings warns
 196          if errorsFound dflags ms then
 197            liftIO $ throwIO $ mkSrcErr errs
 198           else liftIO $ do
 199            dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 200            dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 201                                (ppSourceStats False rdr_module) ;
 202            return rdr_module
 203           -- ToDo: free the string buffer later.
 204
 205 -- | Rename and typecheck a module
 206 hscTypecheck :: GhcMonad m =>
 207                 ModSummary -> Located (HsModule RdrName)
 208              -> m TcGblEnv
 209 hscTypecheck mod_summary rdr_module = do
 210       hsc_env <- getSession
 211       r <- {-# SCC "Typecheck-Rename" #-}
 212            ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 213       return r
 214
 215 -- XXX: should this really be a Maybe X?  Check under which circumstances this
 216 -- can become a Nothing and decide whether this should instead throw an
 217 -- exception/signal an error.
 218 type RenamedStuff =
 219         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
 220                 Maybe LHsDocString))
 221
 222 -- | Rename and typecheck a module, additionally returning the renamed syntax
 223 hscTypecheckRename ::
 224        GhcMonad m =>
 225        ModSummary -> Located (HsModule RdrName)
 226     -> m (TcGblEnv, RenamedStuff)
 227 hscTypecheckRename mod_summary rdr_module = do
 228     hsc_env <- getSession
 229     tc_result
 230           <- {-# SCC "Typecheck-Rename" #-}
 231              ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
 232
 233     let -- This 'do' is in the Maybe monad!
 234         rn_info = do { decl <- tcg_rn_decls tc_result
 235                      ; let imports = tcg_rn_imports tc_result
 236                            exports = tcg_rn_exports tc_result
 237                            doc_hdr  = tcg_doc_hdr tc_result
 238                      ; return (decl,imports,exports,doc_hdr) }
 239
 240     return (tc_result, rn_info)
 241
 242 -- | Convert a typechecked module to Core
 243 hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts
 244 hscDesugar mod_summary tc_result =
 245   withSession $ \hsc_env ->
 246     ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result
 247
 248 -- | Make a 'ModIface' from the results of typechecking.  Used when
 249 -- not optimising, and the interface doesn't need to contain any
 250 -- unfoldings or other cross-module optimisation info.
 251 -- ToDo: the old interface is only needed to get the version numbers,
 252 -- we should use fingerprint versions instead.
 253 makeSimpleIface :: GhcMonad m =>
 254                    Maybe ModIface -> TcGblEnv -> ModDetails
 255                 -> m (ModIface,Bool)
 256 makeSimpleIface maybe_old_iface tc_result details =
 257   withSession $ \hsc_env ->
 258   ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
 259
 260 -- | Make a 'ModDetails' from the results of typechecking.  Used when
 261 -- typechecking only, as opposed to full compilation.
 262 makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails
 263 makeSimpleDetails tc_result =
 264     withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result
 265 \end{code}
 266
 267 %************************************************************************
 268 %*                                                                      *
 269                 The main compiler pipeline
 270 %*                                                                      *
 271 %************************************************************************
 272
 273                    --------------------------------
 274                         The compilation proper
 275                    --------------------------------
 276
 277
 278 It's the task of the compilation proper to compile Haskell, hs-boot and
 279 core files to either byte-code, hard-code (C, asm, Java, ect) or to
 280 nothing at all (the module is still parsed and type-checked. This
 281 feature is mostly used by IDE's and the likes).
 282 Compilation can happen in either 'one-shot', 'batch', 'nothing',
 283 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
 284 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
 285 targets byte-code.
 286 The modes are kept separate because of their different types and meanings.
 287 In 'one-shot' mode, we're only compiling a single file and can therefore
 288 discard the new ModIface and ModDetails. This is also the reason it only
 289 targets hard-code; compiling to byte-code or nothing doesn't make sense
 290 when we discard the result.
 291 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
 292 and ModDetails. 'Batch' mode doesn't target byte-code since that require
 293 us to return the newly compiled byte-code.
 294 'Nothing' mode has exactly the same type as 'batch' mode but they're still
 295 kept separate. This is because compiling to nothing is fairly special: We
 296 don't output any interface files, we don't run the simplifier and we don't
 297 generate any code.
 298 'Interactive' mode is similar to 'batch' mode except that we return the
 299 compiled byte-code together with the ModIface and ModDetails.
 300
 301 Trying to compile a hs-boot file to byte-code will result in a run-time
 302 error. This is the only thing that isn't caught by the type-system.
 303
 304 \begin{code}
 305
 306 -- Status of a compilation to hard-code or nothing.
 307 data HscStatus' a
 308     = HscNoRecomp
 309     | HscRecomp
 310        Bool -- Has stub files.  This is a hack. We can't compile C files here
 311             -- since it's done in DriverPipeline. For now we just return True
 312             -- if we want the caller to compile them for us.
 313        a
 314
 315 -- This is a bit ugly.  Since we use a typeclass below and would like to avoid
 316 -- functional dependencies, we have to parameterise the typeclass over the
 317 -- result type.  Therefore we need to artificially distinguish some types.  We
 318 -- do this by adding type tags which will simply be ignored by the caller.
 319 type HscStatus         = HscStatus' ()
 320 type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
 321     -- INVARIANT: result is @Nothing@ <=> input was a boot file
 322
 323 type OneShotResult     = HscStatus
 324 type BatchResult       = (HscStatus, ModIface, ModDetails)
 325 type NothingResult     = (HscStatus, ModIface, ModDetails)
 326 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
 327
 328 -- FIXME: The old interface and module index are only using in 'batch' and
 329 --        'interactive' mode. They should be removed from 'oneshot' mode.
 330 type Compiler result =  GhcMonad m =>
 331                         HscEnv
 332                      -> ModSummary
 333                      -> Bool                -- True <=> source unchanged
 334                      -> Maybe ModIface      -- Old interface, if available
 335                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
 336                      -> m result
 337
 338 data HsCompiler a
 339   = HsCompiler {
 340     -- | Called when no recompilation is necessary.
 341     hscNoRecomp :: GhcMonad m =>
 342                    ModIface -> m a,
 343
 344     -- | Called to recompile the module.
 345     hscRecompile :: GhcMonad m =>
 346                     ModSummary -> Maybe Fingerprint -> m a,
 347
 348     hscBackend :: GhcMonad m =>
 349                   TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
 350
 351     -- | Code generation for Boot modules.
 352     hscGenBootOutput :: GhcMonad m =>
 353                         TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
 354
 355     -- | Code generation for normal modules.
 356     hscGenOutput :: GhcMonad m =>
 357                     ModGuts  -> ModSummary -> Maybe Fingerprint -> m a
 358   }
 359
 360 genericHscCompile :: GhcMonad m =>
 361                      HsCompiler a
 362                   -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
 363                   -> HscEnv -> ModSummary -> Bool
 364                   -> Maybe ModIface -> Maybe (Int, Int)
 365                   -> m a
 366 genericHscCompile compiler hscMessage
 367                   hsc_env mod_summary source_unchanged
 368                   mb_old_iface0 mb_mod_index =
 369    withTempSession (\_ -> hsc_env) $ do
 370      (recomp_reqd, mb_checked_iface)
 371          <- {-# SCC "checkOldIface" #-}
 372             liftIO $ checkOldIface hsc_env mod_summary
 373                                    source_unchanged mb_old_iface0
 374      -- save the interface that comes back from checkOldIface.
 375      -- In one-shot mode we don't have the old iface until this
 376      -- point, when checkOldIface reads it from the disk.
 377      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
 378      case mb_checked_iface of
 379        Just iface | not recomp_reqd
 380            -> do hscMessage mb_mod_index False mod_summary
 381                  hscNoRecomp compiler iface
 382        _otherwise
 383            -> do hscMessage mb_mod_index True mod_summary
 384                  hscRecompile compiler mod_summary mb_old_hash
 385
 386 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
 387 hscCheckRecompBackend compiler tc_result
 388                    hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
 389    withTempSession (\_ -> hsc_env) $ do
 390      (recomp_reqd, mb_checked_iface)
 391          <- {-# SCC "checkOldIface" #-}
 392             liftIO $ checkOldIface hsc_env mod_summary
 393                                    source_unchanged mb_old_iface
 394
 395      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
 396      case mb_checked_iface of
 397        Just iface | not recomp_reqd
 398            -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
 399        _otherwise
 400            -> hscBackend compiler tc_result mod_summary mb_old_hash
 401
 402 genericHscRecompile :: GhcMonad m =>
 403                        HsCompiler a
 404                     -> ModSummary -> Maybe Fingerprint
 405                     -> m a
 406 genericHscRecompile compiler mod_summary mb_old_hash
 407   | ExtCoreFile <- ms_hsc_src mod_summary =
 408       panic "GHC does not currently support reading External Core files"
 409   | otherwise = do
 410       tc_result <- hscFileFrontEnd mod_summary
 411       hscBackend compiler tc_result mod_summary mb_old_hash
 412
 413 genericHscBackend :: GhcMonad m =>
 414                      HsCompiler a
 415                   -> TcGblEnv -> ModSummary -> Maybe Fingerprint
 416                   -> m a
 417 genericHscBackend compiler tc_result mod_summary mb_old_hash
 418   | HsBootFile <- ms_hsc_src mod_summary =
 419       hscGenBootOutput compiler tc_result mod_summary mb_old_hash
 420   | otherwise = do
 421       guts <- hscDesugar mod_summary tc_result
 422       hscGenOutput compiler guts mod_summary mb_old_hash
 423
 424 --------------------------------------------------------------
 425 -- Compilers
 426 --------------------------------------------------------------
 427
 428 hscOneShotCompiler :: HsCompiler OneShotResult
 429 hscOneShotCompiler =
 430   HsCompiler {
 431
 432     hscNoRecomp = \_old_iface -> do
 433       withSession (liftIO . dumpIfaceStats)
 434       return HscNoRecomp
 435
 436   , hscRecompile = genericHscRecompile hscOneShotCompiler
 437
 438   , hscBackend = \ tc_result mod_summary mb_old_hash -> do
 439        hsc_env <- getSession
 440        case hscTarget (hsc_dflags hsc_env) of
 441          HscNothing -> return (HscRecomp False ())
 442          _otherw    -> genericHscBackend hscOneShotCompiler
 443                                          tc_result mod_summary mb_old_hash
 444
 445   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 446        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
 447        hscWriteIface iface changed mod_summary
 448        return (HscRecomp False ())
 449
 450   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 451        guts <- hscSimplify guts0
 452        (iface, changed, _details, cgguts)
 453            <- hscNormalIface guts mb_old_iface
 454        hscWriteIface iface changed mod_summary
 455        hasStub <- hscGenHardCode cgguts mod_summary
 456        return (HscRecomp hasStub ())
 457   }
 458
 459 -- Compile Haskell, boot and extCore in OneShot mode.
 460 hscCompileOneShot :: Compiler OneShotResult
 461 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
 462        -- One-shot mode needs a knot-tying mutable variable for interface
 463        -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
 464       type_env_var <- liftIO $ newIORef emptyNameEnv
 465       let
 466          mod = ms_mod mod_summary
 467          hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
 468       ---
 469       genericHscCompile hscOneShotCompiler
 470                         oneShotMsg hsc_env' mod_summary src_changed
 471                         mb_old_iface mb_i_of_n
 472
 473
 474 --------------------------------------------------------------
 475
 476 hscBatchCompiler :: HsCompiler BatchResult
 477 hscBatchCompiler =
 478   HsCompiler {
 479
 480     hscNoRecomp = \iface -> do
 481        details <- genModDetails iface
 482        return (HscNoRecomp, iface, details)
 483
 484   , hscRecompile = genericHscRecompile hscBatchCompiler
 485
 486   , hscBackend = genericHscBackend hscBatchCompiler
 487
 488   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 489        (iface, changed, details)
 490            <- hscSimpleIface tc_result mb_old_iface
 491        hscWriteIface iface changed mod_summary
 492        return (HscRecomp False (), iface, details)
 493
 494   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 495        guts <- hscSimplify guts0
 496        (iface, changed, details, cgguts)
 497            <- hscNormalIface guts mb_old_iface
 498        hscWriteIface iface changed mod_summary
 499        hasStub <- hscGenHardCode cgguts mod_summary
 500        return (HscRecomp hasStub (), iface, details)
 501   }
 502
 503 -- Compile Haskell, boot and extCore in batch mode.
 504 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
 505 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
 506
 507 --------------------------------------------------------------
 508
 509 hscInteractiveCompiler :: HsCompiler InteractiveResult
 510 hscInteractiveCompiler =
 511   HsCompiler {
 512     hscNoRecomp = \iface -> do
 513        details <- genModDetails iface
 514        return (HscNoRecomp, iface, details)
 515
 516   , hscRecompile = genericHscRecompile hscInteractiveCompiler
 517
 518   , hscBackend = genericHscBackend hscInteractiveCompiler
 519
 520   , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
 521        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 522        return (HscRecomp False Nothing, iface, details)
 523
 524   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 525        guts <- hscSimplify guts0
 526        (iface, _changed, details, cgguts)
 527            <- hscNormalIface guts mb_old_iface
 528        hscInteractive (iface, details, cgguts) mod_summary
 529   }
 530
 531 -- Compile Haskell, extCore to bytecode.
 532 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
 533 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
 534
 535 --------------------------------------------------------------
 536
 537 hscNothingCompiler :: HsCompiler NothingResult
 538 hscNothingCompiler =
 539   HsCompiler {
 540     hscNoRecomp = \iface -> do
 541        details <- genModDetails iface
 542        return (HscNoRecomp, iface, details)
 543
 544   , hscRecompile = genericHscRecompile hscNothingCompiler
 545
 546   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
 547        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 548        return (HscRecomp False (), iface, details)
 549
 550   , hscGenBootOutput = \_ _ _ ->
 551         panic "hscCompileNothing: hscGenBootOutput should not be called"
 552
 553   , hscGenOutput = \_ _ _ ->
 554         panic "hscCompileNothing: hscGenOutput should not be called"
 555   }
 556
 557 -- Type-check Haskell and .hs-boot only (no external core)
 558 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
 559 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
 560
 561 --------------------------------------------------------------
 562 -- NoRecomp handlers
 563 --------------------------------------------------------------
 564
 565 genModDetails :: GhcMonad m => ModIface -> m ModDetails
 566 genModDetails old_iface =
 567     withSession $ \hsc_env -> liftIO $ do
 568       new_details <- {-# SCC "tcRnIface" #-}
 569                      initIfaceCheck hsc_env $
 570                      typecheckIface old_iface
 571       dumpIfaceStats hsc_env
 572       return new_details
 573
 574 --------------------------------------------------------------
 575 -- Progress displayers.
 576 --------------------------------------------------------------
 577
 578 oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
 579 oneShotMsg _mb_mod_index recomp _mod_summary
 580     = do hsc_env <- getSession
 581          liftIO $ do
 582          if recomp
 583             then return ()
 584             else compilationProgressMsg (hsc_dflags hsc_env) $
 585                      "compilation IS NOT required"
 586
 587 batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
 588 batchMsg mb_mod_index recomp mod_summary
 589     = do hsc_env <- getSession
 590          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
 591                            (showModuleIndex mb_mod_index ++
 592                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
 593          liftIO $ do
 594          if recomp
 595             then showMsg "Compiling "
 596             else if verbosity (hsc_dflags hsc_env) >= 2
 597                     then showMsg "Skipping  "
 598                     else return ()
 599
 600 --------------------------------------------------------------
 601 -- FrontEnds
 602 --------------------------------------------------------------
 603 hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv
 604 hscFileFrontEnd mod_summary =
 605     do rdr_module <- hscParse mod_summary
 606        hscTypecheck mod_summary rdr_module
 607
 608 --------------------------------------------------------------
 609 -- Simplifiers
 610 --------------------------------------------------------------
 611
 612 hscSimplify :: GhcMonad m => ModGuts -> m ModGuts
 613 hscSimplify ds_result
 614   = do hsc_env <- getSession
 615        simpl_result <- {-# SCC "Core2Core" #-}
 616                        liftIO $ core2core hsc_env ds_result
 617        return simpl_result
 618
 619 --------------------------------------------------------------
 620 -- Interface generators
 621 --------------------------------------------------------------
 622
 623 hscSimpleIface :: GhcMonad m =>
 624                   TcGblEnv
 625                -> Maybe Fingerprint
 626                -> m (ModIface, Bool, ModDetails)
 627 hscSimpleIface tc_result mb_old_iface
 628   = do hsc_env <- getSession
 629        details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
 630        (new_iface, no_change)
 631            <- {-# SCC "MkFinalIface" #-}
 632               ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result
 633        -- And the answer is ...
 634        liftIO $ dumpIfaceStats hsc_env
 635        return (new_iface, no_change, details)
 636
 637 hscNormalIface :: GhcMonad m =>
 638                   ModGuts
 639                -> Maybe Fingerprint
 640                -> m (ModIface, Bool, ModDetails, CgGuts)
 641 hscNormalIface simpl_result mb_old_iface
 642   = do hsc_env <- getSession
 643
 644        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
 645                              liftIO $ tidyProgram hsc_env simpl_result
 646
 647             -- BUILD THE NEW ModIface and ModDetails
 648             --  and emit external core if necessary
 649             -- This has to happen *after* code gen so that the back-end
 650             -- info has been set.  Not yet clear if it matters waiting
 651             -- until after code output
 652        (new_iface, no_change)
 653            <- {-# SCC "MkFinalIface" #-}
 654               ioMsgMaybe $ mkIface hsc_env mb_old_iface
 655                                    details simpl_result
 656         -- Emit external core
 657        -- This should definitely be here and not after CorePrep,
 658        -- because CorePrep produces unqualified constructor wrapper declarations,
 659        -- so its output isn't valid External Core (without some preprocessing).
 660        liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
 661        liftIO $ dumpIfaceStats hsc_env
 662
 663             -- Return the prepared code.
 664        return (new_iface, no_change, details, cg_guts)
 665
 666 --------------------------------------------------------------
 667 -- BackEnd combinators
 668 --------------------------------------------------------------
 669
 670 hscWriteIface :: GhcMonad m =>
 671                  ModIface -> Bool
 672               -> ModSummary
 673               -> m ()
 674 hscWriteIface iface no_change mod_summary
 675     = do hsc_env <- getSession
 676          let dflags = hsc_dflags hsc_env
 677          liftIO $ do
 678          unless no_change
 679            $ writeIfaceFile dflags (ms_location mod_summary) iface
 680
 681 -- | Compile to hard-code.
 682 hscGenHardCode :: GhcMonad m =>
 683                   CgGuts -> ModSummary
 684                -> m Bool -- ^ @True@ <=> stub.c exists
 685 hscGenHardCode cgguts mod_summary
 686     = withSession $ \hsc_env -> liftIO $ do
 687          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 688                      -- From now on, we just use the bits we need.
 689                      cg_module   = this_mod,
 690                      cg_binds    = core_binds,
 691                      cg_tycons   = tycons,
 692                      cg_dir_imps = dir_imps,
 693                      cg_foreign  = foreign_stubs,
 694                      cg_dep_pkgs = dependencies,
 695                      cg_hpc_info = hpc_info } = cgguts
 696              dflags = hsc_dflags hsc_env
 697              location = ms_location mod_summary
 698              data_tycons = filter isDataTyCon tycons
 699              -- cg_tycons includes newtypes, for the benefit of External Core,
 700              -- but we don't generate any code for newtypes
 701
 702          -------------------
 703          -- PREPARE FOR CODE GENERATION
 704          -- Do saturation and convert to A-normal form
 705          prepd_binds <- {-# SCC "CorePrep" #-}
 706                         corePrepPgm dflags core_binds data_tycons ;
 707          -----------------  Convert to STG ------------------
 708          (stg_binds, cost_centre_info)
 709              <- {-# SCC "CoreToStg" #-}
 710                 myCoreToStg dflags this_mod prepd_binds
 711
 712          ------------------  Code generation ------------------
 713          cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
 714                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
 715                                  dir_imps cost_centre_info
 716                                  stg_binds hpc_info
 717                          return cmms
 718                  else {-# SCC "CodeGen" #-}
 719                        codeGen dflags this_mod data_tycons
 720                                dir_imps cost_centre_info
 721                                stg_binds hpc_info
 722
 723          --- Optionally run experimental Cmm transformations ---
 724          -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
 725                  -- unless certain dflags are on, the identity function
 726          ------------------  Code output -----------------------
 727          rawcmms <- cmmToRawCmm cmms
 728          dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
 729          (_stub_h_exists, stub_c_exists)
 730              <- codeOutput dflags this_mod location foreign_stubs
 731                 dependencies rawcmms
 732          return stub_c_exists
 733
 734 hscInteractive :: GhcMonad m =>
 735                   (ModIface, ModDetails, CgGuts)
 736                -> ModSummary
 737                -> m (InteractiveStatus, ModIface, ModDetails)
 738 #ifdef GHCI
 739 hscInteractive (iface, details, cgguts) mod_summary
 740     = do hsc_env <- getSession
 741          liftIO $ do
 742          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 743                      -- From now on, we just use the bits we need.
 744                      cg_module   = this_mod,
 745                      cg_binds    = core_binds,
 746                      cg_tycons   = tycons,
 747                      cg_foreign  = foreign_stubs,
 748                      cg_modBreaks = mod_breaks } = cgguts
 749              dflags = hsc_dflags hsc_env
 750              location = ms_location mod_summary
 751              data_tycons = filter isDataTyCon tycons
 752              -- cg_tycons includes newtypes, for the benefit of External Core,
 753              -- but we don't generate any code for newtypes
 754
 755          -------------------
 756          -- PREPARE FOR CODE GENERATION
 757          -- Do saturation and convert to A-normal form
 758          prepd_binds <- {-# SCC "CorePrep" #-}
 759                         corePrepPgm dflags core_binds data_tycons ;
 760          -----------------  Generate byte code ------------------
 761          comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
 762          ------------------ Create f-x-dynamic C-side stuff ---
 763          (_istub_h_exists, istub_c_exists)
 764              <- outputForeignStubs dflags this_mod location foreign_stubs
 765          return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
 766                 , iface, details)
 767 #else
 768 hscInteractive _ _ = panic "GHC not compiled with interpreter"
 769 #endif
 770
 771 ------------------------------
 772
 773 hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
 774 hscCmmFile hsc_env filename = do
 775     dflags <- return $ hsc_dflags hsc_env
 776     cmm <- ioMsgMaybe $
 777              parseCmmFile dflags filename
 778     cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
 779     rawCmms <- liftIO $ cmmToRawCmm cmms
 780     _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
 781     return ()
 782   where
 783         no_mod = panic "hscCmmFile: no_mod"
 784         no_loc = ModLocation{ ml_hs_file  = Just filename,
 785                               ml_hi_file  = panic "hscCmmFile: no hi file",
 786                               ml_obj_file = panic "hscCmmFile: no obj file" }
 787
 788 -------------------- Stuff for new code gen ---------------------
 789
 790 tryNewCodeGen   :: HscEnv -> Module -> [TyCon] -> [Module]
 791                 -> CollectedCCs
 792                 -> [(StgBinding,[(Id,[Id])])]
 793                 -> HpcInfo
 794                 -> IO [Cmm]
 795 tryNewCodeGen hsc_env this_mod data_tycons imported_mods
 796               cost_centre_info stg_binds hpc_info =
 797   do    { let dflags = hsc_dflags hsc_env
 798         ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods
 799                          cost_centre_info stg_binds hpc_info
 800         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
 801                 (pprCmms prog)
 802
 803         ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
 804                 -- Control flow optimisation
 805
 806         -- We are building a single SRT for the entire module, so
 807         -- we must thread it through all the procedures as we cps-convert them.
 808         ; us <- mkSplitUniqSupply 'S'
 809         ; let topSRT = initUs_ us emptySRT
 810         ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
 811                 -- The main CPS conversion
 812
 813         ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
 814                 -- Control flow optimisation, again
 815
 816         ; let prog' = map cmmOfZgraph prog
 817         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
 818         ; return prog' }
 819
 820
 821 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
 822 optionallyConvertAndOrCPS hsc_env cmms =
 823     do let dflags = hsc_dflags hsc_env
 824         --------  Optionally convert to and from zipper ------
 825        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
 826                then mapM (testCmmConversion hsc_env) cmms
 827                else return cmms
 828          ---------  Optionally convert to CPS (MDA) -----------
 829        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
 830                   dopt Opt_RunCPS dflags
 831                then cmmCPS dflags cmms
 832                else return cmms
 833        return cmms
 834
 835
 836 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
 837 testCmmConversion hsc_env cmm =
 838     do let dflags = hsc_dflags hsc_env
 839        showPass dflags "CmmToCmm"
 840        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
 841        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
 842        us <- mkSplitUniqSupply 'C'
 843        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
 844        let cvtm = do g <- cmmToZgraph cmm
 845                      return $ cfopts g
 846        let zgraph = initUs_ us cvtm
 847        us <- mkSplitUniqSupply 'S'
 848        let topSRT = initUs_ us emptySRT
 849        (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
 850        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
 851        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
 852        showPass dflags "Convert from Z back to Cmm"
 853        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
 854        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
 855        return cvt
 856
 857 myCoreToStg :: DynFlags -> Module -> [CoreBind]
 858             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
 859                   , CollectedCCs) -- cost centre info (declared and used)
 860
 861 myCoreToStg dflags this_mod prepd_binds
 862  = do
 863       stg_binds <- {-# SCC "Core2Stg" #-}
 864              coreToStg (thisPackage dflags) prepd_binds
 865
 866       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 867              stg2stg dflags this_mod stg_binds
 868
 869       return (stg_binds2, cost_centre_info)
 870 \end{code}
 871
 872
 873 %************************************************************************
 874 %*                                                                      *
 875 \subsection{Compiling a do-statement}
 876 %*                                                                      *
 877 %************************************************************************
 878
 879 When the UnlinkedBCOExpr is linked you get an HValue of type
 880         IO [HValue]
 881 When you run it you get a list of HValues that should be
 882 the same length as the list of names; add them to the ClosureEnv.
 883
 884 A naked expression returns a singleton Name [it].
 885
 886         What you type                   The IO [HValue] that hscStmt returns
 887         -------------                   ------------------------------------
 888         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 889                                         bindings: [x,y,...]
 890
 891         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 892                                         bindings: [x,y,...]
 893
 894         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 895           [NB: result not printed]      bindings: [it]
 896
 897
 898         expr (of non-IO type,
 899           result showable)      ==>     let v = expr in print v >> return [v]
 900                                         bindings: [it]
 901
 902         expr (of non-IO type,
 903           result not showable)  ==>     error
 904
 905 \begin{code}
 906 #ifdef GHCI
 907 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 908   :: GhcMonad m =>
 909      HscEnv
 910   -> String                     -- The statement
 911   -> m (Maybe ([Id], HValue))
 912      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
 913 hscStmt hsc_env stmt = do
 914     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 915     case maybe_stmt of
 916       Nothing -> return Nothing
 917       Just parsed_stmt -> do  -- The real stuff
 918
 919              -- Rename and typecheck it
 920         let icontext = hsc_IC hsc_env
 921         (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
 922             -- Desugar it
 923         let rdr_env  = ic_rn_gbl_env icontext
 924             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 925         ds_expr <- ioMsgMaybe $
 926                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 927
 928         -- Then desugar, code gen, and link it
 929         let src_span = srcLocSpan interactiveSrcLoc
 930         hval <- liftIO $ compileExpr hsc_env src_span ds_expr
 931
 932         return $ Just (ids, hval)
 933
 934 hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
 935 hscImport hsc_env str = do
 936     (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
 937     case is of
 938         [i] -> return (unLoc i)
 939         _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))
 940
 941 hscTcExpr       -- Typecheck an expression (but don't run it)
 942   :: GhcMonad m =>
 943      HscEnv
 944   -> String                     -- The expression
 945   -> m Type
 946
 947 hscTcExpr hsc_env expr = do
 948     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 949     let icontext = hsc_IC hsc_env
 950     case maybe_stmt of
 951       Just (L _ (ExprStmt expr _ _)) -> do
 952           ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
 953           return ty
 954       _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
 955                         noSrcSpan
 956                         (text "not an expression:" <+> quotes (text expr))
 957
 958 -- | Find the kind of a type
 959 hscKcType
 960   :: GhcMonad m =>
 961      HscEnv
 962   -> String                     -- ^ The type
 963   -> m Kind
 964
 965 hscKcType hsc_env str = do
 966     ty <- hscParseType (hsc_dflags hsc_env) str
 967     let icontext = hsc_IC hsc_env
 968     ioMsgMaybe $ tcRnType hsc_env icontext ty
 969
 970 #endif
 971 \end{code}
 972
 973 \begin{code}
 974 #ifdef GHCI
 975 hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
 976 hscParseStmt = hscParseThing parseStmt
 977
 978 hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
 979 hscParseType = hscParseThing parseType
 980 #endif
 981
 982 hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
 983 hscParseIdentifier = hscParseThing parseIdentifier
 984
 985 hscParseThing :: (Outputable thing, GhcMonad m)
 986               => Lexer.P thing
 987               -> DynFlags -> String
 988               -> m thing
 989         -- Nothing => Parse error (message already printed)
 990         -- Just x  => success
 991 hscParseThing parser dflags str
 992  = (liftIO $ showPass dflags "Parser") >>
 993       {-# SCC "Parser" #-} do
 994
 995       buf <- liftIO $ stringToStringBuffer str
 996
 997       let loc  = mkSrcLoc (fsLit "<interactive>") 1 1
 998
 999       case unP parser (mkPState dflags buf loc) of
1000
1001         PFailed span err -> do
1002           let msg = mkPlainErrMsg span err
1003           throw (mkSrcErr (unitBag msg))
1004
1005         POk pst thing -> do
1006
1007           let ms@(warns, errs) = getMessages pst
1008           logWarnings warns
1009           when (errorsFound dflags ms) $ -- handle -Werror
1010             throw (mkSrcErr errs)
1011
1012           --ToDo: can't free the string buffer until we've finished this
1013           -- compilation sweep and all the identifiers have gone away.
1014           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1015           return thing
1016 \end{code}
1017
1018 %************************************************************************
1019 %*                                                                      *
1020         Desugar, simplify, convert to bytecode, and link an expression
1021 %*                                                                      *
1022 %************************************************************************
1023
1024 \begin{code}
1025 #ifdef GHCI
1026 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1027
1028 compileExpr hsc_env srcspan ds_expr
1029   = do  { let { dflags  = hsc_dflags hsc_env ;
1030                 lint_on = dopt Opt_DoCoreLinting dflags }
1031
1032                 -- Simplify it
1033         ; simpl_expr <- simplifyExpr dflags ds_expr
1034
1035                 -- Tidy it (temporary, until coreSat does cloning)
1036         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1037
1038                 -- Prepare for codegen
1039         ; prepd_expr <- corePrepExpr dflags tidy_expr
1040
1041                 -- Lint if necessary
1042                 -- ToDo: improve SrcLoc
1043         ; if lint_on then
1044                 let ictxt = hsc_IC hsc_env
1045                     tyvars = varSetElems (ic_tyvars ictxt)
1046                 in
1047                 case lintUnfolding noSrcLoc tyvars prepd_expr of
1048                    Just err -> pprPanic "compileExpr" err
1049                    Nothing  -> return ()
1050           else
1051                 return ()
1052
1053                 -- Convert to BCOs
1054         ; bcos <- coreExprToBCOs dflags prepd_expr
1055
1056                 -- link it
1057         ; hval <- linkExpr hsc_env srcspan bcos
1058
1059         ; return hval
1060      }
1061 #endif
1062 \end{code}
1063
1064
1065 %************************************************************************
1066 %*                                                                      *
1067         Statistics on reading interfaces
1068 %*                                                                      *
1069 %************************************************************************
1070
1071 \begin{code}
1072 dumpIfaceStats :: HscEnv -> IO ()
1073 dumpIfaceStats hsc_env
1074   = do  { eps <- readIORef (hsc_EPS hsc_env)
1075         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1076                     "Interface statistics"
1077                     (ifaceStats eps) }
1078   where
1079     dflags = hsc_dflags hsc_env
1080     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1081     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1082 \end{code}
1083
1084 %************************************************************************
1085 %*                                                                      *
1086         Progress Messages: Module i of n
1087 %*                                                                      *
1088 %************************************************************************
1089
1090 \begin{code}
1091 showModuleIndex :: Maybe (Int, Int) -> String
1092 showModuleIndex Nothing = ""
1093 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1094     where
1095         n_str = show n
1096         i_str = show i
1097         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1098 \end{code}