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