ghc/compiler/main/HscMain.lhs

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