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 "hscFrontEnd: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 abstractC
 397
 398             return (stub_h_exists, stub_c_exists, Nothing)
 399
 400
 401 myParseModule dflags src_filename
 402  = do --------------------------  Parser  ----------------
 403       showPass dflags "Parser"
 404       _scc_  "Parser" do
 405       buf <- hGetStringBuffer src_filename
 406
 407       let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
 408                            ffiEF         = dopt Opt_FFI         dflags,
 409                            withEF        = dopt Opt_With        dflags,
 410                            parrEF        = dopt Opt_PArr        dflags}
 411           loc  = mkSrcLoc (mkFastString src_filename) 1
 412
 413       case parseModule buf (mkPState loc exts) of {
 414
 415         PFailed err -> do { hPutStrLn stderr (showSDoc err);
 416                             freeStringBuffer buf;
 417                             return Nothing };
 418
 419         POk _ rdr_module -> do {
 420
 421       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 422
 423       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 424                            (ppSourceStats False rdr_module) ;
 425
 426       return (Just rdr_module)
 427         -- ToDo: free the string buffer later.
 428       }}
 429
 430
 431 myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds})
 432  = do
 433       () <- coreBindsSize tidy_binds `seq` return ()
 434       -- TEMP: the above call zaps some space usage allocated by the
 435       -- simplifier, which for reasons I don't understand, persists
 436       -- thoroughout code generation -- JRS
 437       --
 438       -- This is still necessary. -- SDM (10 Dec 2001)
 439
 440       stg_binds <- _scc_ "Core2Stg"
 441              coreToStg dflags tidy_binds
 442
 443       (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
 444              stg2stg dflags this_mod stg_binds
 445
 446       let env_rhs :: CgInfoEnv
 447           env_rhs = mkNameEnv [ caf_info `seq` (idName bndr, CgInfo caf_info)
 448                               | (bind,_) <- stg_binds2,
 449                                 let caf_info
 450                                      | stgBindHasCafRefs bind = MayHaveCafRefs
 451                                      | otherwise              = NoCafRefs,
 452                                 bndr <- stgBinders bind ]
 453
 454       return (stg_binds2, cost_centre_info, env_rhs)
 455 \end{code}
 456
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection{Compiling a do-statement}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 When the UnlinkedBCOExpr is linked you get an HValue of type
 465         IO [HValue]
 466 When you run it you get a list of HValues that should be
 467 the same length as the list of names; add them to the ClosureEnv.
 468
 469 A naked expression returns a singleton Name [it].
 470
 471         What you type                   The IO [HValue] that hscStmt returns
 472         -------------                   ------------------------------------
 473         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 474                                         bindings: [x,y,...]
 475
 476         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 477                                         bindings: [x,y,...]
 478
 479         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 480           [NB: result not printed]      bindings: [it]
 481
 482
 483         expr (of non-IO type,
 484           result showable)      ==>     let v = expr in print v >> return [v]
 485                                         bindings: [it]
 486
 487         expr (of non-IO type,
 488           result not showable)  ==>     error
 489
 490 \begin{code}
 491 #ifdef GHCI
 492 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 493   :: HscEnv
 494   -> PersistentCompilerState    -- IN: persistent compiler state
 495   -> InteractiveContext         -- Context for compiling
 496   -> String                     -- The statement
 497   -> IO ( PersistentCompilerState,
 498           Maybe (InteractiveContext, [Name], HValue) )
 499
 500 hscStmt hsc_env pcs icontext stmt
 501   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 502         ; case maybe_stmt of {
 503              Nothing -> return (pcs, Nothing) ;
 504              Just parsed_stmt -> do {
 505
 506                 -- Rename and typecheck it
 507           (pcs1, maybe_tc_result)
 508                  <- tcRnStmt hsc_env pcs icontext parsed_stmt
 509
 510         ; case maybe_tc_result of {
 511                 Nothing -> return (pcs1, Nothing) ;
 512                 Just (new_ic, bound_names, tc_expr) -> do {
 513
 514                 -- Then desugar, code gen, and link it
 515         ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
 516                               (ic_rn_gbl_env new_ic)
 517                               (ic_type_env new_ic)
 518                               tc_expr
 519
 520         ; return (pcs1, Just (new_ic, bound_names, hval))
 521         }}}}}
 522
 523 hscTcExpr       -- Typecheck an expression (but don't run it)
 524   :: HscEnv
 525   -> PersistentCompilerState    -- IN: persistent compiler state
 526   -> InteractiveContext         -- Context for compiling
 527   -> String                     -- The expression
 528   -> IO (PersistentCompilerState, Maybe Type)
 529
 530 hscTcExpr hsc_env pcs icontext expr
 531   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 532         ; case maybe_stmt of {
 533              Just (ExprStmt expr _ _)
 534                         -> tcRnExpr hsc_env pcs icontext expr ;
 535              Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
 536                                 return (pcs, Nothing) } ;
 537              Nothing    -> return (pcs, Nothing) } }
 538 \end{code}
 539
 540 \begin{code}
 541 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
 542 hscParseStmt dflags str
 543  = do showPass dflags "Parser"
 544       _scc_ "Parser"  do
 545
 546       buf <- stringToStringBuffer str
 547
 548       let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
 549                            ffiEF         = dopt Opt_FFI         dflags,
 550                            withEF        = dopt Opt_With        dflags,
 551                            parrEF        = dopt Opt_PArr        dflags}
 552           loc  = mkSrcLoc FSLIT("<interactive>") 1
 553
 554       case parseStmt buf (mkPState loc exts) of {
 555
 556         PFailed err -> do { hPutStrLn stderr (showSDoc err);
 557 --      Not yet implemented in <4.11    freeStringBuffer buf;
 558                             return Nothing };
 559
 560         -- no stmt: the line consisted of just space or comments
 561         POk _ Nothing -> return Nothing;
 562
 563         POk _ (Just rdr_stmt) -> do {
 564
 565       --ToDo: can't free the string buffer until we've finished this
 566       -- compilation sweep and all the identifiers have gone away.
 567       --freeStringBuffer buf;
 568       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
 569       return (Just rdr_stmt)
 570       }}
 571 #endif
 572 \end{code}
 573
 574 %************************************************************************
 575 %*                                                                      *
 576 \subsection{Getting information about an identifer}
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 \begin{code}
 581 #ifdef GHCI
 582 hscThing -- like hscStmt, but deals with a single identifier
 583   :: HscEnv
 584   -> PersistentCompilerState    -- IN: persistent compiler state
 585   -> InteractiveContext         -- Context for compiling
 586   -> String                     -- The identifier
 587   -> IO ( PersistentCompilerState,
 588           [TyThing] )
 589
 590 hscThing hsc_env pcs0 ic str
 591    = do let dflags         = hsc_dflags hsc_env
 592
 593         maybe_rdr_name <- myParseIdentifier dflags str
 594         case maybe_rdr_name of {
 595           Nothing -> return (pcs0, []);
 596           Just rdr_name -> do
 597
 598         (pcs1, maybe_tc_result) <-
 599            tcRnThing hsc_env pcs0 ic rdr_name
 600
 601         case maybe_tc_result of {
 602              Nothing     -> return (pcs1, []) ;
 603              Just things -> return (pcs1, things)
 604         }}
 605
 606 myParseIdentifier dflags str
 607   = do buf <- stringToStringBuffer str
 608
 609        let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
 610                             ffiEF         = dopt Opt_FFI         dflags,
 611                             withEF        = dopt Opt_With        dflags,
 612                             parrEF        = dopt Opt_PArr        dflags}
 613            loc  = mkSrcLoc FSLIT("<interactive>") 1
 614
 615        case parseIdentifier buf (mkPState loc exts) of
 616
 617           PFailed err -> do { hPutStrLn stderr (showSDoc err);
 618                               freeStringBuffer buf;
 619                               return Nothing }
 620
 621           POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
 622                                  return (Just rdr_name) }
 623 #endif
 624 \end{code}
 625
 626 %************************************************************************
 627 %*                                                                      *
 628         Desugar, simplify, convert to bytecode, and link an expression
 629 %*                                                                      *
 630 %************************************************************************
 631
 632 \begin{code}
 633 #ifdef GHCI
 634 compileExpr :: HscEnv
 635             -> PersistentCompilerState
 636             -> Module -> GlobalRdrEnv -> TypeEnv
 637             -> TypecheckedHsExpr
 638             -> IO HValue
 639
 640 compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 641   = do  { let dflags = hsc_dflags hsc_env
 642
 643                 -- Desugar it
 644         ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 645
 646                 -- Flatten it
 647         ; flat_expr <- flattenExpr hsc_env pcs ds_expr
 648
 649                 -- Simplify it
 650         ; simpl_expr <- simplifyExpr dflags flat_expr
 651
 652                 -- Tidy it (temporary, until coreSat does cloning)
 653         ; tidy_expr <- tidyCoreExpr simpl_expr
 654
 655                 -- Prepare for codegen
 656         ; prepd_expr <- corePrepExpr dflags tidy_expr
 657
 658                 -- Convert to BCOs
 659         ; bcos <- coreExprToBCOs dflags prepd_expr
 660
 661                 -- link it
 662         ; hval <- linkExpr hsc_env pcs bcos
 663
 664         ; return hval
 665      }
 666 #endif
 667 \end{code}
 668
 669
 670 %************************************************************************
 671 %*                                                                      *
 672 \subsection{Initial persistent state}
 673 %*                                                                      *
 674 %************************************************************************
 675
 676 \begin{code}
 677 initPersistentCompilerState :: IO PersistentCompilerState
 678 initPersistentCompilerState
 679   = do nc <- initNameCache
 680        return (
 681         PCS { pcs_EPS = initExternalPackageState,
 682               pcs_nc  = nc })
 683
 684 initNameCache :: IO NameCache
 685   = do us <- mkSplitUniqSupply 'r'
 686        return (NameCache { nsUniqs = us,
 687                            nsNames = initOrigNames,
 688                            nsIPs   = emptyFM })
 689
 690 initExternalPackageState :: ExternalPackageState
 691 initExternalPackageState
 692   = EPS {
 693       eps_decls      = (emptyNameEnv, 0),
 694       eps_insts      = (emptyBag, 0),
 695       eps_inst_gates = emptyNameSet,
 696       eps_rules      = foldr add_rule (emptyBag, 0) builtinRules,
 697
 698       eps_PIT       = emptyPackageIfaceTable,
 699       eps_PTE       = wiredInThingEnv,
 700       eps_inst_env  = emptyInstEnv,
 701       eps_rule_base = emptyRuleBase }
 702
 703   where
 704     add_rule (name,rule) (rules, n_slurped)
 705          = (gated_decl `consBag` rules, n_slurped)
 706         where
 707            gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
 708            mod        = nameModule name
 709            rdr_name   = nameRdrName name
 710            gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
 711
 712 initOrigNames :: OrigNameCache
 713 initOrigNames
 714    = insert knownKeyNames $
 715      insert (map getName wiredInThings) $
 716      emptyModuleEnv
 717   where
 718      insert names env = foldl extendOrigNameCache env names
 719 \end{code}