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 0
 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 (HsDoc Name), HaddockModInfo Name))
 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     = tcg_doc tc_result
 237                            hmi     = tcg_hmi tc_result
 238                      ; return (decl,imports,exports,doc,hmi) }
 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     -- | The main interface.
 341     hscCompile :: GhcMonad m =>
 342                   HscEnv -> ModSummary -> Bool
 343                -> Maybe ModIface -> Maybe (Int, Int)
 344                -> m a,
 345
 346     -- | Called when no recompilation is necessary.
 347     hscNoRecomp :: GhcMonad m =>
 348                    ModIface -> m a,
 349
 350     -- | Called to recompile the module.
 351     hscRecompile :: GhcMonad m =>
 352                     ModSummary -> Maybe Fingerprint -> m a,
 353
 354     hscBackend :: GhcMonad m =>
 355                   TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
 356
 357     -- | Code generation for Boot modules.
 358     hscGenBootOutput :: GhcMonad m =>
 359                         TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
 360
 361     -- | Code generation for normal modules.
 362     hscGenOutput :: GhcMonad m =>
 363                     ModGuts  -> ModSummary -> Maybe Fingerprint -> m a
 364   }
 365
 366 genericHscCompile :: GhcMonad m =>
 367                      HsCompiler a
 368                   -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ())
 369                   -> HscEnv -> ModSummary -> Bool
 370                   -> Maybe ModIface -> Maybe (Int, Int)
 371                   -> m a
 372 genericHscCompile compiler hscMessage
 373                   hsc_env mod_summary source_unchanged
 374                   mb_old_iface0 mb_mod_index =
 375    withTempSession (\_ -> hsc_env) $ do
 376      (recomp_reqd, mb_checked_iface)
 377          <- {-# SCC "checkOldIface" #-}
 378             liftIO $ checkOldIface hsc_env mod_summary
 379                                    source_unchanged mb_old_iface0
 380      -- save the interface that comes back from checkOldIface.
 381      -- In one-shot mode we don't have the old iface until this
 382      -- point, when checkOldIface reads it from the disk.
 383      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
 384      case mb_checked_iface of
 385        Just iface | not recomp_reqd
 386            -> do hscMessage mb_mod_index False mod_summary
 387                  hscNoRecomp compiler iface
 388        _otherwise
 389            -> do hscMessage mb_mod_index True mod_summary
 390                  hscRecompile compiler mod_summary mb_old_hash
 391
 392 genericHscRecompile :: GhcMonad m =>
 393                        HsCompiler a
 394                     -> ModSummary -> Maybe Fingerprint
 395                     -> m a
 396 genericHscRecompile compiler mod_summary mb_old_hash
 397   | ExtCoreFile <- ms_hsc_src mod_summary =
 398       panic "GHC does not currently support reading External Core files"
 399   | otherwise = do
 400       tc_result <- hscFileFrontEnd mod_summary
 401       hscBackend compiler tc_result mod_summary mb_old_hash
 402
 403 genericHscBackend :: GhcMonad m =>
 404                      HsCompiler a
 405                   -> TcGblEnv -> ModSummary -> Maybe Fingerprint
 406                   -> m a
 407 genericHscBackend compiler tc_result mod_summary mb_old_hash
 408   | HsBootFile <- ms_hsc_src mod_summary =
 409       hscGenBootOutput compiler tc_result mod_summary mb_old_hash
 410   | otherwise = do
 411       guts <- hscDesugar mod_summary tc_result
 412       hscGenOutput compiler guts mod_summary mb_old_hash
 413
 414 --------------------------------------------------------------
 415 -- Compilers
 416 --------------------------------------------------------------
 417
 418 hscOneShotCompiler :: HsCompiler OneShotResult
 419 hscOneShotCompiler =
 420   HsCompiler {
 421
 422     hscCompile = \hsc_env mod_summary src_changed mb_old_iface mb_i_of_n -> do
 423        -- One-shot mode needs a knot-tying mutable variable for interface
 424        -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
 425       type_env_var <- liftIO $ newIORef emptyNameEnv
 426       let
 427          mod = ms_mod mod_summary
 428          hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
 429       ---
 430       genericHscCompile hscOneShotCompiler
 431                         oneShotMsg hsc_env' mod_summary src_changed
 432                         mb_old_iface mb_i_of_n
 433
 434   , hscNoRecomp = \_old_iface -> do
 435       withSession (liftIO . dumpIfaceStats)
 436       return HscNoRecomp
 437
 438   , hscRecompile = genericHscRecompile hscOneShotCompiler
 439
 440   , hscBackend = genericHscBackend hscOneShotCompiler
 441
 442   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 443        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
 444        hscWriteIface iface changed mod_summary
 445        return (HscRecomp False ())
 446
 447   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 448        guts <- hscSimplify guts0
 449        (iface, changed, _details, cgguts)
 450            <- hscNormalIface guts mb_old_iface
 451        hscWriteIface iface changed mod_summary
 452        hasStub <- hscGenHardCode cgguts mod_summary
 453        return (HscRecomp hasStub ())
 454   }
 455
 456 -- Compile Haskell, boot and extCore in OneShot mode.
 457 hscCompileOneShot :: Compiler OneShotResult
 458 hscCompileOneShot = hscCompile hscOneShotCompiler
 459
 460 --------------------------------------------------------------
 461
 462 hscBatchCompiler :: HsCompiler BatchResult
 463 hscBatchCompiler =
 464   HsCompiler {
 465
 466     hscCompile = genericHscCompile hscBatchCompiler batchMsg
 467
 468   , hscNoRecomp = \iface -> do
 469        details <- genModDetails iface
 470        return (HscNoRecomp, iface, details)
 471
 472   , hscRecompile = genericHscRecompile hscBatchCompiler
 473
 474   , hscBackend = genericHscBackend hscBatchCompiler
 475
 476   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 477        (iface, changed, details)
 478            <- hscSimpleIface tc_result mb_old_iface
 479        hscWriteIface iface changed mod_summary
 480        return (HscRecomp False (), iface, details)
 481
 482   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 483        guts <- hscSimplify guts0
 484        (iface, changed, details, cgguts)
 485            <- hscNormalIface guts mb_old_iface
 486        hscWriteIface iface changed mod_summary
 487        hasStub <- hscGenHardCode cgguts mod_summary
 488        return (HscRecomp hasStub (), iface, details)
 489   }
 490
 491 -- Compile Haskell, boot and extCore in batch mode.
 492 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
 493 hscCompileBatch = hscCompile hscBatchCompiler
 494
 495 --------------------------------------------------------------
 496
 497 hscInteractiveCompiler :: HsCompiler InteractiveResult
 498 hscInteractiveCompiler =
 499   HsCompiler {
 500     hscCompile = genericHscCompile hscInteractiveCompiler batchMsg
 501
 502   , hscNoRecomp = \iface -> do
 503        details <- genModDetails iface
 504        return (HscNoRecomp, iface, details)
 505
 506   , hscRecompile = genericHscRecompile hscInteractiveCompiler
 507
 508   , hscBackend = genericHscBackend hscInteractiveCompiler
 509
 510   , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
 511        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 512        return (HscRecomp False Nothing, iface, details)
 513
 514   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 515        guts <- hscSimplify guts0
 516        (iface, _changed, details, cgguts)
 517            <- hscNormalIface guts mb_old_iface
 518        hscInteractive (iface, details, cgguts) mod_summary
 519   }
 520
 521 -- Compile Haskell, extCore to bytecode.
 522 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
 523 hscCompileInteractive = hscCompile hscInteractiveCompiler
 524
 525 --------------------------------------------------------------
 526
 527 hscNothingCompiler :: HsCompiler NothingResult
 528 hscNothingCompiler =
 529   HsCompiler {
 530     hscCompile = genericHscCompile hscNothingCompiler batchMsg
 531
 532   , hscNoRecomp = \iface -> do
 533        details <- genModDetails iface
 534        return (HscNoRecomp, iface, details)
 535
 536   , hscRecompile = \mod_summary mb_old_hash ->
 537       case ms_hsc_src mod_summary of
 538         ExtCoreFile ->
 539           panic "hscCompileNothing: cannot do external core"
 540         _otherwise -> do
 541           tc_result <- hscFileFrontEnd mod_summary
 542           hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash
 543
 544   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
 545        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 546        return (HscRecomp False (), iface, details)
 547
 548   , hscGenBootOutput = \_ _ _ ->
 549         panic "hscCompileNothing: hscGenBootOutput should not be called"
 550
 551   , hscGenOutput = \_ _ _ ->
 552         panic "hscCompileNothing: hscGenOutput should not be called"
 553   }
 554 -- Type-check Haskell and .hs-boot only (no external core)
 555 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
 556 hscCompileNothing = hscCompile hscNothingCompiler
 557
 558 --------------------------------------------------------------
 559 -- NoRecomp handlers
 560 --------------------------------------------------------------
 561
 562 genModDetails :: GhcMonad m => ModIface -> m ModDetails
 563 genModDetails old_iface =
 564     withSession $ \hsc_env -> liftIO $ do
 565       new_details <- {-# SCC "tcRnIface" #-}
 566                      initIfaceCheck hsc_env $
 567                      typecheckIface old_iface
 568       dumpIfaceStats hsc_env
 569       return new_details
 570
 571 --------------------------------------------------------------
 572 -- Progress displayers.
 573 --------------------------------------------------------------
 574
 575 oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
 576 oneShotMsg _mb_mod_index recomp _mod_summary
 577     = do hsc_env <- getSession
 578          liftIO $ do
 579          if recomp
 580             then return ()
 581             else compilationProgressMsg (hsc_dflags hsc_env) $
 582                      "compilation IS NOT required"
 583
 584 batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
 585 batchMsg mb_mod_index recomp mod_summary
 586     = do hsc_env <- getSession
 587          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
 588                            (showModuleIndex mb_mod_index ++
 589                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
 590          liftIO $ do
 591          if recomp
 592             then showMsg "Compiling "
 593             else if verbosity (hsc_dflags hsc_env) >= 2
 594                     then showMsg "Skipping  "
 595                     else return ()
 596
 597 --------------------------------------------------------------
 598 -- FrontEnds
 599 --------------------------------------------------------------
 600 hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv
 601 hscFileFrontEnd mod_summary =
 602     do rdr_module <- hscParse mod_summary
 603        hscTypecheck mod_summary rdr_module
 604
 605 --------------------------------------------------------------
 606 -- Simplifiers
 607 --------------------------------------------------------------
 608
 609 hscSimplify :: GhcMonad m => ModGuts -> m ModGuts
 610 hscSimplify ds_result
 611   = do hsc_env <- getSession
 612        simpl_result <- {-# SCC "Core2Core" #-}
 613                        liftIO $ core2core hsc_env ds_result
 614        return simpl_result
 615
 616 --------------------------------------------------------------
 617 -- Interface generators
 618 --------------------------------------------------------------
 619
 620 hscSimpleIface :: GhcMonad m =>
 621                   TcGblEnv
 622                -> Maybe Fingerprint
 623                -> m (ModIface, Bool, ModDetails)
 624 hscSimpleIface tc_result mb_old_iface
 625   = do hsc_env <- getSession
 626        details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
 627        (new_iface, no_change)
 628            <- {-# SCC "MkFinalIface" #-}
 629               ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result
 630        -- And the answer is ...
 631        liftIO $ dumpIfaceStats hsc_env
 632        return (new_iface, no_change, details)
 633
 634 hscNormalIface :: GhcMonad m =>
 635                   ModGuts
 636                -> Maybe Fingerprint
 637                -> m (ModIface, Bool, ModDetails, CgGuts)
 638 hscNormalIface simpl_result mb_old_iface
 639   = do hsc_env <- getSession
 640
 641        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
 642                              liftIO $ tidyProgram hsc_env simpl_result
 643
 644             -- BUILD THE NEW ModIface and ModDetails
 645             --  and emit external core if necessary
 646             -- This has to happen *after* code gen so that the back-end
 647             -- info has been set.  Not yet clear if it matters waiting
 648             -- until after code output
 649        (new_iface, no_change)
 650            <- {-# SCC "MkFinalIface" #-}
 651               ioMsgMaybe $ mkIface hsc_env mb_old_iface
 652                                    details simpl_result
 653         -- Emit external core
 654        -- This should definitely be here and not after CorePrep,
 655        -- because CorePrep produces unqualified constructor wrapper declarations,
 656        -- so its output isn't valid External Core (without some preprocessing).
 657        liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
 658        liftIO $ dumpIfaceStats hsc_env
 659
 660             -- Return the prepared code.
 661        return (new_iface, no_change, details, cg_guts)
 662
 663 --------------------------------------------------------------
 664 -- BackEnd combinators
 665 --------------------------------------------------------------
 666
 667 hscWriteIface :: GhcMonad m =>
 668                  ModIface -> Bool
 669               -> ModSummary
 670               -> m ()
 671 hscWriteIface iface no_change mod_summary
 672     = do hsc_env <- getSession
 673          let dflags = hsc_dflags hsc_env
 674          liftIO $ do
 675          unless no_change
 676            $ writeIfaceFile dflags (ms_location mod_summary) iface
 677
 678 -- | Compile to hard-code.
 679 hscGenHardCode :: GhcMonad m =>
 680                   CgGuts -> ModSummary
 681                -> m Bool -- ^ @True@ <=> stub.c exists
 682 hscGenHardCode cgguts mod_summary
 683     = withSession $ \hsc_env -> liftIO $ do
 684          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 685                      -- From now on, we just use the bits we need.
 686                      cg_module   = this_mod,
 687                      cg_binds    = core_binds,
 688                      cg_tycons   = tycons,
 689                      cg_dir_imps = dir_imps,
 690                      cg_foreign  = foreign_stubs,
 691                      cg_dep_pkgs = dependencies,
 692                      cg_hpc_info = hpc_info } = cgguts
 693              dflags = hsc_dflags hsc_env
 694              location = ms_location mod_summary
 695              data_tycons = filter isDataTyCon tycons
 696              -- cg_tycons includes newtypes, for the benefit of External Core,
 697              -- but we don't generate any code for newtypes
 698
 699          -------------------
 700          -- PREPARE FOR CODE GENERATION
 701          -- Do saturation and convert to A-normal form
 702          prepd_binds <- {-# SCC "CorePrep" #-}
 703                         corePrepPgm dflags core_binds data_tycons ;
 704          -----------------  Convert to STG ------------------
 705          (stg_binds, cost_centre_info)
 706              <- {-# SCC "CoreToStg" #-}
 707                 myCoreToStg dflags this_mod prepd_binds
 708
 709          ------------------  Code generation ------------------
 710          cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
 711                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
 712                                  dir_imps cost_centre_info
 713                                  stg_binds hpc_info
 714                          return cmms
 715                  else {-# SCC "CodeGen" #-}
 716                        codeGen dflags this_mod data_tycons
 717                                dir_imps cost_centre_info
 718                                stg_binds hpc_info
 719
 720          --- Optionally run experimental Cmm transformations ---
 721          -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
 722                  -- unless certain dflags are on, the identity function
 723          ------------------  Code output -----------------------
 724          rawcmms <- cmmToRawCmm cmms
 725          dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
 726          (_stub_h_exists, stub_c_exists)
 727              <- codeOutput dflags this_mod location foreign_stubs
 728                 dependencies rawcmms
 729          return stub_c_exists
 730
 731 hscInteractive :: GhcMonad m =>
 732                   (ModIface, ModDetails, CgGuts)
 733                -> ModSummary
 734                -> m (InteractiveStatus, ModIface, ModDetails)
 735 #ifdef GHCI
 736 hscInteractive (iface, details, cgguts) mod_summary
 737     = do hsc_env <- getSession
 738          liftIO $ do
 739          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 740                      -- From now on, we just use the bits we need.
 741                      cg_module   = this_mod,
 742                      cg_binds    = core_binds,
 743                      cg_tycons   = tycons,
 744                      cg_foreign  = foreign_stubs,
 745                      cg_modBreaks = mod_breaks } = cgguts
 746              dflags = hsc_dflags hsc_env
 747              location = ms_location mod_summary
 748              data_tycons = filter isDataTyCon tycons
 749              -- cg_tycons includes newtypes, for the benefit of External Core,
 750              -- but we don't generate any code for newtypes
 751
 752          -------------------
 753          -- PREPARE FOR CODE GENERATION
 754          -- Do saturation and convert to A-normal form
 755          prepd_binds <- {-# SCC "CorePrep" #-}
 756                         corePrepPgm dflags core_binds data_tycons ;
 757          -----------------  Generate byte code ------------------
 758          comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
 759          ------------------ Create f-x-dynamic C-side stuff ---
 760          (_istub_h_exists, istub_c_exists)
 761              <- outputForeignStubs dflags this_mod location foreign_stubs
 762          return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
 763                 , iface, details)
 764 #else
 765 hscInteractive _ _ = panic "GHC not compiled with interpreter"
 766 #endif
 767
 768 ------------------------------
 769
 770 hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
 771 hscCmmFile hsc_env filename = do
 772     dflags <- return $ hsc_dflags hsc_env
 773     cmm <- ioMsgMaybe $
 774              parseCmmFile dflags filename
 775     cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
 776     rawCmms <- liftIO $ cmmToRawCmm cmms
 777     _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
 778     return ()
 779   where
 780         no_mod = panic "hscCmmFile: no_mod"
 781         no_loc = ModLocation{ ml_hs_file  = Just filename,
 782                               ml_hi_file  = panic "hscCmmFile: no hi file",
 783                               ml_obj_file = panic "hscCmmFile: no obj file" }
 784
 785 -------------------- Stuff for new code gen ---------------------
 786
 787 tryNewCodeGen   :: HscEnv -> Module -> [TyCon] -> [Module]
 788                 -> CollectedCCs
 789                 -> [(StgBinding,[(Id,[Id])])]
 790                 -> HpcInfo
 791                 -> IO [Cmm]
 792 tryNewCodeGen hsc_env this_mod data_tycons imported_mods
 793               cost_centre_info stg_binds hpc_info
 794   | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env))
 795   = return []
 796   | otherwise
 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         -- Note: Have to thread the module's SRT through all the procedures
 807         -- because we greedily build it as we go.
 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
 935 hscTcExpr       -- Typecheck an expression (but don't run it)
 936   :: GhcMonad m =>
 937      HscEnv
 938   -> String                     -- The expression
 939   -> m Type
 940
 941 hscTcExpr hsc_env expr = do
 942     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 943     let icontext = hsc_IC hsc_env
 944     case maybe_stmt of
 945       Just (L _ (ExprStmt expr _ _)) -> do
 946           ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
 947           return ty
 948       _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
 949                         noSrcSpan
 950                         (text "not an expression:" <+> quotes (text expr))
 951
 952 -- | Find the kind of a type
 953 hscKcType
 954   :: GhcMonad m =>
 955      HscEnv
 956   -> String                     -- ^ The type
 957   -> m Kind
 958
 959 hscKcType hsc_env str = do
 960     ty <- hscParseType (hsc_dflags hsc_env) str
 961     let icontext = hsc_IC hsc_env
 962     ioMsgMaybe $ tcRnType hsc_env icontext ty
 963
 964 #endif
 965 \end{code}
 966
 967 \begin{code}
 968 #ifdef GHCI
 969 hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
 970 hscParseStmt = hscParseThing parseStmt
 971
 972 hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
 973 hscParseType = hscParseThing parseType
 974 #endif
 975
 976 hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
 977 hscParseIdentifier = hscParseThing parseIdentifier
 978
 979 hscParseThing :: (Outputable thing, GhcMonad m)
 980               => Lexer.P thing
 981               -> DynFlags -> String
 982               -> m thing
 983         -- Nothing => Parse error (message already printed)
 984         -- Just x  => success
 985 hscParseThing parser dflags str
 986  = (liftIO $ showPass dflags "Parser") >>
 987       {-# SCC "Parser" #-} do
 988
 989       buf <- liftIO $ stringToStringBuffer str
 990
 991       let loc  = mkSrcLoc (fsLit "<interactive>") 1 0
 992
 993       case unP parser (mkPState buf loc dflags) of
 994
 995         PFailed span err -> do
 996           let msg = mkPlainErrMsg span err
 997           throw (mkSrcErr (unitBag msg))
 998
 999         POk pst thing -> do
1000
1001           let ms@(warns, errs) = getMessages pst
1002           logWarnings warns
1003           when (errorsFound dflags ms) $ -- handle -Werror
1004             throw (mkSrcErr errs)
1005
1006           --ToDo: can't free the string buffer until we've finished this
1007           -- compilation sweep and all the identifiers have gone away.
1008           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1009           return thing
1010 \end{code}
1011
1012 %************************************************************************
1013 %*                                                                      *
1014         Desugar, simplify, convert to bytecode, and link an expression
1015 %*                                                                      *
1016 %************************************************************************
1017
1018 \begin{code}
1019 #ifdef GHCI
1020 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1021
1022 compileExpr hsc_env srcspan ds_expr
1023   = do  { let { dflags  = hsc_dflags hsc_env ;
1024                 lint_on = dopt Opt_DoCoreLinting dflags }
1025
1026                 -- Simplify it
1027         ; simpl_expr <- simplifyExpr dflags ds_expr
1028
1029                 -- Tidy it (temporary, until coreSat does cloning)
1030         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1031
1032                 -- Prepare for codegen
1033         ; prepd_expr <- corePrepExpr dflags tidy_expr
1034
1035                 -- Lint if necessary
1036                 -- ToDo: improve SrcLoc
1037         ; if lint_on then
1038                 let ictxt = hsc_IC hsc_env
1039                     tyvars = varSetElems (ic_tyvars ictxt)
1040                 in
1041                 case lintUnfolding noSrcLoc tyvars prepd_expr of
1042                    Just err -> pprPanic "compileExpr" err
1043                    Nothing  -> return ()
1044           else
1045                 return ()
1046
1047                 -- Convert to BCOs
1048         ; bcos <- coreExprToBCOs dflags prepd_expr
1049
1050                 -- link it
1051         ; hval <- linkExpr hsc_env srcspan bcos
1052
1053         ; return hval
1054      }
1055 #endif
1056 \end{code}
1057
1058
1059 %************************************************************************
1060 %*                                                                      *
1061         Statistics on reading interfaces
1062 %*                                                                      *
1063 %************************************************************************
1064
1065 \begin{code}
1066 dumpIfaceStats :: HscEnv -> IO ()
1067 dumpIfaceStats hsc_env
1068   = do  { eps <- readIORef (hsc_EPS hsc_env)
1069         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1070                     "Interface statistics"
1071                     (ifaceStats eps) }
1072   where
1073     dflags = hsc_dflags hsc_env
1074     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1075     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1076 \end{code}
1077
1078 %************************************************************************
1079 %*                                                                      *
1080         Progress Messages: Module i of n
1081 %*                                                                      *
1082 %************************************************************************
1083
1084 \begin{code}
1085 showModuleIndex :: Maybe (Int, Int) -> String
1086 showModuleIndex Nothing = ""
1087 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1088     where
1089         n_str = show n
1090         i_str = show i
1091         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1092 \end{code}