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