X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=47bde9659d42f7c5cd0b1801b3e87aea24f5c5d3;hb=aee44bbe090c356d649398a93e260d967a7c50db;hp=627a49d5cca7e3247b2c84e469858e27bdf5f079;hpb=08040f3e223222f26c13a8455e2d74bd623fda48;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 627a49d..47bde96 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -62,7 +62,8 @@ module HscMain #ifdef GHCI , hscGetModuleExports , hscTcRnLookupRdrName - , hscStmt, hscTcExpr, hscImport, hscKcType + , hscStmt, hscStmtWithLocation + , hscTcExpr, hscImport, hscKcType , hscCompileCoreExpr #endif @@ -113,17 +114,15 @@ import TyCon ( TyCon, isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) -import Cmm ( Cmm ) +import OldCmm ( Cmm ) import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) import CmmBuildInfoTables import CmmCPS -import CmmCPSZ import CmmInfo import OptimizationFuel ( initOptFuelState ) import CmmCvt -import CmmTx -import CmmContFlowOpt +import CmmContFlowOpt ( runCmmContFlowOpts ) import CodeOutput import NameEnv ( emptyNameEnv ) import NameSet ( emptyNameSet ) @@ -163,9 +162,9 @@ import Data.IORef newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do { eps_var <- newIORef initExternalPackageState - ; us <- mkSplitUniqSupply 'r' - ; nc_var <- newIORef (initNameCache us knownKeyNames) - ; fc_var <- newIORef emptyUFM + ; us <- mkSplitUniqSupply 'r' + ; nc_var <- newIORef (initNameCache us knownKeyNames) + ; fc_var <- newIORef emptyUFM ; mlc_var <- newIORef emptyModuleEnv ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, @@ -181,12 +180,13 @@ newHscEnv dflags hsc_type_env_var = Nothing } ) } -knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, - -- where templateHaskellNames are defined -knownKeyNames = map getName wiredInThings - ++ basicKnownKeyNames +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames + = map getName wiredInThings + ++ basicKnownKeyNames #ifdef GHCI - ++ templateHaskellNames + ++ templateHaskellNames #endif -- ----------------------------------------------------------------------------- @@ -894,7 +894,7 @@ hscGenHardCode cgguts mod_summary stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - -- cmms <- optionallyConvertAndOrCPS hsc_env cmms + cmms <- optionallyConvertAndOrCPS hsc_env cmms -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms @@ -974,17 +974,17 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" (pprCmms prog) - ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog + ; prog <- return $ map runCmmContFlowOpts prog -- Control flow optimisation -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. ; us <- mkSplitUniqSupply 'S' ; let topSRT = initUs_ us emptySRT - ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog + ; (topSRT, prog) <- foldM (protoCmmCPS hsc_env) (topSRT, []) prog -- The main CPS conversion - ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog) + ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog) -- Control flow optimisation, again ; let prog' = map cmmOfZgraph prog @@ -999,11 +999,6 @@ optionallyConvertAndOrCPS hsc_env cmms = cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags then mapM (testCmmConversion hsc_env) cmms else return cmms - --------- Optionally convert to CPS (MDA) ----------- - cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && - dopt Opt_RunCPS dflags - then cmmCPS dflags cmms - else return cmms return cmms @@ -1014,17 +1009,15 @@ testCmmConversion hsc_env cmm = dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' - let cfopts = runTx $ runCmmOpts cmmCfgOptsZ - let cvtm = do g <- cmmToZgraph cmm - return $ cfopts g + let cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm let zgraph = initUs_ us cvtm us <- mkSplitUniqSupply 'S' let topSRT = initUs_ us emptySRT - (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph + (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) zgraph let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) showPass dflags "Convert from Z back to Cmm" - let cvt = cmmOfZgraph $ cfopts $ chosen_graph + let cvt = cmmOfZgraph $ runCmmContFlowOpts $ chosen_graph dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) return cvt @@ -1083,8 +1076,17 @@ hscStmt -- Compile a stmt all the way to an HValue, but don't run it -> String -- The statement -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error -hscStmt hsc_env stmt = runHsc hsc_env $ do - maybe_stmt <- hscParseStmt stmt +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 + +hscStmtWithLocation -- Compile a stmt all the way to an HValue, but don't run it + :: HscEnv + -> String -- The statement + -> String -- the source + -> Int -- ^ starting line + -> IO (Maybe ([Id], HValue)) + -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error +hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing Just parsed_stmt -> do -- The real stuff @@ -1150,6 +1152,11 @@ hscKcType hsc_env str = runHsc hsc_env $ do hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName)) hscParseStmt = hscParseThing parseStmt +hscParseStmtWithLocation :: String -> Int + -> String -> Hsc (Maybe (LStmt RdrName)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + hscParseType :: String -> Hsc (LHsType RdrName) hscParseType = hscParseThing parseType #endif @@ -1158,19 +1165,24 @@ hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = runHsc hsc_env $ hscParseThing parseIdentifier str - hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "" 1 -hscParseThing parser str +hscParseThingWithLocation :: (Outputable thing) + => String -> Int + -> Lexer.P thing + -> String + -> Hsc thing +hscParseThingWithLocation source linenumber parser str = {-# SCC "Parser" #-} do dflags <- getDynFlags liftIO $ showPass dflags "Parser" - + let buf = stringToStringBuffer str - loc = mkSrcLoc (fsLit "") 1 1 + loc = mkSrcLoc (fsLit source) linenumber 1 case unP parser (mkPState dflags buf loc) of @@ -1216,6 +1228,7 @@ mkModGuts mod binds = ModGuts { mg_insts = [], mg_fam_insts = [], mg_rules = [], + mg_vect_decls = [], mg_binds = binds, mg_foreign = NoStubs, mg_warns = NoWarnings, @@ -1257,15 +1270,13 @@ hscCompileCoreExpr hsc_env srcspan ds_expr -- Lint if necessary -- ToDo: improve SrcLoc - if lint_on then + when lint_on $ let ictxt = hsc_IC hsc_env tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt))) in case lintUnfolding noSrcLoc tyvars prepd_expr of Just err -> pprPanic "hscCompileCoreExpr" err Nothing -> return () - else - return () -- Convert to BCOs bcos <- coreExprToBCOs dflags prepd_expr