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