Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/2e8f08c68fc2dabeec6bdd829c17a5946bb51e3a >--------------------------------------------------------------- commit 2e8f08c68fc2dabeec6bdd829c17a5946bb51e3a Author: Simon Marlow <[email protected]> Date: Thu Sep 20 15:54:55 2012 +0100 splitAtProcPoints: jump to the right place when tablesNextToCode == False >--------------------------------------------------------------- compiler/cmm/CmmPipeline.hs | 3 ++- compiler/cmm/CmmProcPoint.hs | 35 ++++++++++++++++++++++++----------- 2 files changed, 26 insertions(+), 12 deletions(-) diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 25fda1c..5fca9e7 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) procPointAnalysis proc_points g dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ - splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g) + splitAtProcPoints dflags l call_pps proc_points pp_map + (CmmProc h l g) dumps Opt_D_dump_cmmz_split "Post splitting" gs ------------- Populate info tables with stack info ----------------- diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 58f2e54..471faf8 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -11,6 +11,7 @@ where import Prelude hiding (last, unzip, succ, zip) +import DynFlags import BlockId import CLabel import Cmm @@ -26,8 +27,6 @@ import UniqSupply import Hoopl -import qualified Data.Map as Map - -- Compute a minimal set of proc points for a control-flow graph. -- Determine a protocol for each proc point (which live variables will @@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints = -- Input invariant: A block should only be reachable from a single ProcPoint. -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY -splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> +splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> CmmDecl -> UniqSM [CmmDecl] -splitAtProcPoints entry_label callPPs procPoints procMap +splitAtProcPoints dflags entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) top_l g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach @@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap -- * Labels for the info tables of their new procedures (only if -- the proc point is a callPP) -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = Map.insert pp lbls map + let add_label map pp = mapInsert pp lbls map where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label)) | otherwise = (blockLbl pp, guard (setMember pp callPPs) >> Just (infoTblLbl pp)) - procLabels = foldl add_label Map.empty + + procLabels :: LabelMap (CLabel, Maybe CLabel) + procLabels = foldl add_label mapEmpty (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + -- In each new graph, add blocks jumping off to the new procedures, -- and replace branches to procpoints with branches to the jump-off blocks let add_jump_block (env, bs) (pp, l) = @@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst) CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl) _ -> rst - add_if_pp id rst = case Map.lookup id procLabels of - Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst + + -- when jumping to a PP that has an info table, if + -- tablesNextToCode is off we must jump to the entry + -- label instead. + jump_label (Just info_lbl) _ + | tablesNextToCode dflags = info_lbl + | otherwise = toEntryLbl info_lbl + jump_label Nothing block_lbl = block_lbl + + add_if_pp id rst = case mapLookup id procLabels of + Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst Nothing -> rst (jumpEnv, jumpBlocks) <- foldM add_jump_block (mapEmpty, []) needed_jumps @@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap let g' = ofBlockMap ppId blockEnv''' -- pprTrace "g' pre jumps" (ppr g') $ do return (mapInsert ppId g' newGraphEnv) + graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv - let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of + + let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of (lbl, Just info_lbl) | bid == entry -> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info}) @@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap replacePPIds g = {-# SCC "replacePPIds" #-} mapGraphNodes (id, mapExp repl, mapExp repl) g where repl e@(CmmLit (CmmBlock bid)) = - case Map.lookup bid procLabels of + case mapLookup bid procLabels of Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) _ -> e repl e = e @@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap return -- pprTrace "procLabels" (ppr procLabels) -- pprTrace "splitting graphs" (ppr procs) procs -splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] +splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
