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