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 #endif
  33
  34 import HsSyn
  35
  36 import RdrName          ( nameRdrName )
  37 import Id               ( idName )
  38 import IdInfo           ( CafInfo(..), CgInfoEnv, CgInfo(..) )
  39 import StringBuffer     ( hGetStringBuffer, freeStringBuffer )
  40 import Parser
  41 import Lex              ( ParseResult(..), ExtFlags(..), mkPState )
  42 import SrcLoc           ( mkSrcLoc )
  43 import TcRnDriver       ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
  44 import RnEnv            ( extendOrigNameCache )
  45 import Rules            ( emptyRuleBase )
  46 import PrelInfo         ( wiredInThingEnv, wiredInThings, knownKeyNames )
  47 import PrelRules        ( builtinRules )
  48 import MkIface          ( mkIface )
  49 import InstEnv          ( emptyInstEnv )
  50 import Desugar
  51 import Flattening       ( flatten )
  52 import SimplCore
  53 import CoreUtils        ( coreBindsSize )
  54 import TidyPgm          ( tidyCorePgm )
  55 import CorePrep         ( corePrepPgm )
  56 import StgSyn
  57 import CoreToStg        ( coreToStg )
  58 import SimplStg         ( stg2stg )
  59 import CodeGen          ( codeGen )
  60 import CodeOutput       ( codeOutput )
  61
  62 import Module           ( emptyModuleEnv )
  63 import CmdLineOpts
  64 import DriverPhases     ( isExtCore_file )
  65 import ErrUtils         ( dumpIfSet_dyn, showPass, printError )
  66 import UniqSupply       ( mkSplitUniqSupply )
  67
  68 import Bag              ( consBag, emptyBag )
  69 import Outputable
  70 import HscStats         ( ppSourceStats )
  71 import HscTypes
  72 import MkExternalCore   ( emitExternalCore )
  73 import ParserCore
  74 import ParserCoreUtils
  75 import FiniteMap        ( emptyFM )
  76 import Name             ( nameModule, getName )
  77 import NameEnv          ( emptyNameEnv, mkNameEnv )
  78 import NameSet          ( emptyNameSet )
  79 import Module           ( Module, ModLocation(..), showModMsg )
  80 import FastString
  81 import Maybes           ( expectJust )
  82
  83 import DATA_IOREF       ( newIORef, readIORef, writeIORef )
  84 import UNSAFE_IO        ( unsafePerformIO )
  85
  86 import Monad            ( when )
  87 import Maybe            ( isJust, fromJust )
  88 import IO
  89 \end{code}
  90
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection{The main compiler pipeline}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 data HscResult
 100    -- compilation failed
 101    = HscFail     PersistentCompilerState -- updated PCS
 102    -- concluded that it wasn't necessary
 103    | HscNoRecomp PersistentCompilerState -- updated PCS
 104                  ModDetails              -- new details (HomeSymbolTable additions)
 105                  ModIface                -- new iface (if any compilation was done)
 106    -- did recompilation
 107    | HscRecomp   PersistentCompilerState -- updated PCS
 108                  ModDetails              -- new details (HomeSymbolTable additions)
 109                  ModIface                -- new iface (if any compilation was done)
 110                  Bool                   -- stub_h exists
 111                  Bool                   -- stub_c exists
 112                  (Maybe CompiledByteCode)
 113
 114         -- no errors or warnings; the individual passes
 115         -- (parse/rename/typecheck) print messages themselves
 116
 117 hscMain
 118   :: HscEnv
 119   -> PersistentCompilerState    -- IN: persistent compiler state
 120   -> Module
 121   -> ModLocation                -- location info
 122   -> Bool                       -- True <=> source unchanged
 123   -> Bool                       -- True <=> have an object file (for msgs only)
 124   -> Maybe ModIface             -- old interface, if available
 125   -> IO HscResult
 126
 127 hscMain hsc_env pcs mod location
 128         source_unchanged have_object maybe_old_iface
 129  = do {
 130       (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
 131                                     checkOldIface hsc_env pcs mod
 132                                                   (ml_hi_file location)
 133                                                   source_unchanged maybe_old_iface;
 134       case maybe_chk_result of {
 135         Nothing -> return (HscFail pcs_ch) ;
 136         Just (recomp_reqd, maybe_checked_iface) -> do {
 137
 138       let no_old_iface = not (isJust maybe_checked_iface)
 139           what_next | recomp_reqd || no_old_iface = hscRecomp
 140                     | otherwise                   = hscNoRecomp
 141
 142       ; what_next hsc_env pcs_ch have_object
 143                   mod location maybe_checked_iface
 144       }}}
 145
 146
 147 -- hscNoRecomp definitely expects to have the old interface available
 148 hscNoRecomp hsc_env pcs_ch have_object
 149             mod location (Just old_iface)
 150  | hsc_mode hsc_env == OneShot
 151  = do {
 152       when (verbosity (hsc_dflags hsc_env) > 0) $
 153           hPutStrLn stderr "compilation IS NOT required";
 154       let { bomb = panic "hscNoRecomp:OneShot" };
 155       return (HscNoRecomp pcs_ch bomb bomb)
 156       }
 157  | otherwise
 158  = do {
 159       when (verbosity (hsc_dflags hsc_env) >= 1) $
 160                 hPutStrLn stderr ("Skipping  " ++
 161                         showModMsg have_object mod location);
 162
 163       -- Typecheck
 164       (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
 165
 166       case maybe_tc_result of {
 167          Nothing -> return (HscFail pcs_tc);
 168          Just new_details ->
 169
 170       return (HscNoRecomp pcs_tc new_details old_iface)
 171       }}
 172
 173 hscRecomp hsc_env pcs_ch have_object
 174           mod location maybe_checked_iface
 175  = do   {
 176           -- what target are we shooting for?
 177         ; let one_shot  = hsc_mode hsc_env == OneShot
 178         ; let dflags    = hsc_dflags hsc_env
 179         ; let toInterp  = dopt_HscLang dflags == HscInterpreted
 180         ; let toCore    = isJust (ml_hs_file location) &&
 181                           isExtCore_file (fromJust (ml_hs_file location))
 182
 183         ; when (not one_shot && verbosity dflags >= 1) $
 184                 hPutStrLn stderr ("Compiling " ++
 185                         showModMsg (not toInterp) mod location);
 186
 187         ; front_res <- if toCore then
 188                           hscCoreFrontEnd hsc_env pcs_ch location
 189                        else
 190                           hscFrontEnd hsc_env pcs_ch location
 191
 192         ; case front_res of
 193             Left flure -> return flure;
 194             Right (pcs_tc, ds_result) -> do {
 195
 196
 197         -- OMITTED:
 198         -- ; seqList imported_modules (return ())
 199
 200             -------------------
 201             -- FLATTENING
 202             -------------------
 203         ; flat_result <- _scc_ "Flattening"
 204                          flatten hsc_env pcs_tc ds_result
 205
 206         ; let pcs_middle = pcs_tc
 207
 208 {-      Again, omit this because it loses the usage info
 209         which is needed in mkIface.  Maybe we should compute
 210         usage info earlier.
 211
 212         ; pcs_middle
 213             <- _scc_ "pcs_middle"
 214                 if one_shot then
 215                        do init_pcs <- initPersistentCompilerState
 216                           init_prs <- initPersistentRenamerState
 217                           let
 218                               rules   = pcs_rules pcs_tc
 219                               orig_tc = prsOrig (pcs_PRS pcs_tc)
 220                               new_prs = init_prs{ prsOrig=orig_tc }
 221
 222                           orig_tc `seq` rules `seq` new_prs `seq`
 223                             return init_pcs{ pcs_PRS = new_prs,
 224                                              pcs_rules = rules }
 225                 else return pcs_tc
 226 -}
 227
 228 -- Should we remove bits of flat_result at this point?
 229 --         ; flat_result <- case flat_result of
 230 --                             ModResult { md_binds = binds } ->
 231 --                                 return ModDetails { md_binds = binds,
 232 --                                                     md_rules = [],
 233 --                                                     md_types = emptyTypeEnv,
 234 --                                                     md_insts = [] }
 235
 236         -- alive at this point:
 237         --      pcs_middle
 238         --      flat_result
 239
 240             -------------------
 241             -- SIMPLIFY
 242             -------------------
 243         ; simpl_result <- _scc_     "Core2Core"
 244                           core2core hsc_env pcs_middle flat_result
 245
 246             -------------------
 247             -- TIDY
 248             -------------------
 249         ; cg_info_ref <- newIORef Nothing ;
 250         ; let cg_info :: CgInfoEnv
 251               cg_info = unsafePerformIO $ do {
 252                            maybe_cg_env <- readIORef cg_info_ref ;
 253                            case maybe_cg_env of
 254                              Just env -> return env
 255                              Nothing  -> do { printError "Urk! Looked at CgInfo too early!";
 256                                               return emptyNameEnv } }
 257                 -- cg_info_ref will be filled in just after restOfCodeGeneration
 258                 -- Meanwhile, tidyCorePgm is careful not to look at cg_info!
 259
 260         ; (pcs_simpl, tidy_result)
 261              <- _scc_ "CoreTidy"
 262                 tidyCorePgm dflags pcs_middle cg_info simpl_result
 263
 264 --              Space-saving ploy doesn't work so well now
 265 --              because mkIface needs the populated PIT to
 266 --              generate usage info.  Maybe we should re-visit this.
 267 --      ; pcs_final <- if one_shot then initPersistentCompilerState
 268 --                                 else return pcs_simpl
 269         ; let pcs_final = pcs_simpl
 270
 271         -- Alive at this point:
 272         --      tidy_result, pcs_final
 273
 274             -------------------
 275             -- PREPARE FOR CODE GENERATION
 276             -- Do saturation and convert to A-normal form
 277         ; prepd_result <- _scc_ "CorePrep"
 278                            corePrepPgm dflags tidy_result
 279
 280             -------------------
 281             -- CONVERT TO STG and COMPLETE CODE GENERATION
 282         ; (stub_h_exists, stub_c_exists, maybe_bcos)
 283                 <- hscBackEnd dflags cg_info_ref prepd_result
 284
 285             -------------------
 286             -- BUILD THE NEW ModIface and ModDetails
 287             --  and emit external core if necessary
 288             -- This has to happen *after* code gen so that the back-end
 289             -- info has been set.  Not yet clear if it matters waiting
 290             -- until after code output
 291         ; final_iface <- _scc_ "MkFinalIface"
 292                         mkIface hsc_env location
 293                                 maybe_checked_iface tidy_result
 294         ; let final_details = ModDetails { md_types = mg_types tidy_result,
 295                                            md_insts = mg_insts tidy_result,
 296                                            md_rules = mg_rules tidy_result }
 297         ; emitExternalCore dflags tidy_result
 298
 299           -- and the answer is ...
 300         ; return (HscRecomp pcs_final
 301                             final_details
 302                             final_iface
 303                             stub_h_exists stub_c_exists
 304                             maybe_bcos)
 305          }}
 306
 307 hscCoreFrontEnd hsc_env pcs_ch location = do {
 308             -------------------
 309             -- PARSE
 310             -------------------
 311         ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
 312         ; case parseCore inp 1 of
 313             FailP s        -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
 314             OkP rdr_module -> do {
 315
 316             -------------------
 317             -- RENAME and TYPECHECK
 318             -------------------
 319         ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
 320                                        tcRnExtCore hsc_env pcs_ch rdr_module
 321         ; case maybe_tc_result of {
 322              Nothing       -> return (Left  (HscFail pcs_tc));
 323              Just mod_guts -> return (Right (pcs_tc, mod_guts))
 324                                         -- No desugaring to do!
 325         }}}
 326
 327
 328 hscFrontEnd hsc_env pcs_ch location = do {
 329             -------------------
 330             -- PARSE
 331             -------------------
 332         ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
 333                              (expectJust "hscRecomp:hspp" (ml_hspp_file location))
 334
 335         ; case maybe_parsed of {
 336              Nothing -> return (Left (HscFail pcs_ch));
 337              Just rdr_module -> do {
 338
 339             -------------------
 340             -- RENAME and TYPECHECK
 341             -------------------
 342         ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
 343                                         tcRnModule hsc_env pcs_ch rdr_module
 344         ; case maybe_tc_result of {
 345              Nothing -> return (Left (HscFail pcs_ch));
 346              Just tc_result -> do {
 347
 348             -------------------
 349             -- DESUGAR
 350             -------------------
 351         ; ds_result <- _scc_ "DeSugar"
 352                        deSugar hsc_env pcs_tc tc_result
 353         ; return (Right (pcs_tc, ds_result))
 354         }}}}}
 355
 356
 357 hscBackEnd dflags cg_info_ref prepd_result
 358   = case dopt_HscLang dflags of
 359       HscNothing -> return (False, False, Nothing)
 360
 361       HscInterpreted ->
 362 #ifdef GHCI
 363         do  -----------------  Generate byte code ------------------
 364             comp_bc <- byteCodeGen dflags prepd_result
 365
 366             -- Fill in the code-gen info
 367             writeIORef cg_info_ref (Just emptyNameEnv)
 368
 369             ------------------ Create f-x-dynamic C-side stuff ---
 370             (istub_h_exists, istub_c_exists)
 371                <- outputForeignStubs dflags (mg_foreign prepd_result)
 372
 373             return ( istub_h_exists, istub_c_exists,
 374                      Just comp_bc )
 375 #else
 376         panic "GHC not compiled with interpreter"
 377 #endif
 378
 379       other ->
 380         do
 381             -----------------  Convert to STG ------------------
 382             (stg_binds, cost_centre_info, stg_back_end_info)
 383                       <- _scc_ "CoreToStg"
 384                          myCoreToStg dflags prepd_result
 385
 386             -- Fill in the code-gen info for the earlier tidyCorePgm
 387             writeIORef cg_info_ref (Just stg_back_end_info)
 388
 389             ------------------  Code generation ------------------
 390             abstractC <- _scc_ "CodeGen"
 391                          codeGen dflags prepd_result
 392                                  cost_centre_info stg_binds
 393
 394             ------------------  Code output -----------------------
 395             (stub_h_exists, stub_c_exists)
 396                      <- codeOutput dflags prepd_result
 397                                    stg_binds 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 type_env rdr_env tc_expr
 642   = do  { let dflags = hsc_dflags hsc_env
 643
 644                 -- Desugar it
 645         ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 646
 647                 -- Flatten it
 648         ; flat_expr <- flattenExpr hsc_env pcs ds_expr
 649
 650                 -- Simplify it
 651         ; simpl_expr <- simplifyExpr dflags flat_expr
 652
 653                 -- Tidy it (temporary, until coreSat does cloning)
 654         ; tidy_expr <- tidyCoreExpr simpl_expr
 655
 656                 -- Prepare for codegen
 657         ; prepd_expr <- corePrepExpr dflags tidy_expr
 658
 659                 -- Convert to BCOs
 660         ; bcos <- coreExprToBCOs dflags prepd_expr
 661
 662                 -- link it
 663         ; hval <- linkExpr hsc_env pcs bcos
 664
 665         ; return hval
 666      }
 667 #endif
 668 \end{code}
 669
 670
 671 %************************************************************************
 672 %*                                                                      *
 673 \subsection{Initial persistent state}
 674 %*                                                                      *
 675 %************************************************************************
 676
 677 \begin{code}
 678 initPersistentCompilerState :: IO PersistentCompilerState
 679 initPersistentCompilerState
 680   = do nc <- initNameCache
 681        return (
 682         PCS { pcs_EPS = initExternalPackageState,
 683               pcs_nc  = nc })
 684
 685 initNameCache :: IO NameCache
 686   = do us <- mkSplitUniqSupply 'r'
 687        return (NameCache { nsUniqs = us,
 688                            nsNames = initOrigNames,
 689                            nsIPs   = emptyFM })
 690
 691 initExternalPackageState :: ExternalPackageState
 692 initExternalPackageState
 693   = EPS {
 694       eps_decls      = (emptyNameEnv, 0),
 695       eps_insts      = (emptyBag, 0),
 696       eps_inst_gates = emptyNameSet,
 697       eps_rules      = foldr add_rule (emptyBag, 0) builtinRules,
 698
 699       eps_PIT       = emptyPackageIfaceTable,
 700       eps_PTE       = wiredInThingEnv,
 701       eps_inst_env  = emptyInstEnv,
 702       eps_rule_base = emptyRuleBase }
 703
 704   where
 705     add_rule (name,rule) (rules, n_slurped)
 706          = (gated_decl `consBag` rules, n_slurped)
 707         where
 708            gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
 709            mod        = nameModule name
 710            rdr_name   = nameRdrName name
 711            gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
 712
 713 initOrigNames :: OrigNameCache
 714 initOrigNames
 715    = insert knownKeyNames $
 716      insert (map getName wiredInThings) $
 717      emptyModuleEnv
 718   where
 719      insert names env = foldl extendOrigNameCache env names
 720 \end{code}