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