X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=93324d59bc789e19c32e0238c5d2372e70e6455b;hb=d0f6db5b0cf1189d84e292aeca350211f3b810dd;hp=463c3035364adb44bc990a14e7b48d2205435df5;hpb=6d94e4fef600e9f14112e11d3e1ff20834bf3446;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 463c303..93324d5 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,8 +25,7 @@ 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 ) @@ -43,6 +42,7 @@ import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) +import VarSet import VarEnv ( emptyTidyEnv ) #endif @@ -51,6 +51,7 @@ import Module ( emptyModuleEnv, ModLocation(..) ) import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, HaddockModInfo ) +import CoreSyn import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) import Parser @@ -74,9 +75,9 @@ import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) +import CmmCPS import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) -import Breakpoints ( noDbgSites ) import DynFlags import ErrUtils @@ -184,7 +185,8 @@ data HscChecked 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 @@ -289,31 +291,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 @@ -404,7 +401,7 @@ batchMsg mb_mod_index recomp liftIO $ do if recomp then showMsg "Compiling " - else if verbosity (hsc_dflags hsc_env) >= 1 + else if verbosity (hsc_dflags hsc_env) >= 2 then showMsg "Skipping " else return () @@ -607,10 +604,12 @@ hscCompile cgguts codeGen dflags this_mod data_tycons foreign_stubs dir_imps cost_centre_info stg_binds hpc_info + ------------------ Convert to CPS -------------------- + continuationC <- cmmCPS dflags 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 @@ -641,7 +640,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 @@ -652,8 +651,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 ------------------- @@ -679,7 +678,7 @@ 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 type_env = tcg_type_env tc_result md = ModDetails { @@ -687,21 +686,32 @@ hscFileCheck hsc_env mod_summary = do { 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"] } + md_modBreaks = emptyModBreaks, + md_rules = [panic "no rules"], -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker + md_vect_info = + panic "HscMain.hscFileCheck: no VectInfo" + -- 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 let doc = tcg_doc tc_result hmi = tcg_hmi tc_result return (decl,imports,exports,doc,hmi) - return (Just (HscChecked rdr_module + 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))) }}}} @@ -711,7 +721,8 @@ 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] + codeOutput dflags no_mod no_loc NoStubs [] continuationC return True where no_mod = panic "hscCmmFile: no_mod" @@ -803,7 +814,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 @@ -818,12 +829,11 @@ 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 new_ic - type_env = ic_type_env new_ic + ; 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 { @@ -834,7 +844,7 @@ hscStmt hsc_env stmt ; 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) @@ -940,7 +950,10 @@ compileExpr hsc_env srcspan ds_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