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