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