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