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