X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=cafba835c69b31928fafc7484c62bbf429abd952;hb=6e2021202c3eec0c95a9d0b7c355559f2630d380;hp=422c2701724f716c4fbb547447cb43f0df6f0527;hpb=7a59afcebe45ea87c42006873f77eb4600d7316f;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 422c270..cafba83 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,7 +25,8 @@ module HscMain #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LStmt, LHsType ) +import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) +import Module ( Module ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) @@ -38,7 +39,7 @@ import SimplCore ( simplifyExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) -import Kind ( Kind ) +import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) @@ -48,11 +49,12 @@ import VarEnv ( emptyTidyEnv ) import Var ( Id ) import Module ( emptyModuleEnv, ModLocation(..) ) import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) -import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl ) +import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, + HaddockModInfo ) import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) import Parser -import Lexer ( P(..), ParseResult(..), mkPState ) +import Lexer import SrcLoc ( mkSrcLoc ) import TcRnDriver ( tcRnModule, tcRnExtCore ) import TcIface ( typecheckIface ) @@ -74,6 +76,7 @@ import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) +import Breakpoints ( noDbgSites ) import DynFlags import ErrUtils @@ -88,9 +91,11 @@ import ParserCoreUtils import FastString import UniqFM ( emptyUFM ) import Bag ( unitBag ) -import Monad ( unless ) -import IO -import DATA_IOREF ( newIORef, readIORef ) + +import Control.Monad +import System.Exit +import System.IO +import Data.IORef \end{code} @@ -175,7 +180,8 @@ data HscChecked -- parsed (Located (HsModule RdrName)) -- renamed - (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name])) + (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe (HsDoc Name), HaddockModInfo Name)) -- typechecked (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) @@ -398,7 +404,7 @@ batchMsg mb_mod_index recomp liftIO $ do if recomp then showMsg "Compiling " - else if verbosity (hsc_dflags hsc_env) >= 2 + else if verbosity (hsc_dflags hsc_env) >= 1 then showMsg "Skipping " else return () @@ -462,7 +468,7 @@ hscFileFrontEnd = ------------------- -- DESUGAR ------------------- - -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result + -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result -------------------------------------------------------------- -- Simplifiers @@ -524,7 +530,7 @@ hscNormalIface simpl_result <- {-# SCC "MkFinalIface" #-} mkIface hsc_env maybe_old_iface simpl_result details -- Emit external core - emitExternalCore (hsc_dflags hsc_env) (mg_exports simpl_result) cg_guts -- Move this? --Lemmih 03/07/2006 + emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006 dumpIfaceStats hsc_env ------------------- @@ -538,9 +544,11 @@ hscNormalIface simpl_result hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) hscWriteIface (iface, no_change, details, a) = do mod_summary <- gets compModSummary + hsc_env <- gets compHscEnv + let dflags = hsc_dflags hsc_env liftIO $ do unless no_change - $ writeIfaceFile (ms_location mod_summary) iface + $ writeIfaceFile dflags (ms_location mod_summary) iface return (iface, details, a) hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) @@ -577,7 +585,8 @@ hscCompile cgguts cg_tycons = tycons, cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, - cg_dep_pkgs = dependencies } = cgguts + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary data_tycons = filter isDataTyCon tycons @@ -597,7 +606,7 @@ hscCompile cgguts abstractC <- {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons foreign_stubs dir_imps cost_centre_info - stg_binds + stg_binds hpc_info ------------------ Code output ----------------------- (stub_h_exists,stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs @@ -672,17 +681,22 @@ hscFileCheck hsc_env mod_summary = do { ; case maybe_tc_result of { Nothing -> return (Just (HscChecked rdr_module Nothing Nothing)); Just tc_result -> do - let md = ModDetails { - md_types = tcg_type_env tc_result, - md_exports = tcg_exports tc_result, - md_insts = tcg_insts tc_result, - md_rules = [panic "no rules"] } + let type_env = tcg_type_env tc_result + md = ModDetails { + md_types = type_env, + md_exports = tcg_exports tc_result, + md_insts = tcg_insts tc_result, + md_fam_insts = tcg_fam_insts tc_result, + md_dbg_sites = noDbgSites, + md_rules = [panic "no rules"] } -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker rnInfo = do decl <- tcg_rn_decls tc_result imports <- tcg_rn_imports tc_result let exports = tcg_rn_exports tc_result - return (decl,imports,exports) + let doc = tcg_doc tc_result + hmi = tcg_hmi tc_result + return (decl,imports,exports,doc,hmi) return (Just (HscChecked rdr_module rnInfo (Just (tcg_binds tc_result, @@ -724,8 +738,12 @@ myParseModule dflags src_filename maybe_src_buf PFailed span err -> return (Left (mkPlainErrMsg span err)); - POk _ rdr_module -> do { + POk pst rdr_module -> do { + let {ms = getMessages pst}; + printErrorsAndWarnings dflags ms; + when (errorsFound dflags ms) $ exitWith (ExitFailure 1); + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" @@ -880,7 +898,11 @@ hscParseThing parser dflags str PFailed span err -> do { printError span err; return Nothing }; - POk _ thing -> do { + POk pst thing -> do { + + let {ms = getMessages pst}; + printErrorsAndWarnings dflags ms; + when (errorsFound dflags ms) $ exitWith (ExitFailure 1); --ToDo: can't free the string buffer until we've finished this -- compilation sweep and all the identifiers have gone away.