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