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