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