compiler/main/HscMain.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \begin{code}
   5 -- | Main driver for the compiling plain Haskell source code.
   6 --
   7 -- This module implements compilation of a Haskell-only source file.  It is
   8 -- /not/ concerned with preprocessing of source files; this is handled in
   9 -- "DriverPipeline".
  10 --
  11 module HscMain
  12     ( newHscEnv, hscCmmFile
  13     , hscParseIdentifier
  14     , hscSimplify
  15     , hscNormalIface, hscWriteIface, hscGenHardCode
  16 #ifdef GHCI
  17     , hscStmt, hscTcExpr, hscImport, hscKcType
  18     , compileExpr
  19 #endif
  20     , HsCompiler(..)
  21     , hscOneShotCompiler, hscNothingCompiler
  22     , hscInteractiveCompiler, hscBatchCompiler
  23     , hscCompileOneShot     -- :: Compiler HscStatus
  24     , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
  25     , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
  26     , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
  27     , hscCheckRecompBackend
  28     , HscStatus' (..)
  29     , InteractiveStatus, HscStatus
  30
  31     -- The new interface
  32     , hscParse
  33     , hscTypecheck
  34     , hscTypecheckRename
  35     , hscDesugar
  36     , makeSimpleIface
  37     , makeSimpleDetails
  38     ) where
  39
  40 #ifdef GHCI
  41 import CodeOutput       ( outputForeignStubs )
  42 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  43 import Linker           ( HValue, linkExpr )
  44 import CoreTidy         ( tidyExpr )
  45 import CorePrep         ( corePrepExpr )
  46 import Desugar          ( deSugarExpr )
  47 import SimplCore        ( simplifyExpr )
  48 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnType )
  49 import Type             ( Type )
  50 import PrelNames        ( iNTERACTIVE )
  51 import {- Kind parts of -} Type         ( Kind )
  52 import CoreLint         ( lintUnfolding )
  53 import DsMeta           ( templateHaskellNames )
  54 import SrcLoc           ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
  55 import VarSet
  56 import VarEnv           ( emptyTidyEnv )
  57 import Panic
  58 #endif
  59
  60 import Id               ( Id )
  61 import Module           ( emptyModuleEnv, ModLocation(..), Module )
  62 import RdrName
  63 import HsSyn
  64 import CoreSyn
  65 import SrcLoc           ( Located(..) )
  66 import StringBuffer
  67 import Parser
  68 import Lexer
  69 import SrcLoc           ( mkSrcLoc )
  70 import TcRnDriver       ( tcRnModule )
  71 import TcIface          ( typecheckIface )
  72 import TcRnMonad        ( initIfaceCheck, TcGblEnv(..) )
  73 import IfaceEnv         ( initNameCache )
  74 import LoadIface        ( ifaceStats, initExternalPackageState )
  75 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
  76 import MkIface
  77 import Desugar          ( deSugar )
  78 import SimplCore        ( core2core )
  79 import TidyPgm
  80 import CorePrep         ( corePrepPgm )
  81 import CoreToStg        ( coreToStg )
  82 import qualified StgCmm ( codeGen )
  83 import StgSyn
  84 import CostCentre
  85 import TyCon            ( TyCon, isDataTyCon )
  86 import Name             ( Name, NamedThing(..) )
  87 import SimplStg         ( stg2stg )
  88 import CodeGen          ( codeGen )
  89 import Cmm              ( Cmm )
  90 import PprCmm           ( pprCmms )
  91 import CmmParse         ( parseCmmFile )
  92 import CmmBuildInfoTables
  93 import CmmCPS
  94 import CmmCPSZ
  95 import CmmInfo
  96 import OptimizationFuel ( initOptFuelState )
  97 import CmmCvt
  98 import CmmTx
  99 import CmmContFlowOpt
 100 import CodeOutput       ( codeOutput )
 101 import NameEnv          ( emptyNameEnv )
 102 import Fingerprint      ( Fingerprint )
 103
 104 import DynFlags
 105 import ErrUtils
 106 import UniqSupply       ( mkSplitUniqSupply )
 107
 108 import Outputable
 109 import HscStats         ( ppSourceStats )
 110 import HscTypes
 111 import MkExternalCore   ( emitExternalCore )
 112 import FastString
 113 import UniqFM           ( emptyUFM )
 114 import UniqSupply       ( initUs_ )
 115 import Bag              ( unitBag )
 116 import Exception
 117 -- import MonadUtils
 118
 119 import Control.Monad
 120 -- import System.IO
 121 import Data.IORef
 122 \end{code}
 123 #include "HsVersions.h"
 124
 125
 126 %************************************************************************
 127 %*                                                                      *
 128                 Initialisation
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 \begin{code}
 133 newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv
 134 newHscEnv callbacks dflags
 135   = do  { eps_var <- newIORef initExternalPackageState
 136         ; us      <- mkSplitUniqSupply 'r'
 137         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
 138         ; fc_var  <- newIORef emptyUFM
 139         ; mlc_var <- newIORef emptyModuleEnv
 140         ; optFuel <- initOptFuelState
 141         ; return (HscEnv { hsc_dflags = dflags,
 142                            hsc_callbacks = callbacks,
 143                            hsc_targets = [],
 144                            hsc_mod_graph = [],
 145                            hsc_IC      = emptyInteractiveContext,
 146                            hsc_HPT     = emptyHomePackageTable,
 147                            hsc_EPS     = eps_var,
 148                            hsc_NC      = nc_var,
 149                            hsc_FC      = fc_var,
 150                            hsc_MLC     = mlc_var,
 151                            hsc_OptFuel = optFuel,
 152                            hsc_type_env_var = Nothing } ) }
 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 dflags buf loc) 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 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
 386 hscCheckRecompBackend compiler tc_result
 387                    hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
 388    withTempSession (\_ -> hsc_env) $ do
 389      (recomp_reqd, mb_checked_iface)
 390          <- {-# SCC "checkOldIface" #-}
 391             liftIO $ checkOldIface hsc_env mod_summary
 392                                    source_unchanged mb_old_iface
 393
 394      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
 395      case mb_checked_iface of
 396        Just iface | not recomp_reqd
 397            -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
 398        _otherwise
 399            -> hscBackend compiler tc_result mod_summary mb_old_hash
 400
 401 genericHscRecompile :: GhcMonad m =>
 402                        HsCompiler a
 403                     -> ModSummary -> Maybe Fingerprint
 404                     -> m a
 405 genericHscRecompile compiler mod_summary mb_old_hash
 406   | ExtCoreFile <- ms_hsc_src mod_summary =
 407       panic "GHC does not currently support reading External Core files"
 408   | otherwise = do
 409       tc_result <- hscFileFrontEnd mod_summary
 410       hscBackend compiler tc_result mod_summary mb_old_hash
 411
 412 genericHscBackend :: GhcMonad m =>
 413                      HsCompiler a
 414                   -> TcGblEnv -> ModSummary -> Maybe Fingerprint
 415                   -> m a
 416 genericHscBackend compiler tc_result mod_summary mb_old_hash
 417   | HsBootFile <- ms_hsc_src mod_summary =
 418       hscGenBootOutput compiler tc_result mod_summary mb_old_hash
 419   | otherwise = do
 420       guts <- hscDesugar mod_summary tc_result
 421       hscGenOutput compiler guts mod_summary mb_old_hash
 422
 423 --------------------------------------------------------------
 424 -- Compilers
 425 --------------------------------------------------------------
 426
 427 hscOneShotCompiler :: HsCompiler OneShotResult
 428 hscOneShotCompiler =
 429   HsCompiler {
 430
 431     hscNoRecomp = \_old_iface -> do
 432       withSession (liftIO . dumpIfaceStats)
 433       return HscNoRecomp
 434
 435   , hscRecompile = genericHscRecompile hscOneShotCompiler
 436
 437   , hscBackend = \ tc_result mod_summary mb_old_hash -> do
 438        hsc_env <- getSession
 439        case hscTarget (hsc_dflags hsc_env) of
 440          HscNothing -> return (HscRecomp False ())
 441          _otherw    -> genericHscBackend hscOneShotCompiler
 442                                          tc_result mod_summary mb_old_hash
 443
 444   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 445        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
 446        hscWriteIface iface changed mod_summary
 447        return (HscRecomp False ())
 448
 449   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 450        guts <- hscSimplify guts0
 451        (iface, changed, _details, cgguts)
 452            <- hscNormalIface guts mb_old_iface
 453        hscWriteIface iface changed mod_summary
 454        hasStub <- hscGenHardCode cgguts mod_summary
 455        return (HscRecomp hasStub ())
 456   }
 457
 458 -- Compile Haskell, boot and extCore in OneShot mode.
 459 hscCompileOneShot :: Compiler OneShotResult
 460 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
 461        -- One-shot mode needs a knot-tying mutable variable for interface
 462        -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
 463       type_env_var <- liftIO $ newIORef emptyNameEnv
 464       let
 465          mod = ms_mod mod_summary
 466          hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
 467       ---
 468       genericHscCompile hscOneShotCompiler
 469                         oneShotMsg hsc_env' mod_summary src_changed
 470                         mb_old_iface mb_i_of_n
 471
 472
 473 --------------------------------------------------------------
 474
 475 hscBatchCompiler :: HsCompiler BatchResult
 476 hscBatchCompiler =
 477   HsCompiler {
 478
 479     hscNoRecomp = \iface -> do
 480        details <- genModDetails iface
 481        return (HscNoRecomp, iface, details)
 482
 483   , hscRecompile = genericHscRecompile hscBatchCompiler
 484
 485   , hscBackend = genericHscBackend hscBatchCompiler
 486
 487   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
 488        (iface, changed, details)
 489            <- hscSimpleIface tc_result mb_old_iface
 490        hscWriteIface iface changed mod_summary
 491        return (HscRecomp False (), iface, details)
 492
 493   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 494        guts <- hscSimplify guts0
 495        (iface, changed, details, cgguts)
 496            <- hscNormalIface guts mb_old_iface
 497        hscWriteIface iface changed mod_summary
 498        hasStub <- hscGenHardCode cgguts mod_summary
 499        return (HscRecomp hasStub (), iface, details)
 500   }
 501
 502 -- Compile Haskell, boot and extCore in batch mode.
 503 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
 504 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
 505
 506 --------------------------------------------------------------
 507
 508 hscInteractiveCompiler :: HsCompiler InteractiveResult
 509 hscInteractiveCompiler =
 510   HsCompiler {
 511     hscNoRecomp = \iface -> do
 512        details <- genModDetails iface
 513        return (HscNoRecomp, iface, details)
 514
 515   , hscRecompile = genericHscRecompile hscInteractiveCompiler
 516
 517   , hscBackend = genericHscBackend hscInteractiveCompiler
 518
 519   , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
 520        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 521        return (HscRecomp False Nothing, iface, details)
 522
 523   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
 524        guts <- hscSimplify guts0
 525        (iface, _changed, details, cgguts)
 526            <- hscNormalIface guts mb_old_iface
 527        hscInteractive (iface, details, cgguts) mod_summary
 528   }
 529
 530 -- Compile Haskell, extCore to bytecode.
 531 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
 532 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
 533
 534 --------------------------------------------------------------
 535
 536 hscNothingCompiler :: HsCompiler NothingResult
 537 hscNothingCompiler =
 538   HsCompiler {
 539     hscNoRecomp = \iface -> do
 540        details <- genModDetails iface
 541        return (HscNoRecomp, iface, details)
 542
 543   , hscRecompile = genericHscRecompile hscNothingCompiler
 544
 545   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
 546        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
 547        return (HscRecomp False (), iface, details)
 548
 549   , hscGenBootOutput = \_ _ _ ->
 550         panic "hscCompileNothing: hscGenBootOutput should not be called"
 551
 552   , hscGenOutput = \_ _ _ ->
 553         panic "hscCompileNothing: hscGenOutput should not be called"
 554   }
 555
 556 -- Type-check Haskell and .hs-boot only (no external core)
 557 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
 558 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
 559
 560 --------------------------------------------------------------
 561 -- NoRecomp handlers
 562 --------------------------------------------------------------
 563
 564 genModDetails :: GhcMonad m => ModIface -> m ModDetails
 565 genModDetails old_iface =
 566     withSession $ \hsc_env -> liftIO $ do
 567       new_details <- {-# SCC "tcRnIface" #-}
 568                      initIfaceCheck hsc_env $
 569                      typecheckIface old_iface
 570       dumpIfaceStats hsc_env
 571       return new_details
 572
 573 --------------------------------------------------------------
 574 -- Progress displayers.
 575 --------------------------------------------------------------
 576
 577 oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
 578 oneShotMsg _mb_mod_index recomp _mod_summary
 579     = do hsc_env <- getSession
 580          liftIO $ do
 581          if recomp
 582             then return ()
 583             else compilationProgressMsg (hsc_dflags hsc_env) $
 584                      "compilation IS NOT required"
 585
 586 batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m ()
 587 batchMsg mb_mod_index recomp mod_summary
 588     = do hsc_env <- getSession
 589          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
 590                            (showModuleIndex mb_mod_index ++
 591                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
 592          liftIO $ do
 593          if recomp
 594             then showMsg "Compiling "
 595             else if verbosity (hsc_dflags hsc_env) >= 2
 596                     then showMsg "Skipping  "
 597                     else return ()
 598
 599 --------------------------------------------------------------
 600 -- FrontEnds
 601 --------------------------------------------------------------
 602 hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv
 603 hscFileFrontEnd mod_summary =
 604     do rdr_module <- hscParse mod_summary
 605        hscTypecheck mod_summary rdr_module
 606
 607 --------------------------------------------------------------
 608 -- Simplifiers
 609 --------------------------------------------------------------
 610
 611 hscSimplify :: GhcMonad m => ModGuts -> m ModGuts
 612 hscSimplify ds_result
 613   = do hsc_env <- getSession
 614        simpl_result <- {-# SCC "Core2Core" #-}
 615                        liftIO $ core2core hsc_env ds_result
 616        return simpl_result
 617
 618 --------------------------------------------------------------
 619 -- Interface generators
 620 --------------------------------------------------------------
 621
 622 hscSimpleIface :: GhcMonad m =>
 623                   TcGblEnv
 624                -> Maybe Fingerprint
 625                -> m (ModIface, Bool, ModDetails)
 626 hscSimpleIface tc_result mb_old_iface
 627   = do hsc_env <- getSession
 628        details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
 629        (new_iface, no_change)
 630            <- {-# SCC "MkFinalIface" #-}
 631               ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result
 632        -- And the answer is ...
 633        liftIO $ dumpIfaceStats hsc_env
 634        return (new_iface, no_change, details)
 635
 636 hscNormalIface :: GhcMonad m =>
 637                   ModGuts
 638                -> Maybe Fingerprint
 639                -> m (ModIface, Bool, ModDetails, CgGuts)
 640 hscNormalIface simpl_result mb_old_iface
 641   = do hsc_env <- getSession
 642
 643        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
 644                              liftIO $ tidyProgram hsc_env simpl_result
 645
 646             -- BUILD THE NEW ModIface and ModDetails
 647             --  and emit external core if necessary
 648             -- This has to happen *after* code gen so that the back-end
 649             -- info has been set.  Not yet clear if it matters waiting
 650             -- until after code output
 651        (new_iface, no_change)
 652            <- {-# SCC "MkFinalIface" #-}
 653               ioMsgMaybe $ mkIface hsc_env mb_old_iface
 654                                    details simpl_result
 655         -- Emit external core
 656        -- This should definitely be here and not after CorePrep,
 657        -- because CorePrep produces unqualified constructor wrapper declarations,
 658        -- so its output isn't valid External Core (without some preprocessing).
 659        liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
 660        liftIO $ dumpIfaceStats hsc_env
 661
 662             -- Return the prepared code.
 663        return (new_iface, no_change, details, cg_guts)
 664
 665 --------------------------------------------------------------
 666 -- BackEnd combinators
 667 --------------------------------------------------------------
 668
 669 hscWriteIface :: GhcMonad m =>
 670                  ModIface -> Bool
 671               -> ModSummary
 672               -> m ()
 673 hscWriteIface iface no_change mod_summary
 674     = do hsc_env <- getSession
 675          let dflags = hsc_dflags hsc_env
 676          liftIO $ do
 677          unless no_change
 678            $ writeIfaceFile dflags (ms_location mod_summary) iface
 679
 680 -- | Compile to hard-code.
 681 hscGenHardCode :: GhcMonad m =>
 682                   CgGuts -> ModSummary
 683                -> m Bool -- ^ @True@ <=> stub.c exists
 684 hscGenHardCode cgguts mod_summary
 685     = withSession $ \hsc_env -> liftIO $ do
 686          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 687                      -- From now on, we just use the bits we need.
 688                      cg_module   = this_mod,
 689                      cg_binds    = core_binds,
 690                      cg_tycons   = tycons,
 691                      cg_dir_imps = dir_imps,
 692                      cg_foreign  = foreign_stubs,
 693                      cg_dep_pkgs = dependencies,
 694                      cg_hpc_info = hpc_info } = cgguts
 695              dflags = hsc_dflags hsc_env
 696              location = ms_location mod_summary
 697              data_tycons = filter isDataTyCon tycons
 698              -- cg_tycons includes newtypes, for the benefit of External Core,
 699              -- but we don't generate any code for newtypes
 700
 701          -------------------
 702          -- PREPARE FOR CODE GENERATION
 703          -- Do saturation and convert to A-normal form
 704          prepd_binds <- {-# SCC "CorePrep" #-}
 705                         corePrepPgm dflags core_binds data_tycons ;
 706          -----------------  Convert to STG ------------------
 707          (stg_binds, cost_centre_info)
 708              <- {-# SCC "CoreToStg" #-}
 709                 myCoreToStg dflags this_mod prepd_binds
 710
 711          ------------------  Code generation ------------------
 712          cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)
 713                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
 714                                  dir_imps cost_centre_info
 715                                  stg_binds hpc_info
 716                          return cmms
 717                  else {-# SCC "CodeGen" #-}
 718                        codeGen dflags this_mod data_tycons
 719                                dir_imps cost_centre_info
 720                                stg_binds hpc_info
 721
 722          --- Optionally run experimental Cmm transformations ---
 723          -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
 724                  -- unless certain dflags are on, the identity function
 725          ------------------  Code output -----------------------
 726          rawcmms <- cmmToRawCmm cmms
 727          dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
 728          (_stub_h_exists, stub_c_exists)
 729              <- codeOutput dflags this_mod location foreign_stubs
 730                 dependencies rawcmms
 731          return stub_c_exists
 732
 733 hscInteractive :: GhcMonad m =>
 734                   (ModIface, ModDetails, CgGuts)
 735                -> ModSummary
 736                -> m (InteractiveStatus, ModIface, ModDetails)
 737 #ifdef GHCI
 738 hscInteractive (iface, details, cgguts) mod_summary
 739     = do hsc_env <- getSession
 740          liftIO $ do
 741          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 742                      -- From now on, we just use the bits we need.
 743                      cg_module   = this_mod,
 744                      cg_binds    = core_binds,
 745                      cg_tycons   = tycons,
 746                      cg_foreign  = foreign_stubs,
 747                      cg_modBreaks = mod_breaks } = cgguts
 748              dflags = hsc_dflags hsc_env
 749              location = ms_location mod_summary
 750              data_tycons = filter isDataTyCon tycons
 751              -- cg_tycons includes newtypes, for the benefit of External Core,
 752              -- but we don't generate any code for newtypes
 753
 754          -------------------
 755          -- PREPARE FOR CODE GENERATION
 756          -- Do saturation and convert to A-normal form
 757          prepd_binds <- {-# SCC "CorePrep" #-}
 758                         corePrepPgm dflags core_binds data_tycons ;
 759          -----------------  Generate byte code ------------------
 760          comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
 761          ------------------ Create f-x-dynamic C-side stuff ---
 762          (_istub_h_exists, istub_c_exists)
 763              <- outputForeignStubs dflags this_mod location foreign_stubs
 764          return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
 765                 , iface, details)
 766 #else
 767 hscInteractive _ _ = panic "GHC not compiled with interpreter"
 768 #endif
 769
 770 ------------------------------
 771
 772 hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
 773 hscCmmFile hsc_env filename = do
 774     dflags <- return $ hsc_dflags hsc_env
 775     cmm <- ioMsgMaybe $
 776              parseCmmFile dflags filename
 777     cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
 778     rawCmms <- liftIO $ cmmToRawCmm cmms
 779     _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
 780     return ()
 781   where
 782         no_mod = panic "hscCmmFile: no_mod"
 783         no_loc = ModLocation{ ml_hs_file  = Just filename,
 784                               ml_hi_file  = panic "hscCmmFile: no hi file",
 785                               ml_obj_file = panic "hscCmmFile: no obj file" }
 786
 787 -------------------- Stuff for new code gen ---------------------
 788
 789 tryNewCodeGen   :: HscEnv -> Module -> [TyCon] -> [Module]
 790                 -> CollectedCCs
 791                 -> [(StgBinding,[(Id,[Id])])]
 792                 -> HpcInfo
 793                 -> IO [Cmm]
 794 tryNewCodeGen hsc_env this_mod data_tycons imported_mods
 795               cost_centre_info stg_binds hpc_info =
 796   do    { let dflags = hsc_dflags hsc_env
 797         ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods
 798                          cost_centre_info stg_binds hpc_info
 799         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
 800                 (pprCmms prog)
 801
 802         ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
 803                 -- Control flow optimisation
 804
 805         -- We are building a single SRT for the entire module, so
 806         -- we must thread it through all the procedures as we cps-convert them.
 807         ; us <- mkSplitUniqSupply 'S'
 808         ; let topSRT = initUs_ us emptySRT
 809         ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
 810                 -- The main CPS conversion
 811
 812         ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
 813                 -- Control flow optimisation, again
 814
 815         ; let prog' = map cmmOfZgraph prog
 816         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
 817         ; return prog' }
 818
 819
 820 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
 821 optionallyConvertAndOrCPS hsc_env cmms =
 822     do let dflags = hsc_dflags hsc_env
 823         --------  Optionally convert to and from zipper ------
 824        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
 825                then mapM (testCmmConversion hsc_env) cmms
 826                else return cmms
 827          ---------  Optionally convert to CPS (MDA) -----------
 828        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
 829                   dopt Opt_RunCPS dflags
 830                then cmmCPS dflags cmms
 831                else return cmms
 832        return cmms
 833
 834
 835 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
 836 testCmmConversion hsc_env cmm =
 837     do let dflags = hsc_dflags hsc_env
 838        showPass dflags "CmmToCmm"
 839        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
 840        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
 841        us <- mkSplitUniqSupply 'C'
 842        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
 843        let cvtm = do g <- cmmToZgraph cmm
 844                      return $ cfopts g
 845        let zgraph = initUs_ us cvtm
 846        us <- mkSplitUniqSupply 'S'
 847        let topSRT = initUs_ us emptySRT
 848        (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
 849        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
 850        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
 851        showPass dflags "Convert from Z back to Cmm"
 852        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
 853        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
 854        return cvt
 855
 856 myCoreToStg :: DynFlags -> Module -> [CoreBind]
 857             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
 858                   , CollectedCCs) -- cost centre info (declared and used)
 859
 860 myCoreToStg dflags this_mod prepd_binds
 861  = do
 862       stg_binds <- {-# SCC "Core2Stg" #-}
 863              coreToStg (thisPackage dflags) prepd_binds
 864
 865       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 866              stg2stg dflags this_mod stg_binds
 867
 868       return (stg_binds2, cost_centre_info)
 869 \end{code}
 870
 871
 872 %************************************************************************
 873 %*                                                                      *
 874 \subsection{Compiling a do-statement}
 875 %*                                                                      *
 876 %************************************************************************
 877
 878 When the UnlinkedBCOExpr is linked you get an HValue of type
 879         IO [HValue]
 880 When you run it you get a list of HValues that should be
 881 the same length as the list of names; add them to the ClosureEnv.
 882
 883 A naked expression returns a singleton Name [it].
 884
 885         What you type                   The IO [HValue] that hscStmt returns
 886         -------------                   ------------------------------------
 887         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 888                                         bindings: [x,y,...]
 889
 890         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 891                                         bindings: [x,y,...]
 892
 893         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 894           [NB: result not printed]      bindings: [it]
 895
 896
 897         expr (of non-IO type,
 898           result showable)      ==>     let v = expr in print v >> return [v]
 899                                         bindings: [it]
 900
 901         expr (of non-IO type,
 902           result not showable)  ==>     error
 903
 904 \begin{code}
 905 #ifdef GHCI
 906 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 907   :: GhcMonad m =>
 908      HscEnv
 909   -> String                     -- The statement
 910   -> m (Maybe ([Id], HValue))
 911      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
 912 hscStmt hsc_env stmt = do
 913     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 914     case maybe_stmt of
 915       Nothing -> return Nothing
 916       Just parsed_stmt -> do  -- The real stuff
 917
 918              -- Rename and typecheck it
 919         let icontext = hsc_IC hsc_env
 920         (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
 921             -- Desugar it
 922         let rdr_env  = ic_rn_gbl_env icontext
 923             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 924         ds_expr <- ioMsgMaybe $
 925                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 926
 927         -- Then desugar, code gen, and link it
 928         let src_span = srcLocSpan interactiveSrcLoc
 929         hval <- liftIO $ compileExpr hsc_env src_span ds_expr
 930
 931         return $ Just (ids, hval)
 932
 933 hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
 934 hscImport hsc_env str = do
 935     (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
 936     case is of
 937         [i] -> return (unLoc i)
 938         _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))
 939
 940 hscTcExpr       -- Typecheck an expression (but don't run it)
 941   :: GhcMonad m =>
 942      HscEnv
 943   -> String                     -- The expression
 944   -> m Type
 945
 946 hscTcExpr hsc_env expr = do
 947     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 948     let icontext = hsc_IC hsc_env
 949     case maybe_stmt of
 950       Just (L _ (ExprStmt expr _ _)) -> do
 951           ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
 952           return ty
 953       _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
 954                         noSrcSpan
 955                         (text "not an expression:" <+> quotes (text expr))
 956
 957 -- | Find the kind of a type
 958 hscKcType
 959   :: GhcMonad m =>
 960      HscEnv
 961   -> String                     -- ^ The type
 962   -> m Kind
 963
 964 hscKcType hsc_env str = do
 965     ty <- hscParseType (hsc_dflags hsc_env) str
 966     let icontext = hsc_IC hsc_env
 967     ioMsgMaybe $ tcRnType hsc_env icontext ty
 968
 969 #endif
 970 \end{code}
 971
 972 \begin{code}
 973 #ifdef GHCI
 974 hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
 975 hscParseStmt = hscParseThing parseStmt
 976
 977 hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
 978 hscParseType = hscParseThing parseType
 979 #endif
 980
 981 hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
 982 hscParseIdentifier = hscParseThing parseIdentifier
 983
 984 hscParseThing :: (Outputable thing, GhcMonad m)
 985               => Lexer.P thing
 986               -> DynFlags -> String
 987               -> m thing
 988         -- Nothing => Parse error (message already printed)
 989         -- Just x  => success
 990 hscParseThing parser dflags str
 991  = (liftIO $ showPass dflags "Parser") >>
 992       {-# SCC "Parser" #-} do
 993
 994       buf <- liftIO $ stringToStringBuffer str
 995
 996       let loc  = mkSrcLoc (fsLit "<interactive>") 1 1
 997
 998       case unP parser (mkPState dflags buf loc) of
 999
1000         PFailed span err -> do
1001           let msg = mkPlainErrMsg span err
1002           throw (mkSrcErr (unitBag msg))
1003
1004         POk pst thing -> do
1005
1006           let ms@(warns, errs) = getMessages pst
1007           logWarnings warns
1008           when (errorsFound dflags ms) $ -- handle -Werror
1009             throw (mkSrcErr errs)
1010
1011           --ToDo: can't free the string buffer until we've finished this
1012           -- compilation sweep and all the identifiers have gone away.
1013           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1014           return thing
1015 \end{code}
1016
1017 %************************************************************************
1018 %*                                                                      *
1019         Desugar, simplify, convert to bytecode, and link an expression
1020 %*                                                                      *
1021 %************************************************************************
1022
1023 \begin{code}
1024 #ifdef GHCI
1025 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1026
1027 compileExpr hsc_env srcspan ds_expr
1028   | rtsIsProfiled
1029   = throwIO (InstallationError "You can't call compileExpr in a profiled compiler")
1030           -- Otherwise you get a seg-fault when you run it
1031
1032   | otherwise
1033   = do  { let { dflags  = hsc_dflags hsc_env ;
1034                 lint_on = dopt Opt_DoCoreLinting dflags }
1035
1036                 -- Simplify it
1037         ; simpl_expr <- simplifyExpr dflags ds_expr
1038
1039                 -- Tidy it (temporary, until coreSat does cloning)
1040         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1041
1042                 -- Prepare for codegen
1043         ; prepd_expr <- corePrepExpr dflags tidy_expr
1044
1045                 -- Lint if necessary
1046                 -- ToDo: improve SrcLoc
1047         ; if lint_on then
1048                 let ictxt = hsc_IC hsc_env
1049                     tyvars = varSetElems (ic_tyvars ictxt)
1050                 in
1051                 case lintUnfolding noSrcLoc tyvars prepd_expr of
1052                    Just err -> pprPanic "compileExpr" err
1053                    Nothing  -> return ()
1054           else
1055                 return ()
1056
1057                 -- Convert to BCOs
1058         ; bcos <- coreExprToBCOs dflags prepd_expr
1059
1060                 -- link it
1061         ; hval <- linkExpr hsc_env srcspan bcos
1062
1063         ; return hval
1064      }
1065 #endif
1066 \end{code}
1067
1068
1069 %************************************************************************
1070 %*                                                                      *
1071         Statistics on reading interfaces
1072 %*                                                                      *
1073 %************************************************************************
1074
1075 \begin{code}
1076 dumpIfaceStats :: HscEnv -> IO ()
1077 dumpIfaceStats hsc_env
1078   = do  { eps <- readIORef (hsc_EPS hsc_env)
1079         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1080                     "Interface statistics"
1081                     (ifaceStats eps) }
1082   where
1083     dflags = hsc_dflags hsc_env
1084     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1085     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1086 \end{code}
1087
1088 %************************************************************************
1089 %*                                                                      *
1090         Progress Messages: Module i of n
1091 %*                                                                      *
1092 %************************************************************************
1093
1094 \begin{code}
1095 showModuleIndex :: Maybe (Int, Int) -> String
1096 showModuleIndex Nothing = ""
1097 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1098     where
1099         n_str = show n
1100         i_str = show i
1101         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1102 \end{code}