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         HscResult(..),
  10         hscMain, newHscEnv, hscCmmFile,
  11         hscBufferCheck, hscFileCheck,
  12 #ifdef GHCI
  13         , hscStmt, hscTcExpr, hscKcType
  14         , hscGetInfo, GetInfoResult
  15         , compileExpr
  16 #endif
  17         ) where
  18
  19 #include "HsVersions.h"
  20
  21 #ifdef GHCI
  22 import HsSyn            ( Stmt(..), LStmt, LHsExpr, LHsType )
  23 import IfaceSyn         ( IfaceDecl, IfaceInst )
  24 import CodeOutput       ( outputForeignStubs )
  25 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  26 import Linker           ( HValue, linkExpr )
  27 import TidyPgm          ( tidyCoreExpr )
  28 import CorePrep         ( corePrepExpr )
  29 import Flattening       ( flattenExpr )
  30 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType )
  31 import RdrName          ( rdrNameOcc )
  32 import OccName          ( occNameUserString )
  33 import Type             ( Type )
  34 import PrelNames        ( iNTERACTIVE )
  35 import StringBuffer     ( stringToStringBuffer )
  36 import Kind             ( Kind )
  37 import Var              ( Id )
  38 import CoreLint         ( lintUnfolding )
  39 import DsMeta           ( templateHaskellNames )
  40 import BasicTypes       ( Fixity )
  41 import SrcLoc           ( SrcLoc, noSrcLoc )
  42 #endif
  43
  44 import RdrName          ( RdrName )
  45 import HsSyn            ( HsModule )
  46 import SrcLoc           ( Located(..) )
  47 import StringBuffer     ( hGetStringBuffer )
  48 import Parser
  49 import Lexer            ( P(..), ParseResult(..), mkPState )
  50 import SrcLoc           ( mkSrcLoc )
  51 import TcRnDriver       ( tcRnModule, tcRnExtCore )
  52 import TcRnTypes        ( TcGblEnv )
  53 import TcIface          ( typecheckIface )
  54 import IfaceEnv         ( initNameCache )
  55 import LoadIface        ( ifaceStats, initExternalPackageState )
  56 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
  57 import RdrName          ( GlobalRdrEnv )
  58 import MkIface          ( checkOldIface, mkIface )
  59 import Desugar
  60 import Flattening       ( flatten )
  61 import SimplCore
  62 import TidyPgm          ( tidyCorePgm )
  63 import CorePrep         ( corePrepPgm )
  64 import CoreToStg        ( coreToStg )
  65 import Name             ( Name, NamedThing(..) )
  66 import SimplStg         ( stg2stg )
  67 import CodeGen          ( codeGen )
  68 import CmmParse         ( parseCmmFile )
  69 import CodeOutput       ( codeOutput )
  70
  71 import CmdLineOpts
  72 import DriverPhases     ( isExtCoreFilename )
  73 import ErrUtils
  74 import UniqSupply       ( mkSplitUniqSupply )
  75
  76 import Outputable
  77 import HscStats         ( ppSourceStats )
  78 import HscTypes
  79 import MkExternalCore   ( emitExternalCore )
  80 import ParserCore
  81 import ParserCoreUtils
  82 import Module           ( Module, ModLocation(..), showModMsg )
  83 import FastString
  84 import Maybes           ( expectJust )
  85 import StringBuffer     ( StringBuffer )
  86 import Bag              ( unitBag, emptyBag )
  87
  88 import Monad            ( when )
  89 import Maybe            ( isJust, fromJust )
  90 import IO
  91 import DATA_IOREF       ( newIORef, readIORef )
  92 \end{code}
  93
  94
  95 %************************************************************************
  96 %*                                                                      *
  97                 Initialisation
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 \begin{code}
 102 newHscEnv :: GhciMode -> DynFlags -> IO HscEnv
 103 newHscEnv ghci_mode dflags
 104   = do  { eps_var <- newIORef initExternalPackageState
 105         ; us      <- mkSplitUniqSupply 'r'
 106         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
 107         ; return (HscEnv { hsc_mode   = ghci_mode,
 108                            hsc_dflags = dflags,
 109                            hsc_HPT    = emptyHomePackageTable,
 110                            hsc_EPS    = eps_var,
 111                            hsc_NC     = nc_var } ) }
 112
 113
 114 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
 115                         -- where templateHaskellNames are defined
 116 knownKeyNames = map getName wiredInThings
 117               ++ basicKnownKeyNames
 118 #ifdef GHCI
 119               ++ templateHaskellNames
 120 #endif
 121 \end{code}
 122
 123
 124 %************************************************************************
 125 %*                                                                      *
 126                 The main compiler pipeline
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 \begin{code}
 131 data HscResult
 132    -- Compilation failed
 133    = HscFail
 134
 135    -- In IDE mode: we just do the static/dynamic checks
 136    | HscChecked (Located (HsModule RdrName)) (Maybe TcGblEnv)
 137
 138    -- Concluded that it wasn't necessary
 139    | HscNoRecomp ModDetails              -- new details (HomeSymbolTable additions)
 140                  ModIface                -- new iface (if any compilation was done)
 141
 142    -- Did recompilation
 143    | HscRecomp   ModDetails             -- new details (HomeSymbolTable additions)
 144                  (Maybe GlobalRdrEnv)
 145                  ModIface               -- new iface (if any compilation was done)
 146                  Bool                   -- stub_h exists
 147                  Bool                   -- stub_c exists
 148                  (Maybe CompiledByteCode)
 149
 150
 151 -- What to do when we have compiler error or warning messages
 152 type MessageAction = Messages -> IO ()
 153
 154         -- no errors or warnings; the individual passes
 155         -- (parse/rename/typecheck) print messages themselves
 156
 157 hscMain
 158   :: HscEnv
 159   -> MessageAction              -- what to do with errors/warnings
 160   -> Module
 161   -> ModLocation                -- location info
 162   -> Bool                       -- True <=> source unchanged
 163   -> Bool                       -- True <=> have an object file (for msgs only)
 164   -> Maybe ModIface             -- old interface, if available
 165   -> IO HscResult
 166
 167 hscMain hsc_env msg_act mod location
 168         source_unchanged have_object maybe_old_iface
 169  = do {
 170       (recomp_reqd, maybe_checked_iface) <-
 171                 _scc_ "checkOldIface"
 172                 checkOldIface hsc_env mod
 173                               (ml_hi_file location)
 174                               source_unchanged maybe_old_iface;
 175
 176       let no_old_iface = not (isJust maybe_checked_iface)
 177           what_next | recomp_reqd || no_old_iface = hscRecomp
 178                     | otherwise                   = hscNoRecomp
 179
 180       ; what_next hsc_env msg_act have_object
 181                   mod location maybe_checked_iface
 182       }
 183
 184
 185 -- hscNoRecomp definitely expects to have the old interface available
 186 hscNoRecomp hsc_env msg_act have_object
 187             mod location (Just old_iface)
 188  | isOneShot (hsc_mode hsc_env)
 189  = do {
 190       compilationProgressMsg (hsc_dflags hsc_env) $
 191         "compilation IS NOT required";
 192       dumpIfaceStats hsc_env ;
 193
 194       let { bomb = panic "hscNoRecomp:OneShot" };
 195       return (HscNoRecomp bomb bomb)
 196       }
 197  | otherwise
 198  = do {
 199       compilationProgressMsg (hsc_dflags hsc_env) $
 200         ("Skipping  " ++ showModMsg have_object mod location);
 201
 202       new_details <- _scc_ "tcRnIface"
 203                      typecheckIface hsc_env old_iface ;
 204       dumpIfaceStats hsc_env ;
 205
 206       return (HscNoRecomp new_details old_iface)
 207       }
 208
 209 hscRecomp hsc_env msg_act have_object
 210           mod location maybe_checked_iface
 211  = do   {
 212           -- what target are we shooting for?
 213         ; let one_shot  = isOneShot (hsc_mode hsc_env)
 214         ; let dflags    = hsc_dflags hsc_env
 215         ; let toInterp  = dopt_HscLang dflags == HscInterpreted
 216         ; let toCore    = isJust (ml_hs_file location) &&
 217                           isExtCoreFilename (fromJust (ml_hs_file location))
 218
 219         ; when (not one_shot) $
 220                 compilationProgressMsg dflags $
 221                   ("Compiling " ++ showModMsg (not toInterp) mod location);
 222
 223         ; let hspp_file = expectJust "hscFrontEnd:hspp" (ml_hspp_file location)
 224         ; front_res <- if toCore then
 225                           hscCoreFrontEnd hsc_env msg_act hspp_file
 226                        else
 227                           hscFileFrontEnd hsc_env msg_act hspp_file (ml_hspp_buf location)
 228
 229         ; case front_res of
 230             Left flure -> return flure;
 231             Right ds_result -> do {
 232
 233
 234         -- OMITTED:
 235         -- ; seqList imported_modules (return ())
 236
 237             -------------------
 238             -- FLATTENING
 239             -------------------
 240         ; flat_result <- _scc_ "Flattening"
 241                          flatten hsc_env ds_result
 242
 243
 244 {-      TEMP: need to review space-leak fixing here
 245         NB: even the code generator can force one of the
 246             thunks for constructor arguments, for newtypes in particular
 247
 248         ; let   -- Rule-base accumulated from imported packages
 249              pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
 250
 251                 -- In one-shot mode, ZAP the external package state at
 252                 -- this point, because we aren't going to need it from
 253                 -- now on.  We keep the name cache, however, because
 254                 -- tidyCore needs it.
 255              pcs_middle
 256                  | one_shot  = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
 257                  | otherwise = pcs_tc
 258
 259         ; pkg_rule_base `seq` pcs_middle `seq` return ()
 260 -}
 261
 262         -- alive at this point:
 263         --      pcs_middle
 264         --      flat_result
 265         --      pkg_rule_base
 266
 267             -------------------
 268             -- SIMPLIFY
 269             -------------------
 270         ; simpl_result <- _scc_ "Core2Core"
 271                           core2core hsc_env flat_result
 272
 273             -------------------
 274             -- TIDY
 275             -------------------
 276         ; tidy_result <- _scc_ "CoreTidy"
 277                          tidyCorePgm hsc_env simpl_result
 278
 279         -- Emit external core
 280         ; emitExternalCore dflags tidy_result
 281
 282         -- Alive at this point:
 283         --      tidy_result, pcs_final
 284         --      hsc_env
 285
 286             -------------------
 287             -- BUILD THE NEW ModIface and ModDetails
 288             --  and emit external core if necessary
 289             -- This has to happen *after* code gen so that the back-end
 290             -- info has been set.  Not yet clear if it matters waiting
 291             -- until after code output
 292         ; new_iface <- _scc_ "MkFinalIface"
 293                         mkIface hsc_env location
 294                                 maybe_checked_iface tidy_result
 295
 296
 297             -- Space leak reduction: throw away the new interface if
 298             -- we're in one-shot mode; we won't be needing it any
 299             -- more.
 300         ; final_iface <-
 301              if one_shot then return (error "no final iface")
 302                          else return new_iface
 303         ; let { final_globals | one_shot  = Nothing
 304                               | otherwise = Just $! (mg_rdr_env tidy_result) }
 305         ; final_globals `seq` return ()
 306
 307             -- Build the final ModDetails (except in one-shot mode, where
 308             -- we won't need this information after compilation).
 309         ; final_details <-
 310              if one_shot then return (error "no final details")
 311                          else return $! ModDetails {
 312                                            md_types = mg_types tidy_result,
 313                                            md_insts = mg_insts tidy_result,
 314                                            md_rules = mg_rules tidy_result }
 315
 316             -------------------
 317             -- CONVERT TO STG and COMPLETE CODE GENERATION
 318         ; (stub_h_exists, stub_c_exists, maybe_bcos)
 319                 <- hscBackEnd dflags tidy_result
 320
 321           -- And the answer is ...
 322         ; dumpIfaceStats hsc_env
 323
 324         ; return (HscRecomp final_details
 325                             final_globals
 326                             final_iface
 327                             stub_h_exists stub_c_exists
 328                             maybe_bcos)
 329          }}
 330
 331 hscCoreFrontEnd hsc_env msg_act hspp_file = do {
 332             -------------------
 333             -- PARSE
 334             -------------------
 335         ; inp <- readFile hspp_file
 336         ; case parseCore inp 1 of
 337             FailP s        -> putMsg s{-ToDo: wrong-} >> return (Left HscFail)
 338             OkP rdr_module -> do {
 339
 340             -------------------
 341             -- RENAME and TYPECHECK
 342             -------------------
 343         ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck"
 344                               tcRnExtCore hsc_env rdr_module
 345         ; msg_act tc_msgs
 346         ; case maybe_tc_result of {
 347              Nothing       -> return (Left  HscFail);
 348              Just mod_guts -> return (Right mod_guts)
 349                                         -- No desugaring to do!
 350         }}}
 351
 352
 353 hscFileFrontEnd hsc_env msg_act hspp_file hspp_buf = do {
 354             -------------------
 355             -- PARSE
 356             -------------------
 357         ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)  hspp_file hspp_buf
 358
 359         ; case maybe_parsed of {
 360              Left err -> do { msg_act (unitBag err, emptyBag) ;
 361                             ; return (Left HscFail) ;
 362                             };
 363              Right rdr_module -> do {
 364
 365             -------------------
 366             -- RENAME and TYPECHECK
 367             -------------------
 368         ; (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
 369                                         tcRnModule hsc_env rdr_module
 370         ; msg_act tc_msgs
 371         ; case maybe_tc_result of {
 372              Nothing -> return (Left HscFail);
 373              Just tc_result -> do {
 374
 375             -------------------
 376             -- DESUGAR
 377             -------------------
 378         ; (warns, maybe_ds_result) <- _scc_ "DeSugar"
 379                              deSugar hsc_env tc_result
 380         ; msg_act (warns, emptyBag)
 381         ; case maybe_ds_result of
 382             Nothing        -> return (Left HscFail);
 383             Just ds_result -> return (Right ds_result);
 384         }}}}}
 385
 386
 387 hscFileCheck hsc_env msg_act hspp_file = do {
 388             -------------------
 389             -- PARSE
 390             -------------------
 391         ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)  hspp_file Nothing
 392
 393         ; case maybe_parsed of {
 394              Left err -> do { msg_act (unitBag err, emptyBag) ;
 395                             ; return HscFail ;
 396                             };
 397              Right rdr_module -> hscBufferTypecheck hsc_env rdr_module msg_act
 398         }}
 399
 400
 401 -- Perform static/dynamic checks on the source code in a StringBuffer
 402 -- This is a temporary solution: it'll read in interface files lazily, whereas
 403 -- we probably want to use the compilation manager to load in all the modules
 404 -- in a project.
 405 hscBufferCheck :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
 406 hscBufferCheck hsc_env buffer msg_act = do
 407         let loc  = mkSrcLoc (mkFastString "*edit*") 1 0
 408         showPass (hsc_dflags hsc_env) "Parser"
 409         case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of
 410                 PFailed span err -> do
 411                    msg_act (emptyBag, unitBag (mkPlainErrMsg span err))
 412                    return HscFail
 413                 POk _ rdr_module -> do
 414                    hscBufferTypecheck hsc_env rdr_module msg_act
 415
 416 hscBufferTypecheck hsc_env rdr_module msg_act = do
 417         (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
 418                                         tcRnModule hsc_env rdr_module
 419         msg_act tc_msgs
 420         case maybe_tc_result of
 421             Nothing  -> return (HscChecked rdr_module Nothing)
 422                                 -- space leak on rdr_module!
 423             Just r -> return (HscChecked rdr_module (Just r))
 424
 425
 426 hscBackEnd dflags
 427     ModGuts{  -- This is the last use of the ModGuts in a compilation.
 428               -- From now on, we just use the bits we need.
 429         mg_module   = this_mod,
 430         mg_binds    = core_binds,
 431         mg_types    = type_env,
 432         mg_dir_imps = dir_imps,
 433         mg_foreign  = foreign_stubs,
 434         mg_deps     = dependencies     }  = do {
 435
 436             -------------------
 437             -- PREPARE FOR CODE GENERATION
 438             -- Do saturation and convert to A-normal form
 439   prepd_binds <- _scc_ "CorePrep"
 440                  corePrepPgm dflags core_binds type_env;
 441
 442   case dopt_HscLang dflags of
 443       HscNothing -> return (False, False, Nothing)
 444
 445       HscInterpreted ->
 446 #ifdef GHCI
 447         do  -----------------  Generate byte code ------------------
 448             comp_bc <- byteCodeGen dflags prepd_binds type_env
 449
 450             ------------------ Create f-x-dynamic C-side stuff ---
 451             (istub_h_exists, istub_c_exists)
 452                <- outputForeignStubs dflags foreign_stubs
 453
 454             return ( istub_h_exists, istub_c_exists, Just comp_bc )
 455 #else
 456         panic "GHC not compiled with interpreter"
 457 #endif
 458
 459       other ->
 460         do
 461             -----------------  Convert to STG ------------------
 462             (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
 463                          myCoreToStg dflags this_mod prepd_binds
 464
 465             ------------------  Code generation ------------------
 466             abstractC <- _scc_ "CodeGen"
 467                          codeGen dflags this_mod type_env foreign_stubs
 468                                  dir_imps cost_centre_info stg_binds
 469
 470             ------------------  Code output -----------------------
 471             (stub_h_exists, stub_c_exists)
 472                      <- codeOutput dflags this_mod foreign_stubs
 473                                 dependencies abstractC
 474
 475             return (stub_h_exists, stub_c_exists, Nothing)
 476    }
 477
 478
 479 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 480 hscCmmFile dflags filename = do
 481   maybe_cmm <- parseCmmFile dflags filename
 482   case maybe_cmm of
 483     Nothing -> return False
 484     Just cmm -> do
 485         codeOutput dflags no_mod NoStubs noDependencies [cmm]
 486         return True
 487   where
 488         no_mod = panic "hscCmmFile: no_mod"
 489
 490
 491 myParseModule dflags src_filename maybe_src_buf
 492  = do --------------------------  Parser  ----------------
 493       showPass dflags "Parser"
 494       _scc_  "Parser" do
 495
 496         -- sometimes we already have the buffer in memory, perhaps
 497         -- because we needed to parse the imports out of it, or get the
 498         -- module name.
 499       buf <- case maybe_src_buf of
 500                 Just b  -> return b
 501                 Nothing -> hGetStringBuffer src_filename
 502
 503       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 504
 505       case unP parseModule (mkPState buf loc dflags) of {
 506
 507         PFailed span err -> return (Left (mkPlainErrMsg span err));
 508
 509         POk _ rdr_module -> do {
 510
 511       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 512
 513       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 514                            (ppSourceStats False rdr_module) ;
 515
 516       return (Right rdr_module)
 517         -- ToDo: free the string buffer later.
 518       }}
 519
 520
 521 myCoreToStg dflags this_mod prepd_binds
 522  = do
 523       stg_binds <- _scc_ "Core2Stg"
 524              coreToStg dflags prepd_binds
 525
 526       (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
 527              stg2stg dflags this_mod stg_binds
 528
 529       return (stg_binds2, cost_centre_info)
 530 \end{code}
 531
 532
 533 %************************************************************************
 534 %*                                                                      *
 535 \subsection{Compiling a do-statement}
 536 %*                                                                      *
 537 %************************************************************************
 538
 539 When the UnlinkedBCOExpr is linked you get an HValue of type
 540         IO [HValue]
 541 When you run it you get a list of HValues that should be
 542 the same length as the list of names; add them to the ClosureEnv.
 543
 544 A naked expression returns a singleton Name [it].
 545
 546         What you type                   The IO [HValue] that hscStmt returns
 547         -------------                   ------------------------------------
 548         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 549                                         bindings: [x,y,...]
 550
 551         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 552                                         bindings: [x,y,...]
 553
 554         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 555           [NB: result not printed]      bindings: [it]
 556
 557
 558         expr (of non-IO type,
 559           result showable)      ==>     let v = expr in print v >> return [v]
 560                                         bindings: [it]
 561
 562         expr (of non-IO type,
 563           result not showable)  ==>     error
 564
 565 \begin{code}
 566 #ifdef GHCI
 567 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 568   :: HscEnv
 569   -> InteractiveContext         -- Context for compiling
 570   -> String                     -- The statement
 571   -> IO (Maybe (InteractiveContext, [Name], HValue))
 572
 573 hscStmt hsc_env icontext stmt
 574   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 575         ; case maybe_stmt of {
 576              Nothing      -> return Nothing ;   -- Parse error
 577              Just Nothing -> return Nothing ;   -- Empty line
 578              Just (Just parsed_stmt) -> do {    -- The real stuff
 579
 580                 -- Rename and typecheck it
 581           maybe_tc_result
 582                  <- tcRnStmt hsc_env icontext parsed_stmt
 583
 584         ; case maybe_tc_result of {
 585                 Nothing -> return Nothing ;
 586                 Just (new_ic, bound_names, tc_expr) -> do {
 587
 588                 -- Then desugar, code gen, and link it
 589         ; hval <- compileExpr hsc_env iNTERACTIVE
 590                               (ic_rn_gbl_env new_ic)
 591                               (ic_type_env new_ic)
 592                               tc_expr
 593
 594         ; return (Just (new_ic, bound_names, hval))
 595         }}}}}
 596
 597 hscTcExpr       -- Typecheck an expression (but don't run it)
 598   :: HscEnv
 599   -> InteractiveContext         -- Context for compiling
 600   -> String                     -- The expression
 601   -> IO (Maybe Type)
 602
 603 hscTcExpr hsc_env icontext expr
 604   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 605         ; case maybe_stmt of {
 606              Nothing      -> return Nothing ;   -- Parse error
 607              Just (Just (L _ (ExprStmt expr _)))
 608                         -> tcRnExpr hsc_env icontext expr ;
 609              Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ;
 610                                 return Nothing } ;
 611              } }
 612
 613 hscKcType       -- Find the kind of a type
 614   :: HscEnv
 615   -> InteractiveContext         -- Context for compiling
 616   -> String                     -- The type
 617   -> IO (Maybe Kind)
 618
 619 hscKcType hsc_env icontext str
 620   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 621         ; case maybe_type of {
 622              Just ty    -> tcRnType hsc_env icontext ty ;
 623              Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ;
 624                                 return Nothing } ;
 625              Nothing    -> return Nothing } }
 626 \end{code}
 627
 628 \begin{code}
 629 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 630 hscParseStmt = hscParseThing parseStmt
 631
 632 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 633 hscParseType = hscParseThing parseType
 634
 635 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 636 hscParseIdentifier = hscParseThing parseIdentifier
 637
 638 hscParseThing :: Outputable thing
 639               => Lexer.P thing
 640               -> DynFlags -> String
 641               -> IO (Maybe thing)
 642         -- Nothing => Parse error (message already printed)
 643         -- Just x  => success
 644 hscParseThing parser dflags str
 645  = do showPass dflags "Parser"
 646       _scc_ "Parser"  do
 647
 648       buf <- stringToStringBuffer str
 649
 650       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 651
 652       case unP parser (mkPState buf loc dflags) of {
 653
 654         PFailed span err -> do { printError span err;
 655                                  return Nothing };
 656
 657         POk _ thing -> do {
 658
 659       --ToDo: can't free the string buffer until we've finished this
 660       -- compilation sweep and all the identifiers have gone away.
 661       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 662       return (Just thing)
 663       }}
 664 #endif
 665 \end{code}
 666
 667 %************************************************************************
 668 %*                                                                      *
 669 \subsection{Getting information about an identifer}
 670 %*                                                                      *
 671 %************************************************************************
 672
 673 \begin{code}
 674 #ifdef GHCI
 675 type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)]))
 676
 677 hscGetInfo -- like hscStmt, but deals with a single identifier
 678   :: HscEnv
 679   -> InteractiveContext         -- Context for compiling
 680   -> String                     -- The identifier
 681   -> IO [GetInfoResult]
 682
 683 hscGetInfo hsc_env ic str
 684    = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 685         case maybe_rdr_name of {
 686           Nothing -> return [];
 687           Just (L _ rdr_name) -> do
 688
 689         maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name
 690
 691         let     -- str' is the the naked occurrence name
 692                 -- after stripping off qualification and parens (+)
 693            str' = occNameUserString (rdrNameOcc rdr_name)
 694
 695         case maybe_tc_result of {
 696              Nothing     -> return [] ;
 697              Just things -> return [(str', t) | t <- things]
 698         }}
 699 #endif
 700 \end{code}
 701
 702 %************************************************************************
 703 %*                                                                      *
 704         Desugar, simplify, convert to bytecode, and link an expression
 705 %*                                                                      *
 706 %************************************************************************
 707
 708 \begin{code}
 709 #ifdef GHCI
 710 compileExpr :: HscEnv
 711             -> Module -> GlobalRdrEnv -> TypeEnv
 712             -> LHsExpr Id
 713             -> IO HValue
 714
 715 compileExpr hsc_env this_mod rdr_env type_env tc_expr
 716   = do  { let { dflags  = hsc_dflags hsc_env ;
 717                 lint_on = dopt Opt_DoCoreLinting dflags }
 718
 719                 -- Desugar it
 720         ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 721
 722                 -- Flatten it
 723         ; flat_expr <- flattenExpr hsc_env ds_expr
 724
 725                 -- Simplify it
 726         ; simpl_expr <- simplifyExpr dflags flat_expr
 727
 728                 -- Tidy it (temporary, until coreSat does cloning)
 729         ; tidy_expr <- tidyCoreExpr simpl_expr
 730
 731                 -- Prepare for codegen
 732         ; prepd_expr <- corePrepExpr dflags tidy_expr
 733
 734                 -- Lint if necessary
 735                 -- ToDo: improve SrcLoc
 736         ; if lint_on then
 737                 case lintUnfolding noSrcLoc [] prepd_expr of
 738                    Just err -> pprPanic "compileExpr" err
 739                    Nothing  -> return ()
 740           else
 741                 return ()
 742
 743                 -- Convert to BCOs
 744         ; bcos <- coreExprToBCOs dflags prepd_expr
 745
 746                 -- link it
 747         ; hval <- linkExpr hsc_env bcos
 748
 749         ; return hval
 750      }
 751 #endif
 752 \end{code}
 753
 754
 755 %************************************************************************
 756 %*                                                                      *
 757         Statistics on reading interfaces
 758 %*                                                                      *
 759 %************************************************************************
 760
 761 \begin{code}
 762 dumpIfaceStats :: HscEnv -> IO ()
 763 dumpIfaceStats hsc_env
 764   = do  { eps <- readIORef (hsc_EPS hsc_env)
 765         ; dumpIfSet (dump_if_trace || dump_rn_stats)
 766                     "Interface statistics"
 767                     (ifaceStats eps) }
 768   where
 769     dflags = hsc_dflags hsc_env
 770     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
 771     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 772 \end{code}