compiler/main/HscMain.lhs

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