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