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 "New Cmm" (pprCmms prog)
 777
 778         ; return $ map cmmOfZgraph prog }
 779
 780
 781 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
 782 optionallyConvertAndOrCPS hsc_env cmms =
 783     do let dflags = hsc_dflags hsc_env
 784         --------  Optionally convert to and from zipper ------
 785        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
 786                then mapM (testCmmConversion hsc_env) cmms
 787                else return cmms
 788          ---------  Optionally convert to CPS (MDA) -----------
 789        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
 790                   dopt Opt_RunCPS dflags
 791                then cmmCPS dflags cmms
 792                else return cmms
 793        return cmms
 794
 795
 796 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
 797 testCmmConversion hsc_env cmm =
 798     do let dflags = hsc_dflags hsc_env
 799        showPass dflags "CmmToCmm"
 800        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
 801        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
 802        us <- mkSplitUniqSupply 'C'
 803        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
 804        let cvtm = do g <- cmmToZgraph cmm
 805                      return $ cfopts g
 806        let zgraph = initUs_ us cvtm
 807        us <- mkSplitUniqSupply 'S'
 808        let topSRT = initUs_ us emptySRT
 809        (topSRT, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
 810        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
 811        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
 812        showPass dflags "Convert from Z back to Cmm"
 813        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
 814        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
 815        return cvt
 816        -- return cmm -- don't use the conversion
 817
 818 myCoreToStg :: DynFlags -> Module -> [CoreBind]
 819             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
 820                   , CollectedCCs) -- cost centre info (declared and used)
 821
 822 myCoreToStg dflags this_mod prepd_binds
 823  = do
 824       stg_binds <- {-# SCC "Core2Stg" #-}
 825              coreToStg (thisPackage dflags) prepd_binds
 826
 827       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 828              stg2stg dflags this_mod stg_binds
 829
 830       return (stg_binds2, cost_centre_info)
 831 \end{code}
 832
 833
 834 %************************************************************************
 835 %*                                                                      *
 836 \subsection{Compiling a do-statement}
 837 %*                                                                      *
 838 %************************************************************************
 839
 840 When the UnlinkedBCOExpr is linked you get an HValue of type
 841         IO [HValue]
 842 When you run it you get a list of HValues that should be
 843 the same length as the list of names; add them to the ClosureEnv.
 844
 845 A naked expression returns a singleton Name [it].
 846
 847         What you type                   The IO [HValue] that hscStmt returns
 848         -------------                   ------------------------------------
 849         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 850                                         bindings: [x,y,...]
 851
 852         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 853                                         bindings: [x,y,...]
 854
 855         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 856           [NB: result not printed]      bindings: [it]
 857
 858
 859         expr (of non-IO type,
 860           result showable)      ==>     let v = expr in print v >> return [v]
 861                                         bindings: [it]
 862
 863         expr (of non-IO type,
 864           result not showable)  ==>     error
 865
 866 \begin{code}
 867 #ifdef GHCI
 868 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 869   :: GhcMonad m =>
 870      HscEnv
 871   -> String                     -- The statement
 872   -> m (Maybe ([Id], HValue))
 873      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
 874 hscStmt hsc_env stmt = do
 875     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 876     case maybe_stmt of
 877       Nothing -> return Nothing
 878       Just parsed_stmt -> do  -- The real stuff
 879
 880              -- Rename and typecheck it
 881         let icontext = hsc_IC hsc_env
 882         (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
 883             -- Desugar it
 884         let rdr_env  = ic_rn_gbl_env icontext
 885             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 886         ds_expr <- ioMsgMaybe $
 887                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 888
 889         -- Then desugar, code gen, and link it
 890         let src_span = srcLocSpan interactiveSrcLoc
 891         hval <- liftIO $ compileExpr hsc_env src_span ds_expr
 892
 893         return $ Just (ids, hval)
 894
 895
 896 hscTcExpr       -- Typecheck an expression (but don't run it)
 897   :: GhcMonad m =>
 898      HscEnv
 899   -> String                     -- The expression
 900   -> m Type
 901
 902 hscTcExpr hsc_env expr = do
 903     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 904     let icontext = hsc_IC hsc_env
 905     case maybe_stmt of
 906       Just (L _ (ExprStmt expr _ _)) -> do
 907           ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
 908           return ty
 909       _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
 910                         noSrcSpan
 911                         (text "not an expression:" <+> quotes (text expr))
 912
 913 -- | Find the kind of a type
 914 hscKcType
 915   :: GhcMonad m =>
 916      HscEnv
 917   -> String                     -- ^ The type
 918   -> m Kind
 919
 920 hscKcType hsc_env str = do
 921     ty <- hscParseType (hsc_dflags hsc_env) str
 922     let icontext = hsc_IC hsc_env
 923     ioMsgMaybe $ tcRnType hsc_env icontext ty
 924
 925 #endif
 926 \end{code}
 927
 928 \begin{code}
 929 #ifdef GHCI
 930 hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
 931 hscParseStmt = hscParseThing parseStmt
 932
 933 hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
 934 hscParseType = hscParseThing parseType
 935 #endif
 936
 937 hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
 938 hscParseIdentifier = hscParseThing parseIdentifier
 939
 940 hscParseThing :: (Outputable thing, GhcMonad m)
 941               => Lexer.P thing
 942               -> DynFlags -> String
 943               -> m thing
 944         -- Nothing => Parse error (message already printed)
 945         -- Just x  => success
 946 hscParseThing parser dflags str
 947  = (liftIO $ showPass dflags "Parser") >>
 948       {-# SCC "Parser" #-} do
 949
 950       buf <- liftIO $ stringToStringBuffer str
 951
 952       let loc  = mkSrcLoc (fsLit "<interactive>") 1 0
 953
 954       case unP parser (mkPState buf loc dflags) of
 955
 956         PFailed span err -> do
 957           let msg = mkPlainErrMsg span err
 958           throw (mkSrcErr (unitBag msg))
 959
 960         POk pst thing -> do
 961
 962           let ms@(warns, errs) = getMessages pst
 963           logWarnings warns
 964           when (errorsFound dflags ms) $ -- handle -Werror
 965             throw (mkSrcErr errs)
 966
 967           --ToDo: can't free the string buffer until we've finished this
 968           -- compilation sweep and all the identifiers have gone away.
 969           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
 970           return thing
 971 \end{code}
 972
 973 %************************************************************************
 974 %*                                                                      *
 975         Desugar, simplify, convert to bytecode, and link an expression
 976 %*                                                                      *
 977 %************************************************************************
 978
 979 \begin{code}
 980 #ifdef GHCI
 981 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 982
 983 compileExpr hsc_env srcspan ds_expr
 984   = do  { let { dflags  = hsc_dflags hsc_env ;
 985                 lint_on = dopt Opt_DoCoreLinting dflags }
 986
 987                 -- Simplify it
 988         ; simpl_expr <- simplifyExpr dflags ds_expr
 989
 990                 -- Tidy it (temporary, until coreSat does cloning)
 991         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 992
 993                 -- Prepare for codegen
 994         ; prepd_expr <- corePrepExpr dflags tidy_expr
 995
 996                 -- Lint if necessary
 997                 -- ToDo: improve SrcLoc
 998         ; if lint_on then
 999                 let ictxt = hsc_IC hsc_env
1000                     tyvars = varSetElems (ic_tyvars ictxt)
1001                 in
1002                 case lintUnfolding noSrcLoc tyvars prepd_expr of
1003                    Just err -> pprPanic "compileExpr" err
1004                    Nothing  -> return ()
1005           else
1006                 return ()
1007
1008                 -- Convert to BCOs
1009         ; bcos <- coreExprToBCOs dflags prepd_expr
1010
1011                 -- link it
1012         ; hval <- linkExpr hsc_env srcspan bcos
1013
1014         ; return hval
1015      }
1016 #endif
1017 \end{code}
1018
1019
1020 %************************************************************************
1021 %*                                                                      *
1022         Statistics on reading interfaces
1023 %*                                                                      *
1024 %************************************************************************
1025
1026 \begin{code}
1027 dumpIfaceStats :: HscEnv -> IO ()
1028 dumpIfaceStats hsc_env
1029   = do  { eps <- readIORef (hsc_EPS hsc_env)
1030         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1031                     "Interface statistics"
1032                     (ifaceStats eps) }
1033   where
1034     dflags = hsc_dflags hsc_env
1035     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1036     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1037 \end{code}
1038
1039 %************************************************************************
1040 %*                                                                      *
1041         Progress Messages: Module i of n
1042 %*                                                                      *
1043 %************************************************************************
1044
1045 \begin{code}
1046 showModuleIndex :: Maybe (Int, Int) -> String
1047 showModuleIndex Nothing = ""
1048 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1049     where
1050         n_str = show n
1051         i_str = show i
1052         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1053 \end{code}