X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=d68058db76e9e6db102430692bf84f55be6aa528;hb=230dc0b04ad444140cab040073adfd0efba24878;hp=4da59433a33cc7506ec66af4efbf4e2a2a3b9668;hpb=e1f7582a9d9f4112bec7b92a61c7f2366ab91666;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 4da5943..d68058d 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -33,6 +33,7 @@ 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 ) @@ -51,6 +52,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 @@ -65,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 ) @@ -74,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 ) @@ -183,7 +188,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 @@ -472,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 -------------------------------------------------------------- @@ -601,10 +607,13 @@ 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 >>= 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 @@ -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,7 +682,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 { @@ -682,20 +691,31 @@ hscFileCheck hsc_env mod_summary = do { md_insts = tcg_insts tc_result, md_fam_insts = tcg_fam_insts tc_result, md_modBreaks = emptyModBreaks, - md_rules = [panic "no rules"] } + 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))) }}}} @@ -705,7 +725,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" @@ -797,7 +819,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 (InteractiveContext, [Name], HValue)) + -> IO (Maybe ([Id], HValue)) hscStmt hsc_env stmt = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt @@ -812,12 +834,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 { @@ -828,7 +849,7 @@ hscStmt hsc_env stmt ; let src_span = srcLocSpan interactiveSrcLoc ; hval <- compileExpr hsc_env src_span ds_expr - ; return (Just (new_ic, bound_names, hval)) + ; return (Just (ids, hval)) }}}}}}} hscTcExpr -- Typecheck an expression (but don't run it)