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