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