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