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        emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006
 581        dumpIfaceStats hsc_env
 582
 583             -------------------
 584             -- Return the prepared code.
 585        return (new_iface, no_change, details, cg_guts)
 586
 587 --------------------------------------------------------------
 588 -- BackEnd combinators
 589 --------------------------------------------------------------
 590
 591 hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 592 hscWriteIface (iface, no_change, details, a)
 593     = do mod_summary <- gets compModSummary
 594          hsc_env <- gets compHscEnv
 595          let dflags = hsc_dflags hsc_env
 596          liftIO $ do
 597          unless no_change
 598            $ writeIfaceFile dflags (ms_location mod_summary) iface
 599          return (iface, details, a)
 600
 601 hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 602 hscIgnoreIface (iface, _no_change, details, a)
 603     = return (iface, details, a)
 604
 605 -- Don't output any code.
 606 hscNothing :: (ModIface, ModDetails, a) -> Comp (Maybe (HscStatus, ModIface, ModDetails))
 607 hscNothing (iface, details, _)
 608     = return (Just (HscRecomp False, iface, details))
 609
 610 -- Generate code and return both the new ModIface and the ModDetails.
 611 hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe (HscStatus, ModIface, ModDetails))
 612 hscBatch (iface, details, cgguts)
 613     = do hasStub <- hscCompile cgguts
 614          return (Just (HscRecomp hasStub, iface, details))
 615
 616 -- Here we don't need the ModIface and ModDetails anymore.
 617 hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe HscStatus)
 618 hscOneShot (_, _, cgguts)
 619     = do hasStub <- hscCompile cgguts
 620          return (Just (HscRecomp hasStub))
 621
 622 -- Compile to hard-code.
 623 hscCompile :: CgGuts -> Comp Bool
 624 hscCompile cgguts
 625     = do hsc_env <- gets compHscEnv
 626          mod_summary <- gets compModSummary
 627          liftIO $ do
 628          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 629                      -- From now on, we just use the bits we need.
 630                      cg_module   = this_mod,
 631                      cg_binds    = core_binds,
 632                      cg_tycons   = tycons,
 633                      cg_dir_imps = dir_imps,
 634                      cg_foreign  = foreign_stubs,
 635                      cg_dep_pkgs = dependencies,
 636                      cg_hpc_info = hpc_info } = cgguts
 637              dflags = hsc_dflags hsc_env
 638              location = ms_location mod_summary
 639              data_tycons = filter isDataTyCon tycons
 640              -- cg_tycons includes newtypes, for the benefit of External Core,
 641              -- but we don't generate any code for newtypes
 642
 643          -------------------
 644          -- PREPARE FOR CODE GENERATION
 645          -- Do saturation and convert to A-normal form
 646          prepd_binds <- {-# SCC "CorePrep" #-}
 647                         corePrepPgm dflags core_binds data_tycons ;
 648          -----------------  Convert to STG ------------------
 649          (stg_binds, cost_centre_info)
 650              <- {-# SCC "CoreToStg" #-}
 651                 myCoreToStg dflags this_mod prepd_binds
 652          ------------------  Code generation ------------------
 653          cmms <- {-# SCC "CodeGen" #-}
 654                       codeGen dflags this_mod data_tycons
 655                               dir_imps cost_centre_info
 656                               stg_binds hpc_info
 657          --- Optionally run experimental Cmm transformations ---
 658          cmms <- optionallyConvertAndOrCPS dflags cmms
 659                  -- ^ unless certain dflags are on, the identity function
 660          ------------------  Code output -----------------------
 661          rawcmms <- cmmToRawCmm cmms
 662          (_stub_h_exists, stub_c_exists)
 663              <- codeOutput dflags this_mod location foreign_stubs
 664                 dependencies rawcmms
 665          return stub_c_exists
 666
 667 hscInteractive :: (ModIface, ModDetails, CgGuts)
 668                -> Comp (Maybe (InteractiveStatus, ModIface, ModDetails))
 669 #ifdef GHCI
 670 hscInteractive (iface, details, cgguts)
 671     = do hsc_env <- gets compHscEnv
 672          mod_summary <- gets compModSummary
 673          liftIO $ do
 674          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 675                      -- From now on, we just use the bits we need.
 676                      cg_module   = this_mod,
 677                      cg_binds    = core_binds,
 678                      cg_tycons   = tycons,
 679                      cg_foreign  = foreign_stubs,
 680                      cg_modBreaks = mod_breaks } = cgguts
 681              dflags = hsc_dflags hsc_env
 682              location = ms_location mod_summary
 683              data_tycons = filter isDataTyCon tycons
 684              -- cg_tycons includes newtypes, for the benefit of External Core,
 685              -- but we don't generate any code for newtypes
 686
 687          -------------------
 688          -- PREPARE FOR CODE GENERATION
 689          -- Do saturation and convert to A-normal form
 690          prepd_binds <- {-# SCC "CorePrep" #-}
 691                         corePrepPgm dflags core_binds data_tycons ;
 692          -----------------  Generate byte code ------------------
 693          comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
 694          ------------------ Create f-x-dynamic C-side stuff ---
 695          (_istub_h_exists, istub_c_exists)
 696              <- outputForeignStubs dflags this_mod location foreign_stubs
 697          return (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details))
 698 #else
 699 hscInteractive _ = panic "GHC not compiled with interpreter"
 700 #endif
 701
 702 ------------------------------
 703
 704 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 705 hscCmmFile dflags filename = do
 706   maybe_cmm <- parseCmmFile dflags filename
 707   case maybe_cmm of
 708     Nothing -> return False
 709     Just cmm -> do
 710         cmms <- optionallyConvertAndOrCPS dflags [cmm]
 711         rawCmms <- cmmToRawCmm cmms
 712         codeOutput dflags no_mod no_loc NoStubs [] rawCmms
 713         return True
 714   where
 715         no_mod = panic "hscCmmFile: no_mod"
 716         no_loc = ModLocation{ ml_hs_file  = Just filename,
 717                               ml_hi_file  = panic "hscCmmFile: no hi file",
 718                               ml_obj_file = panic "hscCmmFile: no obj file" }
 719
 720 optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm]
 721 optionallyConvertAndOrCPS dflags cmms =
 722     do   --------  Optionally convert to and from zipper ------
 723        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
 724                then mapM (testCmmConversion dflags) cmms
 725                else return cmms
 726          ---------  Optionally convert to CPS (MDA) -----------
 727        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
 728                   dopt Opt_RunCPSZ dflags
 729                then cmmCPS dflags cmms
 730                else return cmms
 731        return cmms
 732
 733
 734 testCmmConversion :: DynFlags -> Cmm -> IO Cmm
 735 testCmmConversion dflags cmm =
 736     do showPass dflags "CmmToCmm"
 737        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
 738        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
 739        us <- mkSplitUniqSupply 'C'
 740        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
 741        let cvtm = do g <- cmmToZgraph cmm
 742                      return $ cfopts g
 743        let zgraph = initUs_ us cvtm
 744        cps_zgraph <- protoCmmCPSZ dflags zgraph
 745        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
 746        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
 747        showPass dflags "Convert from Z back to Cmm"
 748        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
 749        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
 750        return cvt
 751        -- return cmm -- don't use the conversion
 752
 753 myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
 754               -> IO (Either ErrMsg (Located (HsModule RdrName)))
 755 myParseModule dflags src_filename maybe_src_buf
 756  =    --------------------------  Parser  ----------------
 757       showPass dflags "Parser" >>
 758       {-# SCC "Parser" #-} do
 759
 760         -- sometimes we already have the buffer in memory, perhaps
 761         -- because we needed to parse the imports out of it, or get the
 762         -- module name.
 763       buf <- case maybe_src_buf of
 764                 Just b  -> return b
 765                 Nothing -> hGetStringBuffer src_filename
 766
 767       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 768
 769       case unP parseModule (mkPState buf loc dflags) of {
 770
 771         PFailed span err -> return (Left (mkPlainErrMsg span err));
 772
 773         POk pst rdr_module -> do {
 774
 775       let {ms = getMessages pst};
 776       printErrorsAndWarnings dflags ms;
 777       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 778
 779       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 780
 781       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 782                            (ppSourceStats False rdr_module) ;
 783
 784       return (Right rdr_module)
 785         -- ToDo: free the string buffer later.
 786       }}
 787
 788
 789 myCoreToStg :: DynFlags -> Module -> [CoreBind]
 790             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
 791                   , CollectedCCs) -- cost centre info (declared and used)
 792
 793 myCoreToStg dflags this_mod prepd_binds
 794  = do
 795       stg_binds <- {-# SCC "Core2Stg" #-}
 796              coreToStg (thisPackage dflags) prepd_binds
 797
 798       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 799              stg2stg dflags this_mod stg_binds
 800
 801       return (stg_binds2, cost_centre_info)
 802 \end{code}
 803
 804
 805 %************************************************************************
 806 %*                                                                      *
 807 \subsection{Compiling a do-statement}
 808 %*                                                                      *
 809 %************************************************************************
 810
 811 When the UnlinkedBCOExpr is linked you get an HValue of type
 812         IO [HValue]
 813 When you run it you get a list of HValues that should be
 814 the same length as the list of names; add them to the ClosureEnv.
 815
 816 A naked expression returns a singleton Name [it].
 817
 818         What you type                   The IO [HValue] that hscStmt returns
 819         -------------                   ------------------------------------
 820         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 821                                         bindings: [x,y,...]
 822
 823         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 824                                         bindings: [x,y,...]
 825
 826         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 827           [NB: result not printed]      bindings: [it]
 828
 829
 830         expr (of non-IO type,
 831           result showable)      ==>     let v = expr in print v >> return [v]
 832                                         bindings: [it]
 833
 834         expr (of non-IO type,
 835           result not showable)  ==>     error
 836
 837 \begin{code}
 838 #ifdef GHCI
 839 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 840   :: HscEnv
 841   -> String                     -- The statement
 842   -> IO (Maybe ([Id], HValue))
 843
 844 hscStmt hsc_env stmt
 845   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 846         ; case maybe_stmt of {
 847              Nothing      -> return Nothing ;   -- Parse error
 848              Just Nothing -> return Nothing ;   -- Empty line
 849              Just (Just parsed_stmt) -> do {    -- The real stuff
 850
 851                 -- Rename and typecheck it
 852           let icontext = hsc_IC hsc_env
 853         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
 854
 855         ; case maybe_tc_result of {
 856                 Nothing -> return Nothing ;
 857                 Just (ids, tc_expr) -> do {
 858
 859                 -- Desugar it
 860         ; let rdr_env  = ic_rn_gbl_env icontext
 861               type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 862         ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 863
 864         ; case mb_ds_expr of {
 865                 Nothing -> return Nothing ;
 866                 Just ds_expr -> do {
 867
 868                 -- Then desugar, code gen, and link it
 869         ; let src_span = srcLocSpan interactiveSrcLoc
 870         ; hval <- compileExpr hsc_env src_span ds_expr
 871
 872         ; return (Just (ids, hval))
 873         }}}}}}}
 874
 875 hscTcExpr       -- Typecheck an expression (but don't run it)
 876   :: HscEnv
 877   -> String                     -- The expression
 878   -> IO (Maybe Type)
 879
 880 hscTcExpr hsc_env expr
 881   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 882         ; let icontext = hsc_IC hsc_env
 883         ; case maybe_stmt of {
 884              Nothing      -> return Nothing ;   -- Parse error
 885              Just (Just (L _ (ExprStmt expr _ _)))
 886                         -> tcRnExpr hsc_env icontext expr ;
 887              Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 888                                 return Nothing } ;
 889              } }
 890
 891 hscKcType       -- Find the kind of a type
 892   :: HscEnv
 893   -> String                     -- The type
 894   -> IO (Maybe Kind)
 895
 896 hscKcType hsc_env str
 897   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 898         ; let icontext = hsc_IC hsc_env
 899         ; case maybe_type of {
 900              Just ty -> tcRnType hsc_env icontext ty ;
 901              Nothing -> return Nothing } }
 902 #endif
 903 \end{code}
 904
 905 \begin{code}
 906 #ifdef GHCI
 907 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 908 hscParseStmt = hscParseThing parseStmt
 909
 910 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 911 hscParseType = hscParseThing parseType
 912 #endif
 913
 914 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 915 hscParseIdentifier = hscParseThing parseIdentifier
 916
 917 hscParseThing :: Outputable thing
 918               => Lexer.P thing
 919               -> DynFlags -> String
 920               -> IO (Maybe thing)
 921         -- Nothing => Parse error (message already printed)
 922         -- Just x  => success
 923 hscParseThing parser dflags str
 924  = showPass dflags "Parser" >>
 925       {-# SCC "Parser" #-} do
 926
 927       buf <- stringToStringBuffer str
 928
 929       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 930
 931       case unP parser (mkPState buf loc dflags) of {
 932
 933         PFailed span err -> do { printError span err;
 934                                  return Nothing };
 935
 936         POk pst thing -> do {
 937
 938       let {ms = getMessages pst};
 939       printErrorsAndWarnings dflags ms;
 940       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 941
 942       --ToDo: can't free the string buffer until we've finished this
 943       -- compilation sweep and all the identifiers have gone away.
 944       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 945       return (Just thing)
 946       }}
 947 \end{code}
 948
 949 %************************************************************************
 950 %*                                                                      *
 951         Desugar, simplify, convert to bytecode, and link an expression
 952 %*                                                                      *
 953 %************************************************************************
 954
 955 \begin{code}
 956 #ifdef GHCI
 957 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 958
 959 compileExpr hsc_env srcspan ds_expr
 960   = do  { let { dflags  = hsc_dflags hsc_env ;
 961                 lint_on = dopt Opt_DoCoreLinting dflags }
 962
 963                 -- Simplify it
 964         ; simpl_expr <- simplifyExpr dflags ds_expr
 965
 966                 -- Tidy it (temporary, until coreSat does cloning)
 967         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 968
 969                 -- Prepare for codegen
 970         ; prepd_expr <- corePrepExpr dflags tidy_expr
 971
 972                 -- Lint if necessary
 973                 -- ToDo: improve SrcLoc
 974         ; if lint_on then
 975                 let ictxt = hsc_IC hsc_env
 976                     tyvars = varSetElems (ic_tyvars ictxt)
 977                 in
 978                 case lintUnfolding noSrcLoc tyvars prepd_expr of
 979                    Just err -> pprPanic "compileExpr" err
 980                    Nothing  -> return ()
 981           else
 982                 return ()
 983
 984                 -- Convert to BCOs
 985         ; bcos <- coreExprToBCOs dflags prepd_expr
 986
 987                 -- link it
 988         ; hval <- linkExpr hsc_env srcspan bcos
 989
 990         ; return hval
 991      }
 992 #endif
 993 \end{code}
 994
 995
 996 %************************************************************************
 997 %*                                                                      *
 998         Statistics on reading interfaces
 999 %*                                                                      *
1000 %************************************************************************
1001
1002 \begin{code}
1003 dumpIfaceStats :: HscEnv -> IO ()
1004 dumpIfaceStats hsc_env
1005   = do  { eps <- readIORef (hsc_EPS hsc_env)
1006         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1007                     "Interface statistics"
1008                     (ifaceStats eps) }
1009   where
1010     dflags = hsc_dflags hsc_env
1011     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1012     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1013 \end{code}
1014
1015 %************************************************************************
1016 %*                                                                      *
1017         Progress Messages: Module i of n
1018 %*                                                                      *
1019 %************************************************************************
1020
1021 \begin{code}
1022 showModuleIndex :: Maybe (Int, Int) -> String
1023 showModuleIndex Nothing = ""
1024 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1025     where
1026         n_str = show n
1027         i_str = show i
1028         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1029 \end{code}
1030