X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=092d1635e2f38b9f8fa9e57dc234b58e9fe45ff3;hp=e5b7026eb57536cb9db4915c0107176c5614d425;hb=bf2f000a552e025ec156010d52aee282bdfcf7a4;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index e5b7026..092d163 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,34 +25,38 @@ module HscMain #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) -import Module ( Module ) +import HsSyn ( Stmt(..), LStmt, LHsType ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) +import CoreSyn ( CoreExpr ) import CoreTidy ( tidyExpr ) import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) +import Vectorise ( vectorise ) import Desugar ( deSugarExpr ) 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 ( noSrcLoc, getLoc ) +import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) +import VarSet import VarEnv ( emptyTidyEnv ) #endif 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 CoreSyn 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 ) @@ -63,6 +67,7 @@ import PrelInfo ( wiredInThings, basicKnownKeyNames ) import MkIface ( checkOldIface, mkIface, writeIfaceFile ) import Desugar ( deSugar ) import Flattening ( flatten ) +import Vectorise ( vectorise ) import SimplCore ( core2core ) import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) @@ -72,6 +77,8 @@ import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) +import CmmCPS +import CmmInfo import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) @@ -88,9 +95,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,10 +184,12 @@ 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)) - + -- desugared + (Maybe [CoreBind]) -- Status of a compilation to hard-code or nothing. data HscStatus @@ -187,7 +198,7 @@ data HscStatus -- This is a hack. We can't compile C files here -- since it's done in DriverPipeline. For now we -- just return True if we want the caller to compile - -- it for us. + -- them for us. -- Status of a compilation to byte-code. data InteractiveStatus @@ -283,31 +294,26 @@ hscMkCompiler norecomp messenger frontend backend -- 1 2 3 4 5 6 7 8 9 -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler HscStatus -hscCompileOneShot hsc_env mod_summary = - compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecompOneShot oneShotMsg - -- How to compile nonBoot files. - nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= - hscWriteIface >>= hscOneShot - -- How to compile boot files. - bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscConst (HscRecomp False) - compiler - = case ms_hsc_src mod_summary of - ExtCoreFile - -> mkComp hscCoreFrontEnd nonBootComp - HsSrcFile - -> mkComp hscFileFrontEnd nonBootComp - HsBootFile - -> mkComp hscFileFrontEnd bootComp +hscCompileOneShot = hscCompileHardCode norecompOneShot oneShotMsg hscOneShot (hscConst (HscRecomp False)) -- Compile Haskell, boot and extCore in batch mode. hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) -hscCompileBatch hsc_env mod_summary - = compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecompBatch batchMsg +hscCompileBatch = hscCompileHardCode norecompBatch batchMsg hscBatch hscNothing + +-- Compile to hardcode (C,asm,...). This general structure is shared by OneShot and Batch. +hscCompileHardCode :: NoRecomp result -- No recomp necessary + -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback + -> ((ModIface, ModDetails, CgGuts) -> Comp result) -- Compile normal file + -> ((ModIface, ModDetails, ModGuts) -> Comp result) -- Compile boot file + -> Compiler result +hscCompileHardCode norecomp msg compNormal compBoot hsc_env mod_summary = + compiler hsc_env mod_summary + where mkComp = hscMkCompiler norecomp msg + -- How to compile nonBoot files. nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= - hscWriteIface >>= hscBatch - bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing + hscWriteIface >>= compNormal + -- How to compile boot files. + bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= compBoot compiler = case ms_hsc_src mod_summary of ExtCoreFile @@ -462,10 +468,7 @@ hscFileFrontEnd = ------------------- -- DESUGAR ------------------- - -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} - deSugar hsc_env tc_result - printBagOfWarnings dflags warns - return maybe_ds_result + -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result -------------------------------------------------------------- -- Simplifiers @@ -475,13 +478,13 @@ hscSimplify :: ModGuts -> Comp ModGuts hscSimplify ds_result = do hsc_env <- gets compHscEnv liftIO $ do - flat_result <- {-# SCC "Flattening" #-} - flatten hsc_env ds_result + vect_result <- {-# SCC "Vectorisation" #-} + vectorise hsc_env ds_result ------------------- -- SIMPLIFY ------------------- simpl_result <- {-# SCC "Core2Core" #-} - core2core hsc_env flat_result + core2core hsc_env vect_result return simpl_result -------------------------------------------------------------- @@ -527,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 ------------------- @@ -541,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) @@ -580,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 @@ -600,11 +606,14 @@ hscCompile cgguts abstractC <- {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons foreign_stubs dir_imps cost_centre_info - stg_binds + stg_binds hpc_info + ------------------ Convert to CPS -------------------- + --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm + continuationC <- cmmToRawCmm abstractC ------------------ Code output ----------------------- (stub_h_exists,stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs - dependencies abstractC + dependencies continuationC return stub_c_exists hscConst :: b -> a -> Comp b @@ -635,7 +644,7 @@ hscInteractive (iface, details, cgguts) prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm dflags core_binds data_tycons ; ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds data_tycons + comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details) ------------------ Create f-x-dynamic C-side stuff --- (istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs @@ -646,8 +655,8 @@ hscInteractive (iface, details, cgguts) ------------------------------ -hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked) -hscFileCheck hsc_env mod_summary = do { +hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked) +hscFileCheck hsc_env mod_summary compileToCore = do { ------------------- -- PARSE ------------------- @@ -673,24 +682,39 @@ hscFileCheck hsc_env mod_summary = do { ; printErrorsAndWarnings dflags tc_msgs ; case maybe_tc_result of { - Nothing -> return (Just (HscChecked rdr_module Nothing Nothing)); + Nothing -> return (Just (HscChecked rdr_module Nothing 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_modBreaks = emptyModBreaks, + md_rules = [panic "no rules"], -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker + md_vect_info = noVectInfo + -- VectInfo is added by the Core + -- vectorisation pass + } 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) - return (Just (HscChecked rdr_module + let doc = tcg_doc tc_result + hmi = tcg_hmi tc_result + return (decl,imports,exports,doc,hmi) + maybeModGuts <- + if compileToCore then + deSugar hsc_env (ms_location mod_summary) tc_result + else + return Nothing + return (Just (HscChecked rdr_module rnInfo (Just (tcg_binds tc_result, tcg_rdr_env tc_result, - md)))) + md)) + (fmap mg_binds maybeModGuts))) }}}} @@ -700,7 +724,9 @@ hscCmmFile dflags filename = do case maybe_cmm of Nothing -> return False Just cmm -> do - codeOutput dflags no_mod no_loc NoStubs [] [cmm] + --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm + continuationC <- cmmToRawCmm [cmm] + codeOutput dflags no_mod no_loc NoStubs [] continuationC return True where no_mod = panic "hscCmmFile: no_mod" @@ -727,8 +753,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" @@ -788,7 +818,7 @@ A naked expression returns a singleton Name [it]. hscStmt -- Compile a stmt all the way to an HValue, but don't run it :: HscEnv -> String -- The statement - -> IO (Maybe (HscEnv, [Name], HValue)) + -> IO (Maybe ([Id], HValue)) hscStmt hsc_env stmt = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt @@ -803,16 +833,23 @@ hscStmt hsc_env stmt ; case maybe_tc_result of { Nothing -> return Nothing ; - Just (new_ic, bound_names, tc_expr) -> do { + Just (ids, tc_expr) -> do { + + -- Desugar it + ; let rdr_env = ic_rn_gbl_env icontext + type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) + ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + + ; case mb_ds_expr of { + Nothing -> return Nothing ; + Just ds_expr -> do { -- Then desugar, code gen, and link it - ; hval <- compileExpr hsc_env iNTERACTIVE - (ic_rn_gbl_env new_ic) - (ic_type_env new_ic) - tc_expr + ; let src_span = srcLocSpan interactiveSrcLoc + ; hval <- compileExpr hsc_env src_span ds_expr - ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval)) - }}}}} + ; return (Just (ids, hval)) + }}}}}}} hscTcExpr -- Typecheck an expression (but don't run it) :: HscEnv @@ -839,10 +876,8 @@ hscKcType hsc_env str = do { maybe_type <- hscParseType (hsc_dflags hsc_env) str ; let icontext = hsc_IC hsc_env ; case maybe_type of { - Just ty -> tcRnType hsc_env icontext ty ; - Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ; - return Nothing } ; - Nothing -> return Nothing } } + Just ty -> tcRnType hsc_env icontext ty ; + Nothing -> return Nothing } } #endif \end{code} @@ -877,7 +912,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. @@ -894,19 +933,12 @@ hscParseThing parser dflags str \begin{code} #ifdef GHCI -compileExpr :: HscEnv - -> Module -> GlobalRdrEnv -> TypeEnv - -> LHsExpr Id - -> IO HValue +compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue -compileExpr hsc_env this_mod rdr_env type_env tc_expr +compileExpr hsc_env srcspan ds_expr = do { let { dflags = hsc_dflags hsc_env ; - lint_on = dopt Opt_DoCoreLinting dflags ; - !srcspan = getLoc tc_expr } + lint_on = dopt Opt_DoCoreLinting dflags } - -- Desugar it - ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr - -- Flatten it ; flat_expr <- flattenExpr hsc_env ds_expr @@ -922,7 +954,10 @@ compileExpr hsc_env this_mod rdr_env type_env tc_expr -- Lint if necessary -- ToDo: improve SrcLoc ; if lint_on then - case lintUnfolding noSrcLoc [] prepd_expr of + let ictxt = hsc_IC hsc_env + tyvars = varSetElems (ic_tyvars ictxt) + in + case lintUnfolding noSrcLoc tyvars prepd_expr of Just err -> pprPanic "compileExpr" err Nothing -> return () else