X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=a120926717639da666968e4eb2b53897d1327910;hp=841125a0c5ef927fb7e5aa5d96657a1079d94e08;hb=de2d10e18ce23e5df7fa4f3433b85c95d6092b58;hpb=7b0ff1792d699ff02a604163c9ccf4a98a1ca3eb diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 841125a..a120926 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -109,7 +109,8 @@ import CoreToStg ( coreToStg ) import qualified StgCmm ( codeGen ) import StgSyn import CostCentre -import TyCon ( TyCon, isDataTyCon ) +import ProfInit +import TyCon ( TyCon, isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -117,7 +118,7 @@ import OldCmm ( Cmm ) import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) import CmmBuildInfoTables -import CmmCPS +import CmmPipeline import CmmInfo import OptimizationFuel ( initOptFuelState ) import CmmCvt @@ -339,7 +340,7 @@ hscParse' mod_summary Just b -> return b Nothing -> liftIO $ hGetStringBuffer src_filename - let loc = mkSrcLoc (mkFastString src_filename) 1 1 + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 case unP parseModule (mkPState dflags buf loc) of PFailed span err -> @@ -429,7 +430,7 @@ makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result It's the task of the compilation proper to compile Haskell, hs-boot and -core files to either byte-code, hard-code (C, asm, Java, ect) or to +core files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all (the module is still parsed and type-checked. This feature is mostly used by IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', 'nothing', @@ -863,8 +864,7 @@ hscGenHardCode cgguts mod_summary cg_module = this_mod, cg_binds = core_binds, cg_tycons = tycons, - cg_dir_imps = dir_imps, - cg_foreign = foreign_stubs, + cg_foreign = foreign_stubs0, cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env @@ -883,16 +883,19 @@ hscGenHardCode cgguts mod_summary <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds + let prof_init = profilingInitCode this_mod cost_centre_info + foreign_stubs = foreign_stubs0 `appendStubC` prof_init + ------------------ Code generation ------------------ cmms <- if dopt Opt_TryNewCodeGen dflags then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info return cmms else {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- @@ -963,35 +966,28 @@ hscCompileCmmFile hsc_env filename -------------------- Stuff for new code gen --------------------- -tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> [Module] - -> CollectedCCs - -> [(StgBinding,[(Id,[Id])])] - -> HpcInfo - -> IO [Cmm] -tryNewCodeGen hsc_env this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info = - do { let dflags = hsc_dflags hsc_env - ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" - (pprCmms prog) - - ; prog <- return $ map runCmmContFlowOpts prog - -- Control flow optimisation +tryNewCodeGen :: HscEnv -> Module -> [TyCon] + -> CollectedCCs + -> [(StgBinding,[(Id,[Id])])] + -> HpcInfo + -> IO [Cmm] +tryNewCodeGen hsc_env this_mod data_tycons + cost_centre_info stg_binds hpc_info = + do { let dflags = hsc_dflags hsc_env + ; prog <- StgCmm.codeGen dflags this_mod data_tycons + cost_centre_info stg_binds hpc_info + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" + (pprCmms prog) -- 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 (protoCmmCPS hsc_env) (topSRT, []) prog - -- The main CPS conversion - - ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog) - -- Control flow optimisation, again + ; let initTopSRT = initUs_ us emptySRT + ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog - ; let prog' = map cmmOfZgraph prog - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') - ; return prog' } + ; let prog' = map cmmOfZgraph (srtToData topSRT : prog) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') + ; return prog' } optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] @@ -1011,15 +1007,17 @@ 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 cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm - let zgraph = initUs_ us cvtm - us <- mkSplitUniqSupply 'S' - let topSRT = initUs_ us emptySRT - (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) zgraph - let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph + let zgraph = initUs_ us (cmmToZgraph cmm) + chosen_graph <- + if dopt Opt_RunCPSZ dflags + then do us <- mkSplitUniqSupply 'S' + let topSRT = initUs_ us emptySRT + (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph + return zgraph + else return (runCmmContFlowOpts 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 $ runCmmContFlowOpts $ chosen_graph + let cvt = cmmOfZgraph chosen_graph dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) return cvt @@ -1129,12 +1127,11 @@ hscTcExpr -- Typecheck an expression (but don't run it) hscTcExpr hsc_env expr = runHsc hsc_env $ do maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (ExprStmt expr _ _)) -> - ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr - _ -> - liftIO $ throwIO $ mkSrcErr $ unitBag $ - mkPlainErrMsg noSrcSpan - (text "not an expression:" <+> quotes (text expr)) + Just (L _ (ExprStmt expr _ _ _)) -> + ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr + _ -> + liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan + (text "not an expression:" <+> quotes (text expr)) -- | Find the kind of a type hscKcType @@ -1184,7 +1181,7 @@ hscParseThingWithLocation source linenumber parser str liftIO $ showPass dflags "Parser" let buf = stringToStringBuffer str - loc = mkSrcLoc (fsLit source) linenumber 1 + loc = mkRealSrcLoc (fsLit source) linenumber 1 case unP parser (mkPState dflags buf loc) of