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