From a50f11ebc0667355e5669c922adf70f926c1763a Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Wed, 23 May 2007 11:27:29 +0000 Subject: [PATCH] Factored proc-point analysis into separate file (compiler/cmm/CmmProcPoint) --- compiler/cmm/CmmCPS.hs | 127 +----------------------------------------- compiler/cmm/CmmCPSData.hs | 74 ++++++++++++++++++++++++ compiler/cmm/CmmProcPoint.hs | 79 ++++++++++++++++++++++++++ 3 files changed, 155 insertions(+), 125 deletions(-) create mode 100644 compiler/cmm/CmmCPSData.hs create mode 100644 compiler/cmm/CmmProcPoint.hs diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 7cc89ba..2370ec4 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -8,6 +8,8 @@ import PprCmm import Dataflow (fixedpoint) import CmmLive +import CmmCPSData +import CmmProcPoint import MachOp import ForeignCall @@ -45,25 +47,6 @@ import Data.List -- and heap memory (not sure if that's usefull at all though, but it may -- be worth exploring the design space). -data BrokenBlock - = BrokenBlock { - brokenBlockId :: BlockId, -- Like a CmmBasicBlock - brokenBlockEntry :: BlockEntryInfo, - -- How this block can be entered - - brokenBlockStmts :: [CmmStmt], - -- Like a CmmBasicBlock - -- (but without the last statement) - - brokenBlockTargets :: [BlockId], - -- Blocks that this block could - -- branch to one either by conditional - -- branches or via the last statement - - brokenBlockExit :: FinalStmt - -- How the block can be left - } - continuationLabel (Continuation _ _ l _ _) = l data Continuation = Continuation @@ -80,44 +63,6 @@ data Continuation = -- to a label. To jump to the first block in a Proc, -- use the appropriate CLabel. -data BlockEntryInfo - = FunctionEntry -- Beginning of a function - CLabel -- The function name - CmmFormals -- Aguments to function - - | ContinuationEntry -- Return point of a call - CmmFormals -- return values (argument to continuation) - -- TODO: - -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame - - | ControlEntry -- A label in the input - --- Final statement in a BlokenBlock --- Constructors and arguments match those in Cmm, --- but are restricted to branches, returns, jumps, calls and switches -data FinalStmt - = FinalBranch - BlockId -- next block (must be a ControlEntry) - - | FinalReturn - CmmActuals -- return values - - | FinalJump - CmmExpr -- the function to call - CmmActuals -- arguments to call - - | FinalCall - BlockId -- next block after call (must be a ContinuationEntry) - CmmCallTarget -- the function to call - CmmFormals -- results from call (redundant with ContinuationEntry) - CmmActuals -- arguments to call - (Maybe [GlobalReg]) -- registers that must be saved (TODO) - - | FinalSwitch - CmmExpr [Maybe BlockId] -- Table branch - - -- TODO: | ProcPointExit (needed?) - -- Describes the layout of a stack frame for a continuation data StackFormat = StackFormat @@ -129,75 +74,7 @@ data StackFormat -- A block can be a continuation of another block (w/ or w/o joins) -- A block can be an entry to a function -blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock -blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks - ----------------------------------------------------------------------------- -calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId) -calculateOwnership proc_points blocks = - fixedpoint dependants update (map brokenBlockId blocks) emptyUFM - where - blocks_ufm :: BlockEnv BrokenBlock - blocks_ufm = blocksToBlockEnv blocks - - dependants :: BlockId -> [BlockId] - dependants ident = - brokenBlockTargets $ lookupWithDefaultUFM - blocks_ufm unknown_block ident - - update :: BlockId -> Maybe BlockId - -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId)) - update ident cause owners = - case (cause, ident `elementOfUniqSet` proc_points) of - (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident) - (Nothing, False) -> Nothing - (Just cause', True) -> Nothing - (Just cause', False) -> - if (sizeUniqSet old) == (sizeUniqSet new) - then Nothing - else Just $ addToUFM owners ident new - where - old = lookupWithDefaultUFM owners emptyUniqSet ident - new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause' - - unknown_block = panic "unknown BlockId in selectStackFormat" - -calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId -calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks - where - init_proc_points = mkUniqSet $ - map brokenBlockId $ - filter always_proc_point blocks - always_proc_point BrokenBlock { - brokenBlockEntry = FunctionEntry _ _ } = True - always_proc_point BrokenBlock { - brokenBlockEntry = ContinuationEntry _ } = True - always_proc_point _ = False - -calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId -calculateProcPoints' old_proc_points blocks = - if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points - then old_proc_points - else calculateProcPoints' new_proc_points blocks - where - owners = calculateOwnership old_proc_points blocks - new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks)) - -calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId -calculateProcPoints'' owners block = - unionManyUniqSets (map (f parent_id) child_ids) - where - parent_id = brokenBlockId block - child_ids = brokenBlockTargets block - -- TODO: name for f - f parent_id child_id = - if needs_proc_point - then unitUniqSet child_id - else emptyUniqSet - where - parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id - child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id - needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners collectNonProcPointTargets :: UniqSet BlockId -> BlockEnv BrokenBlock diff --git a/compiler/cmm/CmmCPSData.hs b/compiler/cmm/CmmCPSData.hs new file mode 100644 index 0000000..7ea1d40 --- /dev/null +++ b/compiler/cmm/CmmCPSData.hs @@ -0,0 +1,74 @@ +module CmmCPSData ( + blocksToBlockEnv, + BrokenBlock(..), + BlockEntryInfo(..), + FinalStmt(..) + ) where + +#include "HsVersions.h" + +import Cmm +import CLabel + +import UniqFM + +-- A minor helper (TODO document) +blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock +blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks + +data BrokenBlock + = BrokenBlock { + brokenBlockId :: BlockId, -- Like a CmmBasicBlock + brokenBlockEntry :: BlockEntryInfo, + -- How this block can be entered + + brokenBlockStmts :: [CmmStmt], + -- Like a CmmBasicBlock + -- (but without the last statement) + + brokenBlockTargets :: [BlockId], + -- Blocks that this block could + -- branch to one either by conditional + -- branches or via the last statement + + brokenBlockExit :: FinalStmt + -- How the block can be left + } + +data BlockEntryInfo + = FunctionEntry -- Beginning of a function + CLabel -- The function name + CmmFormals -- Aguments to function + + | ContinuationEntry -- Return point of a call + CmmFormals -- return values (argument to continuation) + -- TODO: + -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame + + | ControlEntry -- A label in the input + +-- Final statement in a BlokenBlock +-- Constructors and arguments match those in Cmm, +-- but are restricted to branches, returns, jumps, calls and switches +data FinalStmt + = FinalBranch + BlockId -- next block (must be a ControlEntry) + + | FinalReturn + CmmActuals -- return values + + | FinalJump + CmmExpr -- the function to call + CmmActuals -- arguments to call + + | FinalCall + BlockId -- next block after call (must be a ContinuationEntry) + CmmCallTarget -- the function to call + CmmFormals -- results from call (redundant with ContinuationEntry) + CmmActuals -- arguments to call + (Maybe [GlobalReg]) -- registers that must be saved (TODO) + + | FinalSwitch + CmmExpr [Maybe BlockId] -- Table branch + + -- TODO: | ProcPointExit (needed?) diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs new file mode 100644 index 0000000..c814862 --- /dev/null +++ b/compiler/cmm/CmmProcPoint.hs @@ -0,0 +1,79 @@ +module CmmProcPoint ( + calculateProcPoints + ) where + +#include "HsVersions.h" + +import Cmm +import CmmCPSData +import Dataflow + +import UniqSet +import UniqFM +import Panic + +calculateOwnership :: BlockEnv BrokenBlock -> UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId) +calculateOwnership blocks_ufm proc_points blocks = + fixedpoint dependants update (map brokenBlockId blocks) emptyUFM + where + dependants :: BlockId -> [BlockId] + dependants ident = + brokenBlockTargets $ lookupWithDefaultUFM + blocks_ufm unknown_block ident + + update :: BlockId -> Maybe BlockId + -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId)) + update ident cause owners = + case (cause, ident `elementOfUniqSet` proc_points) of + (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident) + (Nothing, False) -> Nothing + (Just cause', True) -> Nothing + (Just cause', False) -> + if (sizeUniqSet old) == (sizeUniqSet new) + then Nothing + else Just $ addToUFM owners ident new + where + old = lookupWithDefaultUFM owners emptyUniqSet ident + new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause' + + unknown_block = panic "unknown BlockId in selectStackFormat" + +calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId +calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks + where + init_proc_points = mkUniqSet $ + map brokenBlockId $ + filter always_proc_point blocks + always_proc_point BrokenBlock { + brokenBlockEntry = FunctionEntry _ _ } = True + always_proc_point BrokenBlock { + brokenBlockEntry = ContinuationEntry _ } = True + always_proc_point _ = False + +calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId +calculateProcPoints' old_proc_points blocks = + if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points + then old_proc_points + else calculateProcPoints' new_proc_points blocks + where + blocks_ufm :: BlockEnv BrokenBlock + blocks_ufm = blocksToBlockEnv blocks + + owners = calculateOwnership blocks_ufm old_proc_points blocks + new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks)) + +calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId +calculateProcPoints'' owners block = + unionManyUniqSets (map (f parent_id) child_ids) + where + parent_id = brokenBlockId block + child_ids = brokenBlockTargets block + -- TODO: name for f + f parent_id child_id = + if needs_proc_point + then unitUniqSet child_id + else emptyUniqSet + where + parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id + child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id + needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners -- 1.7.10.4