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 )
  40 import Parser
  41 import Lexer            ( P(..), ParseResult(..), ExtFlags(..),
  42                           mkPState, showPFailed )
  43 import SrcLoc           ( mkSrcLoc )
  44 import TcRnDriver       ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
  45 import RnEnv            ( extendOrigNameCache )
  46 import PrelInfo         ( wiredInThingEnv, knownKeyNames )
  47 import PrelRules        ( builtinRules )
  48 import MkIface          ( mkIface )
  49 import Desugar
  50 import Flattening       ( flatten )
  51 import SimplCore
  52 import TidyPgm          ( tidyCorePgm )
  53 import CorePrep         ( corePrepPgm )
  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) <- _scc_ "tcRnIface"
 157                                    tcRnIface hsc_env pcs_ch old_iface ;
 158
 159       case maybe_tc_result of {
 160          Nothing -> return (HscFail pcs_tc);
 161          Just new_details ->
 162
 163       return (HscNoRecomp pcs_tc new_details old_iface)
 164       }}
 165
 166 hscRecomp hsc_env pcs_ch have_object
 167           mod location maybe_checked_iface
 168  = do   {
 169           -- what target are we shooting for?
 170         ; let one_shot  = hsc_mode hsc_env == OneShot
 171         ; let dflags    = hsc_dflags hsc_env
 172         ; let toInterp  = dopt_HscLang dflags == HscInterpreted
 173         ; let toCore    = isJust (ml_hs_file location) &&
 174                           isExtCore_file (fromJust (ml_hs_file location))
 175
 176         ; when (not one_shot && verbosity dflags >= 1) $
 177                 hPutStrLn stderr ("Compiling " ++
 178                         showModMsg (not toInterp) mod location);
 179
 180         ; front_res <- if toCore then
 181                           hscCoreFrontEnd hsc_env pcs_ch location
 182                        else
 183                           hscFrontEnd hsc_env pcs_ch location
 184
 185         ; case front_res of
 186             Left flure -> return flure;
 187             Right (pcs_tc, ds_result) -> do {
 188
 189
 190         -- OMITTED:
 191         -- ; seqList imported_modules (return ())
 192
 193             -------------------
 194             -- FLATTENING
 195             -------------------
 196         ; flat_result <- _scc_ "Flattening"
 197                          flatten hsc_env pcs_tc ds_result
 198
 199
 200         ; let   -- Rule-base accumulated from imported packages
 201              pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc)
 202
 203                 -- In one-shot mode, ZAP the external package state at
 204                 -- this point, because we aren't going to need it from
 205                 -- now on.  We keep the name cache, however, because
 206                 -- tidyCore needs it.
 207              pcs_middle
 208                  | one_shot  = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
 209                  | otherwise = pcs_tc
 210
 211         ; pkg_rule_base `seq` pcs_middle `seq` return ()
 212
 213         -- alive at this point:
 214         --      pcs_middle
 215         --      flat_result
 216         --      pkg_rule_base
 217
 218             -------------------
 219             -- SIMPLIFY
 220             -------------------
 221         ; simpl_result <- _scc_     "Core2Core"
 222                           core2core hsc_env pkg_rule_base flat_result
 223
 224             -------------------
 225             -- TIDY
 226             -------------------
 227         ; (pcs_simpl, tidy_result)
 228              <- _scc_ "CoreTidy"
 229                 tidyCorePgm dflags pcs_middle simpl_result
 230
 231         -- ZAP the persistent compiler state altogether now if we're
 232         -- in one-shot mode, to save space.
 233         ; pcs_final <- if one_shot then return (error "pcs_final missing")
 234                                    else return pcs_simpl
 235
 236         ; emitExternalCore dflags tidy_result
 237
 238         -- Alive at this point:
 239         --      tidy_result, pcs_final
 240         --      hsc_env
 241
 242             -------------------
 243             -- BUILD THE NEW ModIface and ModDetails
 244             --  and emit external core if necessary
 245             -- This has to happen *after* code gen so that the back-end
 246             -- info has been set.  Not yet clear if it matters waiting
 247             -- until after code output
 248         ; new_iface <- _scc_ "MkFinalIface"
 249                         mkIface hsc_env location
 250                                 maybe_checked_iface tidy_result
 251
 252
 253             -- Space leak reduction: throw away the new interface if
 254             -- we're in one-shot mode; we won't be needing it any
 255             -- more.
 256         ; final_iface <-
 257              if one_shot then return (error "no final iface")
 258                          else return new_iface
 259
 260             -- Build the final ModDetails (except in one-shot mode, where
 261             -- we won't need this information after compilation).
 262         ; final_details <-
 263              if one_shot then return (error "no final details")
 264                          else return $! ModDetails {
 265                                            md_types = mg_types tidy_result,
 266                                            md_insts = mg_insts tidy_result,
 267                                            md_rules = mg_rules tidy_result }
 268
 269             -------------------
 270             -- CONVERT TO STG and COMPLETE CODE GENERATION
 271         ; (stub_h_exists, stub_c_exists, maybe_bcos)
 272                 <- hscBackEnd dflags tidy_result
 273
 274           -- and the answer is ...
 275         ; return (HscRecomp pcs_final
 276                             final_details
 277                             final_iface
 278                             stub_h_exists stub_c_exists
 279                             maybe_bcos)
 280          }}
 281
 282 hscCoreFrontEnd hsc_env pcs_ch location = do {
 283             -------------------
 284             -- PARSE
 285             -------------------
 286         ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
 287         ; case parseCore inp 1 of
 288             FailP s        -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
 289             OkP rdr_module -> do {
 290
 291             -------------------
 292             -- RENAME and TYPECHECK
 293             -------------------
 294         ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
 295                                        tcRnExtCore hsc_env pcs_ch rdr_module
 296         ; case maybe_tc_result of {
 297              Nothing       -> return (Left  (HscFail pcs_tc));
 298              Just mod_guts -> return (Right (pcs_tc, mod_guts))
 299                                         -- No desugaring to do!
 300         }}}
 301
 302
 303 hscFrontEnd hsc_env pcs_ch location = do {
 304             -------------------
 305             -- PARSE
 306             -------------------
 307         ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
 308                              (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
 309
 310         ; case maybe_parsed of {
 311              Nothing -> return (Left (HscFail pcs_ch));
 312              Just rdr_module -> do {
 313
 314             -------------------
 315             -- RENAME and TYPECHECK
 316             -------------------
 317         ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename"
 318                                         tcRnModule hsc_env pcs_ch rdr_module
 319         ; case maybe_tc_result of {
 320              Nothing -> return (Left (HscFail pcs_ch));
 321              Just tc_result -> do {
 322
 323             -------------------
 324             -- DESUGAR
 325             -------------------
 326         ; ds_result <- _scc_ "DeSugar"
 327                        deSugar hsc_env pcs_tc tc_result
 328         ; return (Right (pcs_tc, ds_result))
 329         }}}}}
 330
 331
 332 hscBackEnd dflags
 333     ModGuts{  -- This is the last use of the ModGuts in a compilation.
 334               -- From now on, we just use the bits we need.
 335         mg_module   = this_mod,
 336         mg_binds    = core_binds,
 337         mg_types    = type_env,
 338         mg_dir_imps = dir_imps,
 339         mg_foreign  = foreign_stubs,
 340         mg_deps     = dependencies     }  = do {
 341
 342             -------------------
 343             -- PREPARE FOR CODE GENERATION
 344             -- Do saturation and convert to A-normal form
 345   prepd_binds <- _scc_ "CorePrep"
 346                  corePrepPgm dflags core_binds type_env;
 347
 348   case dopt_HscLang dflags of
 349       HscNothing -> return (False, False, Nothing)
 350
 351       HscInterpreted ->
 352 #ifdef GHCI
 353         do  -----------------  Generate byte code ------------------
 354             comp_bc <- byteCodeGen dflags prepd_binds type_env
 355
 356             ------------------ Create f-x-dynamic C-side stuff ---
 357             (istub_h_exists, istub_c_exists)
 358                <- outputForeignStubs dflags foreign_stubs
 359
 360             return ( istub_h_exists, istub_c_exists, Just comp_bc )
 361 #else
 362         panic "GHC not compiled with interpreter"
 363 #endif
 364
 365       other ->
 366         do
 367             -----------------  Convert to STG ------------------
 368             (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
 369                          myCoreToStg dflags this_mod prepd_binds
 370
 371             ------------------  Code generation ------------------
 372             abstractC <- _scc_ "CodeGen"
 373                          codeGen dflags this_mod type_env foreign_stubs
 374                                  dir_imps cost_centre_info stg_binds
 375
 376             ------------------  Code output -----------------------
 377             (stub_h_exists, stub_c_exists)
 378                      <- codeOutput dflags this_mod foreign_stubs
 379                                 dependencies abstractC
 380
 381             return (stub_h_exists, stub_c_exists, Nothing)
 382    }
 383
 384
 385 myParseModule dflags src_filename
 386  = do --------------------------  Parser  ----------------
 387       showPass dflags "Parser"
 388       _scc_  "Parser" do
 389       buf <- hGetStringBuffer src_filename
 390
 391       let exts = mkExtFlags dflags
 392           loc  = mkSrcLoc (mkFastString src_filename) 1 0
 393
 394       case unP parseModule (mkPState buf loc exts) of {
 395
 396         PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
 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 0
 515
 516       case unP parseStmt (mkPState buf loc exts) of {
 517
 518         PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
 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       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
 529       return (Just rdr_stmt)
 530       }}
 531 #endif
 532 \end{code}
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsection{Getting information about an identifer}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 \begin{code}
 541 #ifdef GHCI
 542 hscThing -- like hscStmt, but deals with a single identifier
 543   :: HscEnv
 544   -> PersistentCompilerState    -- IN: persistent compiler state
 545   -> InteractiveContext         -- Context for compiling
 546   -> String                     -- The identifier
 547   -> IO ( PersistentCompilerState,
 548           [TyThing] )
 549
 550 hscThing hsc_env pcs0 ic str
 551    = do let dflags         = hsc_dflags hsc_env
 552
 553         maybe_rdr_name <- myParseIdentifier dflags str
 554         case maybe_rdr_name of {
 555           Nothing -> return (pcs0, []);
 556           Just rdr_name -> do
 557
 558         (pcs1, maybe_tc_result) <-
 559            tcRnThing hsc_env pcs0 ic rdr_name
 560
 561         case maybe_tc_result of {
 562              Nothing     -> return (pcs1, []) ;
 563              Just things -> return (pcs1, things)
 564         }}
 565
 566 myParseIdentifier dflags str
 567   = do buf <- stringToStringBuffer str
 568
 569        let exts = mkExtFlags dflags
 570            loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 571
 572        case unP parseIdentifier (mkPState buf loc exts) of
 573
 574           PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err);
 575                                     return Nothing }
 576
 577           POk _ rdr_name -> return (Just rdr_name)
 578 #endif
 579 \end{code}
 580
 581 %************************************************************************
 582 %*                                                                      *
 583         Desugar, simplify, convert to bytecode, and link an expression
 584 %*                                                                      *
 585 %************************************************************************
 586
 587 \begin{code}
 588 #ifdef GHCI
 589 compileExpr :: HscEnv
 590             -> PersistentCompilerState
 591             -> Module -> GlobalRdrEnv -> TypeEnv
 592             -> TypecheckedHsExpr
 593             -> IO HValue
 594
 595 compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 596   = do  { let { dflags  = hsc_dflags hsc_env ;
 597                 lint_on = dopt Opt_DoCoreLinting dflags }
 598
 599                 -- Desugar it
 600         ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 601
 602                 -- Flatten it
 603         ; flat_expr <- flattenExpr hsc_env pcs ds_expr
 604
 605                 -- Simplify it
 606         ; simpl_expr <- simplifyExpr dflags flat_expr
 607
 608                 -- Tidy it (temporary, until coreSat does cloning)
 609         ; tidy_expr <- tidyCoreExpr simpl_expr
 610
 611                 -- Prepare for codegen
 612         ; prepd_expr <- corePrepExpr dflags tidy_expr
 613
 614                 -- Lint if necessary
 615                 -- ToDo: improve SrcLoc
 616         ; if lint_on then
 617                 case lintUnfolding noSrcLoc [] prepd_expr of
 618                    Just err -> pprPanic "compileExpr" err
 619                    Nothing  -> return ()
 620           else
 621                 return ()
 622
 623                 -- Convert to BCOs
 624         ; bcos <- coreExprToBCOs dflags prepd_expr
 625
 626                 -- link it
 627         ; hval <- linkExpr hsc_env pcs bcos
 628
 629         ; return hval
 630      }
 631 #endif
 632 \end{code}
 633
 634
 635 %************************************************************************
 636 %*                                                                      *
 637 \subsection{Initial persistent state}
 638 %*                                                                      *
 639 %************************************************************************
 640
 641 \begin{code}
 642 initPersistentCompilerState :: IO PersistentCompilerState
 643 initPersistentCompilerState
 644   = do nc <- initNameCache
 645        return (
 646         PCS { pcs_EPS = initExternalPackageState,
 647               pcs_nc  = nc })
 648
 649 initNameCache :: IO NameCache
 650   = do us <- mkSplitUniqSupply 'r'
 651        return (NameCache { nsUniqs = us,
 652                            nsNames = initOrigNames,
 653                            nsIPs   = emptyFM })
 654
 655 initExternalPackageState :: ExternalPackageState
 656 initExternalPackageState
 657   = emptyExternalPackageState {
 658       eps_rules  = foldr add_rule (emptyBag, 0) builtinRules,
 659       eps_PTE    = wiredInThingEnv,
 660     }
 661   where
 662     add_rule (name,rule) (rules, n_slurped)
 663          = (gated_decl `consBag` rules, n_slurped)
 664         where
 665            gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
 666            mod        = nameModule name
 667            rdr_name   = nameRdrName name        -- Seems a bit of a hack to go back
 668                                                 -- to the RdrName
 669            gate_fn vis_fn = vis_fn name         -- Load the rule whenever name is visible
 670
 671 initOrigNames :: OrigNameCache
 672 initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames
 673
 674 mkExtFlags dflags
 675   = ExtFlags { glasgowExtsEF = dopt Opt_GlasgowExts dflags,
 676                ffiEF         = dopt Opt_FFI      dflags,
 677                withEF        = dopt Opt_With     dflags,
 678                arrowsEF      = dopt Opt_Arrows   dflags,
 679                parrEF        = dopt Opt_PArr     dflags}
 680 \end{code}