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, newHscEnv, hscCmmFile, hscBufferFrontEnd
  10 #ifdef GHCI
  11         , hscStmt, hscTcExpr, hscKcType
  12         , hscGetInfo, GetInfoResult
  13         , compileExpr
  14 #endif
  15         ) where
  16
  17 #include "HsVersions.h"
  18
  19 #ifdef GHCI
  20 import HsSyn            ( Stmt(..), LStmt, LHsExpr, LHsType )
  21 import IfaceSyn         ( IfaceDecl, IfaceInst )
  22 import CodeOutput       ( outputForeignStubs )
  23 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  24 import Linker           ( HValue, linkExpr )
  25 import TidyPgm          ( tidyCoreExpr )
  26 import CorePrep         ( corePrepExpr )
  27 import Flattening       ( flattenExpr )
  28 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType )
  29 import RdrName          ( rdrNameOcc )
  30 import OccName          ( occNameUserString )
  31 import Type             ( Type )
  32 import PrelNames        ( iNTERACTIVE )
  33 import StringBuffer     ( stringToStringBuffer )
  34 import Kind             ( Kind )
  35 import Var              ( Id )
  36 import CoreLint         ( lintUnfolding )
  37 import DsMeta           ( templateHaskellNames )
  38 import BasicTypes       ( Fixity )
  39 #endif
  40
  41 import RdrName          ( RdrName )
  42 import HsSyn            ( HsModule )
  43 import SrcLoc           ( SrcLoc, noSrcLoc, Located(..) )
  44 import StringBuffer     ( hGetStringBuffer )
  45 import Parser
  46 import Lexer            ( P(..), ParseResult(..), mkPState )
  47 import SrcLoc           ( mkSrcLoc )
  48 import TcRnDriver       ( tcRnModule, tcRnExtCore )
  49 import TcIface          ( typecheckIface )
  50 import IfaceEnv         ( initNameCache )
  51 import LoadIface        ( ifaceStats, initExternalPackageState )
  52 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
  53 import RdrName          ( GlobalRdrEnv )
  54 import MkIface          ( checkOldIface, mkIface )
  55 import Desugar
  56 import Flattening       ( flatten )
  57 import SimplCore
  58 import TidyPgm          ( tidyCorePgm )
  59 import CorePrep         ( corePrepPgm )
  60 import CoreToStg        ( coreToStg )
  61 import Name             ( Name, NamedThing(..) )
  62 import SimplStg         ( stg2stg )
  63 import CodeGen          ( codeGen )
  64 import CmmParse         ( parseCmmFile )
  65 import CodeOutput       ( codeOutput )
  66
  67 import CmdLineOpts
  68 import DriverPhases     ( isExtCoreFilename )
  69 import ErrUtils
  70 import UniqSupply       ( mkSplitUniqSupply )
  71
  72 import Outputable
  73 import HscStats         ( ppSourceStats )
  74 import HscTypes
  75 import MkExternalCore   ( emitExternalCore )
  76 import ParserCore
  77 import ParserCoreUtils
  78 import Module           ( Module, ModLocation(..), showModMsg )
  79 import FastString
  80 import Maybes           ( expectJust )
  81 import StringBuffer     ( StringBuffer )
  82 import Bag              ( unitBag, emptyBag )
  83
  84 import Monad            ( when )
  85 import Maybe            ( isJust, fromJust )
  86 import IO
  87 import DATA_IOREF       ( newIORef, readIORef )
  88 \end{code}
  89
  90
  91 %************************************************************************
  92 %*                                                                      *
  93                 Initialisation
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98 newHscEnv :: GhciMode -> DynFlags -> IO HscEnv
  99 newHscEnv ghci_mode dflags
 100   = do  { eps_var <- newIORef initExternalPackageState
 101         ; us      <- mkSplitUniqSupply 'r'
 102         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
 103         ; return (HscEnv { hsc_mode   = ghci_mode,
 104                            hsc_dflags = dflags,
 105                            hsc_HPT    = emptyHomePackageTable,
 106                            hsc_EPS    = eps_var,
 107                            hsc_NC     = nc_var } ) }
 108
 109
 110 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
 111                         -- where templateHaskellNames are defined
 112 knownKeyNames = map getName wiredInThings
 113               ++ basicKnownKeyNames
 114 #ifdef GHCI
 115               ++ templateHaskellNames
 116 #endif
 117 \end{code}
 118
 119
 120 %************************************************************************
 121 %*                                                                      *
 122                 The main compiler pipeline
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 \begin{code}
 127 data HscResult
 128    -- Compilation failed
 129    = HscFail
 130
 131    -- In IDE mode: we just do the static/dynamic checks
 132    | HscChecked (Located (HsModule RdrName))
 133
 134    -- Concluded that it wasn't necessary
 135    | HscNoRecomp ModDetails              -- new details (HomeSymbolTable additions)
 136                  ModIface                -- new iface (if any compilation was done)
 137
 138    -- Did recompilation
 139    | HscRecomp   ModDetails             -- new details (HomeSymbolTable additions)
 140                  (Maybe GlobalRdrEnv)
 141                  ModIface               -- new iface (if any compilation was done)
 142                  Bool                   -- stub_h exists
 143                  Bool                   -- stub_c exists
 144                  (Maybe CompiledByteCode)
 145
 146
 147 -- What to do when we have compiler error or warning messages
 148 type MessageAction = Messages -> IO ()
 149
 150         -- no errors or warnings; the individual passes
 151         -- (parse/rename/typecheck) print messages themselves
 152
 153 hscMain
 154   :: HscEnv
 155   -> MessageAction              -- what to do with errors/warnings
 156   -> Module
 157   -> ModLocation                -- location info
 158   -> Bool                       -- True <=> source unchanged
 159   -> Bool                       -- True <=> have an object file (for msgs only)
 160   -> Maybe ModIface             -- old interface, if available
 161   -> IO HscResult
 162
 163 hscMain hsc_env msg_act mod location
 164         source_unchanged have_object maybe_old_iface
 165  = do {
 166       (recomp_reqd, maybe_checked_iface) <-
 167                 _scc_ "checkOldIface"
 168                 checkOldIface hsc_env mod
 169                               (ml_hi_file location)
 170                               source_unchanged maybe_old_iface;
 171
 172       let no_old_iface = not (isJust maybe_checked_iface)
 173           what_next | recomp_reqd || no_old_iface = hscRecomp
 174                     | otherwise                   = hscNoRecomp
 175
 176       ; what_next hsc_env msg_act have_object
 177                   mod location maybe_checked_iface
 178       }
 179
 180
 181 -- hscNoRecomp definitely expects to have the old interface available
 182 hscNoRecomp hsc_env msg_act have_object
 183             mod location (Just old_iface)
 184  | isOneShot (hsc_mode hsc_env)
 185  = do {
 186       compilationProgressMsg (hsc_dflags hsc_env) $
 187         "compilation IS NOT required";
 188       dumpIfaceStats hsc_env ;
 189
 190       let { bomb = panic "hscNoRecomp:OneShot" };
 191       return (HscNoRecomp bomb bomb)
 192       }
 193  | otherwise
 194  = do {
 195       compilationProgressMsg (hsc_dflags hsc_env) $
 196         ("Skipping  " ++ showModMsg have_object mod location);
 197
 198       new_details <- _scc_ "tcRnIface"
 199                      typecheckIface hsc_env old_iface ;
 200       dumpIfaceStats hsc_env ;
 201
 202       return (HscNoRecomp new_details old_iface)
 203       }
 204
 205 hscRecomp hsc_env msg_act have_object
 206           mod location maybe_checked_iface
 207  = do   {
 208           -- what target are we shooting for?
 209         ; let one_shot  = isOneShot (hsc_mode hsc_env)
 210         ; let dflags    = hsc_dflags hsc_env
 211         ; let toInterp  = dopt_HscLang dflags == HscInterpreted
 212         ; let toCore    = isJust (ml_hs_file location) &&
 213                           isExtCoreFilename (fromJust (ml_hs_file location))
 214
 215         ; when (not one_shot) $
 216                 compilationProgressMsg dflags $
 217                   ("Compiling " ++ showModMsg (not toInterp) mod location);
 218
 219         ; front_res <- if toCore then
 220                           hscCoreFrontEnd hsc_env msg_act location
 221                        else
 222                           hscFileFrontEnd hsc_env msg_act location
 223
 224         ; case front_res of
 225             Left flure -> return flure;
 226             Right ds_result -> do {
 227
 228
 229         -- OMITTED:
 230         -- ; seqList imported_modules (return ())
 231
 232             -------------------
 233             -- FLATTENING
 234             -------------------
 235         ; flat_result <- _scc_ "Flattening"
 236                          flatten hsc_env ds_result
 237
 238
 239 {-      TEMP: need to review space-leak fixing here
 240         NB: even the code generator can force one of the
 241             thunks for constructor arguments, for newtypes in particular
 242
 243         ; let   -- Rule-base accumulated from imported packages
 244              pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
 245
 246                 -- In one-shot mode, ZAP the external package state at
 247                 -- this point, because we aren't going to need it from
 248                 -- now on.  We keep the name cache, however, because
 249                 -- tidyCore needs it.
 250              pcs_middle
 251                  | one_shot  = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
 252                  | otherwise = pcs_tc
 253
 254         ; pkg_rule_base `seq` pcs_middle `seq` return ()
 255 -}
 256
 257         -- alive at this point:
 258         --      pcs_middle
 259         --      flat_result
 260         --      pkg_rule_base
 261
 262             -------------------
 263             -- SIMPLIFY
 264             -------------------
 265         ; simpl_result <- _scc_ "Core2Core"
 266                           core2core hsc_env flat_result
 267
 268             -------------------
 269             -- TIDY
 270             -------------------
 271         ; tidy_result <- _scc_ "CoreTidy"
 272                          tidyCorePgm hsc_env simpl_result
 273
 274         -- Emit external core
 275         ; emitExternalCore dflags tidy_result
 276
 277         -- Alive at this point:
 278         --      tidy_result, pcs_final
 279         --      hsc_env
 280
 281             -------------------
 282             -- BUILD THE NEW ModIface and ModDetails
 283             --  and emit external core if necessary
 284             -- This has to happen *after* code gen so that the back-end
 285             -- info has been set.  Not yet clear if it matters waiting
 286             -- until after code output
 287         ; new_iface <- _scc_ "MkFinalIface"
 288                         mkIface hsc_env location
 289                                 maybe_checked_iface tidy_result
 290
 291
 292             -- Space leak reduction: throw away the new interface if
 293             -- we're in one-shot mode; we won't be needing it any
 294             -- more.
 295         ; final_iface <-
 296              if one_shot then return (error "no final iface")
 297                          else return new_iface
 298         ; let { final_globals | one_shot  = Nothing
 299                               | otherwise = Just $! (mg_rdr_env tidy_result) }
 300         ; final_globals `seq` return ()
 301
 302             -- Build the final ModDetails (except in one-shot mode, where
 303             -- we won't need this information after compilation).
 304         ; final_details <-
 305              if one_shot then return (error "no final details")
 306                          else return $! ModDetails {
 307                                            md_types = mg_types tidy_result,
 308                                            md_insts = mg_insts tidy_result,
 309                                            md_rules = mg_rules tidy_result }
 310
 311             -------------------
 312             -- CONVERT TO STG and COMPLETE CODE GENERATION
 313         ; (stub_h_exists, stub_c_exists, maybe_bcos)
 314                 <- hscBackEnd dflags tidy_result
 315
 316           -- And the answer is ...
 317         ; dumpIfaceStats hsc_env
 318
 319         ; return (HscRecomp final_details
 320                             final_globals
 321                             final_iface
 322                             stub_h_exists stub_c_exists
 323                             maybe_bcos)
 324          }}
 325
 326 hscCoreFrontEnd hsc_env msg_act location = do {
 327             -------------------
 328             -- PARSE
 329             -------------------
 330         ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
 331         ; case parseCore inp 1 of
 332             FailP s        -> putMsg s{-ToDo: wrong-} >> return (Left HscFail)
 333             OkP rdr_module -> do {
 334
 335             -------------------
 336             -- RENAME and TYPECHECK
 337             -------------------
 338         ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck"
 339                               tcRnExtCore hsc_env rdr_module
 340         ; msg_act tc_msgs
 341         ; case maybe_tc_result of {
 342              Nothing       -> return (Left  HscFail);
 343              Just mod_guts -> return (Right mod_guts)
 344                                         -- No desugaring to do!
 345         }}}
 346
 347
 348 hscFileFrontEnd hsc_env msg_act location = do {
 349             -------------------
 350             -- PARSE
 351             -------------------
 352         ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
 353                              (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
 354
 355         ; case maybe_parsed of {
 356              Left err -> do { msg_act (unitBag err, emptyBag) ;
 357                             ; return (Left HscFail) ;
 358                             };
 359              Right rdr_module -> hscFrontEnd hsc_env msg_act rdr_module
 360     }}
 361
 362 -- Perform static/dynamic checks on the source code in a StringBuffer
 363 -- This is a temporary solution: it'll read in interface files lazily, whereas
 364 -- we probably want to use the compilation manager to load in all the modules
 365 -- in a project.
 366 hscBufferFrontEnd :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
 367 hscBufferFrontEnd hsc_env buffer msg_act = do
 368         let loc  = mkSrcLoc (mkFastString "*edit*") 1 0
 369         showPass (hsc_dflags hsc_env) "Parser"
 370         case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of
 371                 PFailed span err -> do
 372                         msg_act (emptyBag, unitBag (mkPlainErrMsg span err))
 373                         return HscFail
 374                 POk _ rdr_module -> do
 375                         r <- hscFrontEnd hsc_env msg_act rdr_module
 376                         case r of
 377                            Left r -> return r
 378                            Right _ -> return (HscChecked rdr_module)
 379
 380
 381
 382 hscFrontEnd hsc_env msg_act rdr_module  = do {
 383             -------------------
 384             -- RENAME and TYPECHECK
 385             -------------------
 386         ; (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
 387                                         tcRnModule hsc_env rdr_module
 388         ; msg_act tc_msgs
 389         ; case maybe_tc_result of {
 390              Nothing -> return (Left HscFail);
 391              Just tc_result -> do {
 392
 393             -------------------
 394             -- DESUGAR
 395             -------------------
 396         ; (warns, maybe_ds_result) <- _scc_ "DeSugar"
 397                              deSugar hsc_env tc_result
 398         ; msg_act (warns, emptyBag)
 399         ; case maybe_ds_result of
 400             Nothing        -> return (Left HscFail);
 401             Just ds_result -> return (Right ds_result);
 402         }}}
 403
 404 hscBackEnd dflags
 405     ModGuts{  -- This is the last use of the ModGuts in a compilation.
 406               -- From now on, we just use the bits we need.
 407         mg_module   = this_mod,
 408         mg_binds    = core_binds,
 409         mg_types    = type_env,
 410         mg_dir_imps = dir_imps,
 411         mg_foreign  = foreign_stubs,
 412         mg_deps     = dependencies     }  = do {
 413
 414             -------------------
 415             -- PREPARE FOR CODE GENERATION
 416             -- Do saturation and convert to A-normal form
 417   prepd_binds <- _scc_ "CorePrep"
 418                  corePrepPgm dflags core_binds type_env;
 419
 420   case dopt_HscLang dflags of
 421       HscNothing -> return (False, False, Nothing)
 422
 423       HscInterpreted ->
 424 #ifdef GHCI
 425         do  -----------------  Generate byte code ------------------
 426             comp_bc <- byteCodeGen dflags prepd_binds type_env
 427
 428             ------------------ Create f-x-dynamic C-side stuff ---
 429             (istub_h_exists, istub_c_exists)
 430                <- outputForeignStubs dflags foreign_stubs
 431
 432             return ( istub_h_exists, istub_c_exists, Just comp_bc )
 433 #else
 434         panic "GHC not compiled with interpreter"
 435 #endif
 436
 437       other ->
 438         do
 439             -----------------  Convert to STG ------------------
 440             (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
 441                          myCoreToStg dflags this_mod prepd_binds
 442
 443             ------------------  Code generation ------------------
 444             abstractC <- _scc_ "CodeGen"
 445                          codeGen dflags this_mod type_env foreign_stubs
 446                                  dir_imps cost_centre_info stg_binds
 447
 448             ------------------  Code output -----------------------
 449             (stub_h_exists, stub_c_exists)
 450                      <- codeOutput dflags this_mod foreign_stubs
 451                                 dependencies abstractC
 452
 453             return (stub_h_exists, stub_c_exists, Nothing)
 454    }
 455
 456
 457 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 458 hscCmmFile dflags filename = do
 459   maybe_cmm <- parseCmmFile dflags filename
 460   case maybe_cmm of
 461     Nothing -> return False
 462     Just cmm -> do
 463         codeOutput dflags no_mod NoStubs noDependencies [cmm]
 464         return True
 465   where
 466         no_mod = panic "hscCmmFile: no_mod"
 467
 468
 469 myParseModule dflags src_filename
 470  = do --------------------------  Parser  ----------------
 471       showPass dflags "Parser"
 472       _scc_  "Parser" do
 473       buf <- hGetStringBuffer src_filename
 474
 475       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 476
 477       case unP parseModule (mkPState buf loc dflags) of {
 478
 479         PFailed span err -> return (Left (mkPlainErrMsg span err));
 480
 481         POk _ rdr_module -> do {
 482
 483       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 484
 485       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 486                            (ppSourceStats False rdr_module) ;
 487
 488       return (Right rdr_module)
 489         -- ToDo: free the string buffer later.
 490       }}
 491
 492
 493 myCoreToStg dflags this_mod prepd_binds
 494  = do
 495       stg_binds <- _scc_ "Core2Stg"
 496              coreToStg dflags prepd_binds
 497
 498       (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
 499              stg2stg dflags this_mod stg_binds
 500
 501       return (stg_binds2, cost_centre_info)
 502 \end{code}
 503
 504
 505 %************************************************************************
 506 %*                                                                      *
 507 \subsection{Compiling a do-statement}
 508 %*                                                                      *
 509 %************************************************************************
 510
 511 When the UnlinkedBCOExpr is linked you get an HValue of type
 512         IO [HValue]
 513 When you run it you get a list of HValues that should be
 514 the same length as the list of names; add them to the ClosureEnv.
 515
 516 A naked expression returns a singleton Name [it].
 517
 518         What you type                   The IO [HValue] that hscStmt returns
 519         -------------                   ------------------------------------
 520         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 521                                         bindings: [x,y,...]
 522
 523         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 524                                         bindings: [x,y,...]
 525
 526         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 527           [NB: result not printed]      bindings: [it]
 528
 529
 530         expr (of non-IO type,
 531           result showable)      ==>     let v = expr in print v >> return [v]
 532                                         bindings: [it]
 533
 534         expr (of non-IO type,
 535           result not showable)  ==>     error
 536
 537 \begin{code}
 538 #ifdef GHCI
 539 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 540   :: HscEnv
 541   -> InteractiveContext         -- Context for compiling
 542   -> String                     -- The statement
 543   -> IO (Maybe (InteractiveContext, [Name], HValue))
 544
 545 hscStmt hsc_env icontext stmt
 546   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 547         ; case maybe_stmt of {
 548              Nothing      -> return Nothing ;   -- Parse error
 549              Just Nothing -> return Nothing ;   -- Empty line
 550              Just (Just parsed_stmt) -> do {    -- The real stuff
 551
 552                 -- Rename and typecheck it
 553           maybe_tc_result
 554                  <- tcRnStmt hsc_env icontext parsed_stmt
 555
 556         ; case maybe_tc_result of {
 557                 Nothing -> return Nothing ;
 558                 Just (new_ic, bound_names, tc_expr) -> do {
 559
 560                 -- Then desugar, code gen, and link it
 561         ; hval <- compileExpr hsc_env iNTERACTIVE
 562                               (ic_rn_gbl_env new_ic)
 563                               (ic_type_env new_ic)
 564                               tc_expr
 565
 566         ; return (Just (new_ic, bound_names, hval))
 567         }}}}}
 568
 569 hscTcExpr       -- Typecheck an expression (but don't run it)
 570   :: HscEnv
 571   -> InteractiveContext         -- Context for compiling
 572   -> String                     -- The expression
 573   -> IO (Maybe Type)
 574
 575 hscTcExpr hsc_env icontext expr
 576   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 577         ; case maybe_stmt of {
 578              Nothing      -> return Nothing ;   -- Parse error
 579              Just (Just (L _ (ExprStmt expr _)))
 580                         -> tcRnExpr hsc_env icontext expr ;
 581              Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ;
 582                                 return Nothing } ;
 583              } }
 584
 585 hscKcType       -- Find the kind of a type
 586   :: HscEnv
 587   -> InteractiveContext         -- Context for compiling
 588   -> String                     -- The type
 589   -> IO (Maybe Kind)
 590
 591 hscKcType hsc_env icontext str
 592   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 593         ; case maybe_type of {
 594              Just ty    -> tcRnType hsc_env icontext ty ;
 595              Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ;
 596                                 return Nothing } ;
 597              Nothing    -> return Nothing } }
 598 \end{code}
 599
 600 \begin{code}
 601 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 602 hscParseStmt = hscParseThing parseStmt
 603
 604 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 605 hscParseType = hscParseThing parseType
 606
 607 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 608 hscParseIdentifier = hscParseThing parseIdentifier
 609
 610 hscParseThing :: Outputable thing
 611               => Lexer.P thing
 612               -> DynFlags -> String
 613               -> IO (Maybe thing)
 614         -- Nothing => Parse error (message already printed)
 615         -- Just x  => success
 616 hscParseThing parser dflags str
 617  = do showPass dflags "Parser"
 618       _scc_ "Parser"  do
 619
 620       buf <- stringToStringBuffer str
 621
 622       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 623
 624       case unP parser (mkPState buf loc dflags) of {
 625
 626         PFailed span err -> do { printError span err;
 627                                  return Nothing };
 628
 629         POk _ thing -> do {
 630
 631       --ToDo: can't free the string buffer until we've finished this
 632       -- compilation sweep and all the identifiers have gone away.
 633       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 634       return (Just thing)
 635       }}
 636 #endif
 637 \end{code}
 638
 639 %************************************************************************
 640 %*                                                                      *
 641 \subsection{Getting information about an identifer}
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 \begin{code}
 646 #ifdef GHCI
 647 type GetInfoResult = (String, (IfaceDecl, Fixity, SrcLoc, [(IfaceInst,SrcLoc)]))
 648
 649 hscGetInfo -- like hscStmt, but deals with a single identifier
 650   :: HscEnv
 651   -> InteractiveContext         -- Context for compiling
 652   -> String                     -- The identifier
 653   -> IO [GetInfoResult]
 654
 655 hscGetInfo hsc_env ic str
 656    = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
 657         case maybe_rdr_name of {
 658           Nothing -> return [];
 659           Just (L _ rdr_name) -> do
 660
 661         maybe_tc_result <- tcRnGetInfo hsc_env ic rdr_name
 662
 663         let     -- str' is the the naked occurrence name
 664                 -- after stripping off qualification and parens (+)
 665            str' = occNameUserString (rdrNameOcc rdr_name)
 666
 667         case maybe_tc_result of {
 668              Nothing     -> return [] ;
 669              Just things -> return [(str', t) | t <- things]
 670         }}
 671 #endif
 672 \end{code}
 673
 674 %************************************************************************
 675 %*                                                                      *
 676         Desugar, simplify, convert to bytecode, and link an expression
 677 %*                                                                      *
 678 %************************************************************************
 679
 680 \begin{code}
 681 #ifdef GHCI
 682 compileExpr :: HscEnv
 683             -> Module -> GlobalRdrEnv -> TypeEnv
 684             -> LHsExpr Id
 685             -> IO HValue
 686
 687 compileExpr hsc_env this_mod rdr_env type_env tc_expr
 688   = do  { let { dflags  = hsc_dflags hsc_env ;
 689                 lint_on = dopt Opt_DoCoreLinting dflags }
 690
 691                 -- Desugar it
 692         ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 693
 694                 -- Flatten it
 695         ; flat_expr <- flattenExpr hsc_env ds_expr
 696
 697                 -- Simplify it
 698         ; simpl_expr <- simplifyExpr dflags flat_expr
 699
 700                 -- Tidy it (temporary, until coreSat does cloning)
 701         ; tidy_expr <- tidyCoreExpr simpl_expr
 702
 703                 -- Prepare for codegen
 704         ; prepd_expr <- corePrepExpr dflags tidy_expr
 705
 706                 -- Lint if necessary
 707                 -- ToDo: improve SrcLoc
 708         ; if lint_on then
 709                 case lintUnfolding noSrcLoc [] prepd_expr of
 710                    Just err -> pprPanic "compileExpr" err
 711                    Nothing  -> return ()
 712           else
 713                 return ()
 714
 715                 -- Convert to BCOs
 716         ; bcos <- coreExprToBCOs dflags prepd_expr
 717
 718                 -- link it
 719         ; hval <- linkExpr hsc_env bcos
 720
 721         ; return hval
 722      }
 723 #endif
 724 \end{code}
 725
 726
 727 %************************************************************************
 728 %*                                                                      *
 729         Statistics on reading interfaces
 730 %*                                                                      *
 731 %************************************************************************
 732
 733 \begin{code}
 734 dumpIfaceStats :: HscEnv -> IO ()
 735 dumpIfaceStats hsc_env
 736   = do  { eps <- readIORef (hsc_EPS hsc_env)
 737         ; dumpIfSet (dump_if_trace || dump_rn_stats)
 738                     "Interface statistics"
 739                     (ifaceStats eps) }
 740   where
 741     dflags = hsc_dflags hsc_env
 742     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
 743     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 744 \end{code}