compiler/main/HscMain.lhs

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