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