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