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