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