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, initPersistentCompilerState
  10 #ifdef GHCI
  11         , hscStmt, hscTcExpr, hscThing,
  12         , compileExpr
  13 #endif
  14         ) where
  15
  16 #include "HsVersions.h"
  17
  18 #ifdef GHCI
  19 import TcHsSyn          ( TypecheckedHsExpr )
  20 import CodeOutput       ( outputForeignStubs )
  21 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  22 import Linker           ( HValue, linkExpr )
  23 import TidyPgm          ( tidyCoreExpr )
  24 import CorePrep         ( corePrepExpr )
  25 import Flattening       ( flattenExpr )
  26 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnThing )
  27 import RdrHsSyn         ( RdrNameStmt )
  28 import Type             ( Type )
  29 import PrelNames        ( iNTERACTIVE )
  30 import StringBuffer     ( stringToStringBuffer )
  31 import Name             ( Name )
  32 import CoreLint         ( lintUnfolding )
  33 #endif
  34
  35 import HsSyn
  36
  37 import RdrName          ( nameRdrName )
  38 import Id               ( idName )
  39 import IdInfo           ( CafInfo(..), CgInfoEnv, CgInfo(..) )
  40 import StringBuffer     ( hGetStringBuffer, freeStringBuffer )
  41 import Parser
  42 import Lex              ( ParseResult(..), ExtFlags(..), mkPState )
  43 import SrcLoc           ( mkSrcLoc, noSrcLoc )
  44 import TcRnDriver       ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
  45 import RnEnv            ( extendOrigNameCache )
  46 import Rules            ( emptyRuleBase )
  47 import PrelInfo         ( wiredInThingEnv, wiredInThings, knownKeyNames )
  48 import PrelRules        ( builtinRules )
  49 import MkIface          ( mkIface )
  50 import InstEnv          ( emptyInstEnv )
  51 import Desugar
  52 import Flattening       ( flatten )
  53 import SimplCore
  54 import CoreUtils        ( coreBindsSize )
  55 import TidyPgm          ( tidyCorePgm )
  56 import CorePrep         ( corePrepPgm )
  57 import StgSyn
  58 import CoreToStg        ( coreToStg )
  59 import SimplStg         ( stg2stg )
  60 import CodeGen          ( codeGen )
  61 import CodeOutput       ( codeOutput )
  62
  63 import Module           ( emptyModuleEnv )
  64 import CmdLineOpts
  65 import DriverPhases     ( isExtCore_file )
  66 import ErrUtils         ( dumpIfSet_dyn, showPass, printError )
  67 import UniqSupply       ( mkSplitUniqSupply )
  68
  69 import Bag              ( consBag, emptyBag )
  70 import Outputable
  71 import HscStats         ( ppSourceStats )
  72 import HscTypes
  73 import MkExternalCore   ( emitExternalCore )
  74 import ParserCore
  75 import ParserCoreUtils
  76 import FiniteMap        ( emptyFM )
  77 import Name             ( nameModule, getName )
  78 import NameEnv          ( emptyNameEnv, mkNameEnv )
  79 import NameSet          ( emptyNameSet )
  80 import Module           ( Module, ModLocation(..), showModMsg )
  81 import FastString
  82 import Maybes           ( expectJust )
  83
  84 import DATA_IOREF       ( newIORef, readIORef, writeIORef )
  85 import UNSAFE_IO        ( unsafePerformIO )
  86
  87 import Monad            ( when )
  88 import Maybe            ( isJust, fromJust )
  89 import IO
  90 \end{code}
  91
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection{The main compiler pipeline}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 \begin{code}
 100 data HscResult
 101    -- compilation failed
 102    = HscFail     PersistentCompilerState -- updated PCS
 103    -- concluded that it wasn't necessary
 104    | HscNoRecomp PersistentCompilerState -- updated PCS
 105                  ModDetails              -- new details (HomeSymbolTable additions)
 106                  ModIface                -- new iface (if any compilation was done)
 107    -- did recompilation
 108    | HscRecomp   PersistentCompilerState -- updated PCS
 109                  ModDetails              -- new details (HomeSymbolTable additions)
 110                  ModIface                -- new iface (if any compilation was done)
 111                  Bool                   -- stub_h exists
 112                  Bool                   -- stub_c exists
 113                  (Maybe CompiledByteCode)
 114
 115         -- no errors or warnings; the individual passes
 116         -- (parse/rename/typecheck) print messages themselves
 117
 118 hscMain
 119   :: HscEnv
 120   -> PersistentCompilerState    -- IN: persistent compiler state
 121   -> Module
 122   -> ModLocation                -- location info
 123   -> Bool                       -- True <=> source unchanged
 124   -> Bool                       -- True <=> have an object file (for msgs only)
 125   -> Maybe ModIface             -- old interface, if available
 126   -> IO HscResult
 127
 128 hscMain hsc_env pcs mod location
 129         source_unchanged have_object maybe_old_iface
 130  = do {
 131       (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
 132                                     checkOldIface hsc_env pcs mod
 133                                                   (ml_hi_file location)
 134                                                   source_unchanged maybe_old_iface;
 135       case maybe_chk_result of {
 136         Nothing -> return (HscFail pcs_ch) ;
 137         Just (recomp_reqd, maybe_checked_iface) -> do {
 138
 139       let no_old_iface = not (isJust maybe_checked_iface)
 140           what_next | recomp_reqd || no_old_iface = hscRecomp
 141                     | otherwise                   = hscNoRecomp
 142
 143       ; what_next hsc_env pcs_ch have_object
 144                   mod location maybe_checked_iface
 145       }}}
 146
 147
 148 -- hscNoRecomp definitely expects to have the old interface available
 149 hscNoRecomp hsc_env pcs_ch have_object
 150             mod location (Just old_iface)
 151  | hsc_mode hsc_env == OneShot
 152  = do {
 153       when (verbosity (hsc_dflags hsc_env) > 0) $
 154           hPutStrLn stderr "compilation IS NOT required";
 155       let { bomb = panic "hscNoRecomp:OneShot" };
 156       return (HscNoRecomp pcs_ch bomb bomb)
 157       }
 158  | otherwise
 159  = do {
 160       when (verbosity (hsc_dflags hsc_env) >= 1) $
 161                 hPutStrLn stderr ("Skipping  " ++
 162                         showModMsg have_object mod location);
 163
 164       -- Typecheck
 165       (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
 166
 167       case maybe_tc_result of {
 168          Nothing -> return (HscFail pcs_tc);
 169          Just new_details ->
 170
 171       return (HscNoRecomp pcs_tc new_details old_iface)
 172       }}
 173
 174 hscRecomp hsc_env pcs_ch have_object
 175           mod location maybe_checked_iface
 176  = do   {
 177           -- what target are we shooting for?
 178         ; let one_shot  = hsc_mode hsc_env == OneShot
 179         ; let dflags    = hsc_dflags hsc_env
 180         ; let toInterp  = dopt_HscLang dflags == HscInterpreted
 181         ; let toCore    = isJust (ml_hs_file location) &&
 182                           isExtCore_file (fromJust (ml_hs_file location))
 183
 184         ; when (not one_shot && verbosity dflags >= 1) $
 185                 hPutStrLn stderr ("Compiling " ++
 186                         showModMsg (not toInterp) mod location);
 187
 188         ; front_res <- if toCore then
 189                           hscCoreFrontEnd hsc_env pcs_ch location
 190                        else
 191                           hscFrontEnd hsc_env pcs_ch location
 192
 193         ; case front_res of
 194             Left flure -> return flure;
 195             Right (pcs_tc, ds_result) -> do {
 196
 197
 198         -- OMITTED:
 199         -- ; seqList imported_modules (return ())
 200
 201             -------------------
 202             -- FLATTENING
 203             -------------------
 204         ; flat_result <- _scc_ "Flattening"
 205                          flatten hsc_env pcs_tc ds_result
 206
 207         ; let pcs_middle = pcs_tc
 208
 209 {-      Again, omit this because it loses the usage info
 210         which is needed in mkIface.  Maybe we should compute
 211         usage info earlier.
 212
 213         ; pcs_middle
 214             <- _scc_ "pcs_middle"
 215                 if one_shot then
 216                        do init_pcs <- initPersistentCompilerState
 217                           init_prs <- initPersistentRenamerState
 218                           let
 219                               rules   = pcs_rules pcs_tc
 220                               orig_tc = prsOrig (pcs_PRS pcs_tc)
 221                               new_prs = init_prs{ prsOrig=orig_tc }
 222
 223                           orig_tc `seq` rules `seq` new_prs `seq`
 224                             return init_pcs{ pcs_PRS = new_prs,
 225                                              pcs_rules = rules }
 226                 else return pcs_tc
 227 -}
 228
 229 -- Should we remove bits of flat_result at this point?
 230 --         ; flat_result <- case flat_result of
 231 --                             ModResult { md_binds = binds } ->
 232 --                                 return ModDetails { md_binds = binds,
 233 --                                                     md_rules = [],
 234 --                                                     md_types = emptyTypeEnv,
 235 --                                                     md_insts = [] }
 236
 237         -- alive at this point:
 238         --      pcs_middle
 239         --      flat_result
 240
 241             -------------------
 242             -- SIMPLIFY
 243             -------------------
 244         ; simpl_result <- _scc_     "Core2Core"
 245                           core2core hsc_env pcs_middle flat_result
 246
 247             -------------------
 248             -- TIDY
 249             -------------------
 250         ; cg_info_ref <- newIORef Nothing ;
 251         ; let cg_info :: CgInfoEnv
 252               cg_info = unsafePerformIO $ do {
 253                            maybe_cg_env <- readIORef cg_info_ref ;
 254                            case maybe_cg_env of
 255                              Just env -> return env
 256                              Nothing  -> do { printError "Urk! Looked at CgInfo too early!";
 257                                               return emptyNameEnv } }
 258                 -- cg_info_ref will be filled in just after restOfCodeGeneration
 259                 -- Meanwhile, tidyCorePgm is careful not to look at cg_info!
 260
 261         ; (pcs_simpl, tidy_result)
 262              <- _scc_ "CoreTidy"
 263                 tidyCorePgm dflags pcs_middle cg_info simpl_result
 264
 265 --              Space-saving ploy doesn't work so well now
 266 --              because mkIface needs the populated PIT to
 267 --              generate usage info.  Maybe we should re-visit this.
 268 --      ; pcs_final <- if one_shot then initPersistentCompilerState
 269 --                                 else return pcs_simpl
 270         ; let pcs_final = pcs_simpl
 271
 272         -- Alive at this point:
 273         --      tidy_result, pcs_final
 274
 275             -------------------
 276             -- PREPARE FOR CODE GENERATION
 277             -- Do saturation and convert to A-normal form
 278         ; prepd_result <- _scc_ "CorePrep"
 279                            corePrepPgm dflags tidy_result
 280
 281             -------------------
 282             -- CONVERT TO STG and COMPLETE CODE GENERATION
 283         ; (stub_h_exists, stub_c_exists, maybe_bcos)
 284                 <- hscBackEnd dflags cg_info_ref prepd_result
 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         ; final_iface <- _scc_ "MkFinalIface"
 293                         mkIface hsc_env location
 294                                 maybe_checked_iface tidy_result
 295         ; let final_details = ModDetails { md_types = mg_types tidy_result,
 296                                            md_insts = mg_insts tidy_result,
 297                                            md_rules = mg_rules tidy_result }
 298         ; emitExternalCore dflags tidy_result
 299
 300           -- and the answer is ...
 301         ; return (HscRecomp pcs_final
 302                             final_details
 303                             final_iface
 304                             stub_h_exists stub_c_exists
 305                             maybe_bcos)
 306          }}
 307
 308 hscCoreFrontEnd hsc_env pcs_ch location = do {
 309             -------------------
 310             -- PARSE
 311             -------------------
 312         ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
 313         ; case parseCore inp 1 of
 314             FailP s        -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
 315             OkP rdr_module -> do {
 316
 317             -------------------
 318             -- RENAME and TYPECHECK
 319             -------------------
 320         ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
 321                                        tcRnExtCore hsc_env pcs_ch rdr_module
 322         ; case maybe_tc_result of {
 323              Nothing       -> return (Left  (HscFail pcs_tc));
 324              Just mod_guts -> return (Right (pcs_tc, mod_guts))
 325                                         -- No desugaring to do!
 326         }}}
 327
 328
 329 hscFrontEnd hsc_env pcs_ch location = do {
 330             -------------------
 331             -- PARSE
 332             -------------------
 333         ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
 334                              (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
 335
 336         ; case maybe_parsed of {
 337              Nothing -> return (Left (HscFail pcs_ch));
 338              Just rdr_module -> do {
 339
 340             -------------------
 341             -- RENAME and TYPECHECK
 342             -------------------
 343         ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
 344                                         tcRnModule hsc_env pcs_ch rdr_module
 345         ; case maybe_tc_result of {
 346              Nothing -> return (Left (HscFail pcs_ch));
 347              Just tc_result -> do {
 348
 349             -------------------
 350             -- DESUGAR
 351             -------------------
 352         ; ds_result <- _scc_ "DeSugar"
 353                        deSugar hsc_env pcs_tc tc_result
 354         ; return (Right (pcs_tc, ds_result))
 355         }}}}}
 356
 357
 358 hscBackEnd dflags cg_info_ref prepd_result
 359   = case dopt_HscLang dflags of
 360       HscNothing -> return (False, False, Nothing)
 361
 362       HscInterpreted ->
 363 #ifdef GHCI
 364         do  -----------------  Generate byte code ------------------
 365             comp_bc <- byteCodeGen dflags prepd_result
 366
 367             -- Fill in the code-gen info
 368             writeIORef cg_info_ref (Just emptyNameEnv)
 369
 370             ------------------ Create f-x-dynamic C-side stuff ---
 371             (istub_h_exists, istub_c_exists)
 372                <- outputForeignStubs dflags (mg_foreign prepd_result)
 373
 374             return ( istub_h_exists, istub_c_exists,
 375                      Just comp_bc )
 376 #else
 377         panic "GHC not compiled with interpreter"
 378 #endif
 379
 380       other ->
 381         do
 382             -----------------  Convert to STG ------------------
 383             (stg_binds, cost_centre_info, stg_back_end_info)
 384                       <- _scc_ "CoreToStg"
 385                          myCoreToStg dflags prepd_result
 386
 387             -- Fill in the code-gen info for the earlier tidyCorePgm
 388             writeIORef cg_info_ref (Just stg_back_end_info)
 389
 390             ------------------  Code generation ------------------
 391             abstractC <- _scc_ "CodeGen"
 392                          codeGen dflags prepd_result
 393                                  cost_centre_info stg_binds
 394
 395             ------------------  Code output -----------------------
 396             (stub_h_exists, stub_c_exists)
 397                      <- codeOutput dflags prepd_result abstractC
 398
 399             return (stub_h_exists, stub_c_exists, Nothing)
 400
 401
 402 myParseModule dflags src_filename
 403  = do --------------------------  Parser  ----------------
 404       showPass dflags "Parser"
 405       _scc_  "Parser" do
 406       buf <- hGetStringBuffer src_filename
 407
 408       let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
 409                            ffiEF         = dopt Opt_FFI         dflags,
 410                            withEF        = dopt Opt_With        dflags,
 411                            parrEF        = dopt Opt_PArr        dflags}
 412           loc  = mkSrcLoc (mkFastString src_filename) 1
 413
 414       case parseModule buf (mkPState loc exts) of {
 415
 416         PFailed err -> do { hPutStrLn stderr (showSDoc err);
 417                             freeStringBuffer buf;
 418                             return Nothing };
 419
 420         POk _ rdr_module -> do {
 421
 422       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 423
 424       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 425                            (ppSourceStats False rdr_module) ;
 426
 427       return (Just rdr_module)
 428         -- ToDo: free the string buffer later.
 429       }}
 430
 431
 432 myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds})
 433  = do
 434       () <- coreBindsSize tidy_binds `seq` return ()
 435       -- TEMP: the above call zaps some space usage allocated by the
 436       -- simplifier, which for reasons I don't understand, persists
 437       -- thoroughout code generation -- JRS
 438       --
 439       -- This is still necessary. -- SDM (10 Dec 2001)
 440
 441       stg_binds <- _scc_ "Core2Stg"
 442              coreToStg dflags tidy_binds
 443
 444       (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
 445              stg2stg dflags this_mod stg_binds
 446
 447       let env_rhs :: CgInfoEnv
 448           env_rhs = mkNameEnv [ caf_info `seq` (idName bndr, CgInfo caf_info)
 449                               | (bind,_) <- stg_binds2,
 450                                 let caf_info
 451                                      | stgBindHasCafRefs bind = MayHaveCafRefs
 452                                      | otherwise              = NoCafRefs,
 453                                 bndr <- stgBinders bind ]
 454
 455       return (stg_binds2, cost_centre_info, env_rhs)
 456 \end{code}
 457
 458
 459 %************************************************************************
 460 %*                                                                      *
 461 \subsection{Compiling a do-statement}
 462 %*                                                                      *
 463 %************************************************************************
 464
 465 When the UnlinkedBCOExpr is linked you get an HValue of type
 466         IO [HValue]
 467 When you run it you get a list of HValues that should be
 468 the same length as the list of names; add them to the ClosureEnv.
 469
 470 A naked expression returns a singleton Name [it].
 471
 472         What you type                   The IO [HValue] that hscStmt returns
 473         -------------                   ------------------------------------
 474         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 475                                         bindings: [x,y,...]
 476
 477         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 478                                         bindings: [x,y,...]
 479
 480         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 481           [NB: result not printed]      bindings: [it]
 482
 483
 484         expr (of non-IO type,
 485           result showable)      ==>     let v = expr in print v >> return [v]
 486                                         bindings: [it]
 487
 488         expr (of non-IO type,
 489           result not showable)  ==>     error
 490
 491 \begin{code}
 492 #ifdef GHCI
 493 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 494   :: HscEnv
 495   -> PersistentCompilerState    -- IN: persistent compiler state
 496   -> InteractiveContext         -- Context for compiling
 497   -> String                     -- The statement
 498   -> IO ( PersistentCompilerState,
 499           Maybe (InteractiveContext, [Name], HValue) )
 500
 501 hscStmt hsc_env pcs icontext stmt
 502   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 503         ; case maybe_stmt of {
 504              Nothing -> return (pcs, Nothing) ;
 505              Just parsed_stmt -> do {
 506
 507                 -- Rename and typecheck it
 508           (pcs1, maybe_tc_result)
 509                  <- tcRnStmt hsc_env pcs icontext parsed_stmt
 510
 511         ; case maybe_tc_result of {
 512                 Nothing -> return (pcs1, Nothing) ;
 513                 Just (new_ic, bound_names, tc_expr) -> do {
 514
 515                 -- Then desugar, code gen, and link it
 516         ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
 517                               (ic_rn_gbl_env new_ic)
 518                               (ic_type_env new_ic)
 519                               tc_expr
 520
 521         ; return (pcs1, Just (new_ic, bound_names, hval))
 522         }}}}}
 523
 524 hscTcExpr       -- Typecheck an expression (but don't run it)
 525   :: HscEnv
 526   -> PersistentCompilerState    -- IN: persistent compiler state
 527   -> InteractiveContext         -- Context for compiling
 528   -> String                     -- The expression
 529   -> IO (PersistentCompilerState, Maybe Type)
 530
 531 hscTcExpr hsc_env pcs icontext expr
 532   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 533         ; case maybe_stmt of {
 534              Just (ExprStmt expr _ _)
 535                         -> tcRnExpr hsc_env pcs icontext expr ;
 536              Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
 537                                 return (pcs, Nothing) } ;
 538              Nothing    -> return (pcs, Nothing) } }
 539 \end{code}
 540
 541 \begin{code}
 542 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
 543 hscParseStmt dflags str
 544  = do showPass dflags "Parser"
 545       _scc_ "Parser"  do
 546
 547       buf <- stringToStringBuffer str
 548
 549       let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
 550                            ffiEF         = dopt Opt_FFI         dflags,
 551                            withEF        = dopt Opt_With        dflags,
 552                            parrEF        = dopt Opt_PArr        dflags}
 553           loc  = mkSrcLoc FSLIT("<interactive>") 1
 554
 555       case parseStmt buf (mkPState loc exts) of {
 556
 557         PFailed err -> do { hPutStrLn stderr (showSDoc err);
 558 --      Not yet implemented in <4.11    freeStringBuffer buf;
 559                             return Nothing };
 560
 561         -- no stmt: the line consisted of just space or comments
 562         POk _ Nothing -> return Nothing;
 563
 564         POk _ (Just rdr_stmt) -> do {
 565
 566       --ToDo: can't free the string buffer until we've finished this
 567       -- compilation sweep and all the identifiers have gone away.
 568       --freeStringBuffer buf;
 569       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
 570       return (Just rdr_stmt)
 571       }}
 572 #endif
 573 \end{code}
 574
 575 %************************************************************************
 576 %*                                                                      *
 577 \subsection{Getting information about an identifer}
 578 %*                                                                      *
 579 %************************************************************************
 580
 581 \begin{code}
 582 #ifdef GHCI
 583 hscThing -- like hscStmt, but deals with a single identifier
 584   :: HscEnv
 585   -> PersistentCompilerState    -- IN: persistent compiler state
 586   -> InteractiveContext         -- Context for compiling
 587   -> String                     -- The identifier
 588   -> IO ( PersistentCompilerState,
 589           [TyThing] )
 590
 591 hscThing hsc_env pcs0 ic str
 592    = do let dflags         = hsc_dflags hsc_env
 593
 594         maybe_rdr_name <- myParseIdentifier dflags str
 595         case maybe_rdr_name of {
 596           Nothing -> return (pcs0, []);
 597           Just rdr_name -> do
 598
 599         (pcs1, maybe_tc_result) <-
 600            tcRnThing hsc_env pcs0 ic rdr_name
 601
 602         case maybe_tc_result of {
 603              Nothing     -> return (pcs1, []) ;
 604              Just things -> return (pcs1, things)
 605         }}
 606
 607 myParseIdentifier dflags str
 608   = do buf <- stringToStringBuffer str
 609
 610        let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
 611                             ffiEF         = dopt Opt_FFI         dflags,
 612                             withEF        = dopt Opt_With        dflags,
 613                             parrEF        = dopt Opt_PArr        dflags}
 614            loc  = mkSrcLoc FSLIT("<interactive>") 1
 615
 616        case parseIdentifier buf (mkPState loc exts) of
 617
 618           PFailed err -> do { hPutStrLn stderr (showSDoc err);
 619                               freeStringBuffer buf;
 620                               return Nothing }
 621
 622           POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
 623                                  return (Just rdr_name) }
 624 #endif
 625 \end{code}
 626
 627 %************************************************************************
 628 %*                                                                      *
 629         Desugar, simplify, convert to bytecode, and link an expression
 630 %*                                                                      *
 631 %************************************************************************
 632
 633 \begin{code}
 634 #ifdef GHCI
 635 compileExpr :: HscEnv
 636             -> PersistentCompilerState
 637             -> Module -> GlobalRdrEnv -> TypeEnv
 638             -> TypecheckedHsExpr
 639             -> IO HValue
 640
 641 compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 642   = do  { let { dflags  = hsc_dflags hsc_env ;
 643                 lint_on = dopt Opt_DoCoreLinting dflags }
 644
 645                 -- Desugar it
 646         ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 647
 648                 -- Flatten it
 649         ; flat_expr <- flattenExpr hsc_env pcs ds_expr
 650
 651                 -- Simplify it
 652         ; simpl_expr <- simplifyExpr dflags flat_expr
 653
 654                 -- Tidy it (temporary, until coreSat does cloning)
 655         ; tidy_expr <- tidyCoreExpr simpl_expr
 656
 657                 -- Prepare for codegen
 658         ; prepd_expr <- corePrepExpr dflags tidy_expr
 659
 660                 -- Lint if necessary
 661                 -- ToDo: improve SrcLoc
 662         ; if lint_on then
 663                 case lintUnfolding noSrcLoc [] prepd_expr of
 664                    Just err -> pprPanic "compileExpr" err
 665                    Nothing  -> return ()
 666           else
 667                 return ()
 668
 669                 -- Convert to BCOs
 670         ; bcos <- coreExprToBCOs dflags prepd_expr
 671
 672                 -- link it
 673         ; hval <- linkExpr hsc_env pcs bcos
 674
 675         ; return hval
 676      }
 677 #endif
 678 \end{code}
 679
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection{Initial persistent state}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 \begin{code}
 688 initPersistentCompilerState :: IO PersistentCompilerState
 689 initPersistentCompilerState
 690   = do nc <- initNameCache
 691        return (
 692         PCS { pcs_EPS = initExternalPackageState,
 693               pcs_nc  = nc })
 694
 695 initNameCache :: IO NameCache
 696   = do us <- mkSplitUniqSupply 'r'
 697        return (NameCache { nsUniqs = us,
 698                            nsNames = initOrigNames,
 699                            nsIPs   = emptyFM })
 700
 701 initExternalPackageState :: ExternalPackageState
 702 initExternalPackageState
 703   = EPS {
 704       eps_decls      = (emptyNameEnv, 0),
 705       eps_insts      = (emptyBag, 0),
 706       eps_inst_gates = emptyNameSet,
 707       eps_rules      = foldr add_rule (emptyBag, 0) builtinRules,
 708
 709       eps_PIT       = emptyPackageIfaceTable,
 710       eps_PTE       = wiredInThingEnv,
 711       eps_inst_env  = emptyInstEnv,
 712       eps_rule_base = emptyRuleBase }
 713
 714   where
 715     add_rule (name,rule) (rules, n_slurped)
 716          = (gated_decl `consBag` rules, n_slurped)
 717         where
 718            gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
 719            mod        = nameModule name
 720            rdr_name   = nameRdrName name        -- Seems a bit of a hack to go back
 721                                                 -- to the RdrName
 722            gate_fn vis_fn = vis_fn name         -- Load the rule whenever name is visible
 723
 724 initOrigNames :: OrigNameCache
 725 initOrigNames
 726    = insert knownKeyNames $
 727      insert (map getName wiredInThings) $
 728      emptyModuleEnv
 729   where
 730      insert names env = foldl extendOrigNameCache env names
 731 \end{code}