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