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