From 81285ec475e94ef93d2ac59386d48cb333da2c96 Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Thu, 28 Jun 2007 08:25:43 +0000 Subject: [PATCH] Comment and formatting updates for the CPS pass --- compiler/cmm/CmmBrokenBlock.hs | 15 ++++++ compiler/cmm/CmmCPS.hs | 8 ++-- compiler/cmm/CmmCallConv.hs | 31 ++++++++----- compiler/cmm/CmmProcPoint.hs | 100 +++++++++++++++++++++++++++------------- 4 files changed, 108 insertions(+), 46 deletions(-) diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs index a968484..af47e8d 100644 --- a/compiler/cmm/CmmBrokenBlock.hs +++ b/compiler/cmm/CmmBrokenBlock.hs @@ -19,6 +19,11 @@ import Panic import Unique import UniqFM +-- This module takes a 'CmmBasicBlock' which might have 'CmmCall' +-- statements in it with 'CmmSafe' set and breaks it up at each such call. +-- It also collects information about the block for later use +-- by the CPS algorithm. + ----------------------------------------------------------------------------- -- Data structures ----------------------------------------------------------------------------- @@ -110,6 +115,8 @@ breakBlock uniques (BasicBlock ident stmts) entry = breakBlock' uniques current_id entry exits accum_stmts stmts = case stmts of [] -> panic "block doesn't end in jump, goto, return or switch" + + -- Last statement. Make the 'BrokenBlock' [CmmJump target arguments] -> [BrokenBlock current_id entry accum_stmts exits @@ -126,6 +133,9 @@ breakBlock uniques (BasicBlock ident stmts) entry = [BrokenBlock current_id entry accum_stmts (mapMaybe id targets ++ exits) (FinalSwitch expr targets)] + + -- These shouldn't happen in the middle of a block. + -- They would cause dead code. (CmmJump _ _:_) -> panic "jump in middle of block" (CmmReturn _:_) -> panic "return in middle of block" (CmmBranch _:_) -> panic "branch in middle of block" @@ -140,6 +150,8 @@ breakBlock uniques (BasicBlock ident stmts) entry = block = do_call current_id entry accum_stmts exits next_id target results arguments -} + + -- Break the block on safe calls (the main job of this function) (CmmCall target results arguments (CmmSafe srt):stmts) -> block : rest where @@ -149,6 +161,9 @@ breakBlock uniques (BasicBlock ident stmts) entry = rest = breakBlock' (tail uniques) next_id (ContinuationEntry (map fst results) srt) [] [] stmts + + -- Default case. Just keep accumulating statements + -- and branch targets. (s:stmts) -> breakBlock' uniques current_id entry (cond_branch_target s++exits) diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index b6c57ee..4c606ee 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -157,7 +157,9 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs -- -- This is an association list instead of a UniqFM because -- CLabel's don't have a 'Uniqueable' instance. - formats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))] + formats :: [(CLabel, -- key + (Maybe CLabel, -- label in top slot + [Maybe LocalReg]))] -- slots formats = selectStackFormat live continuations -- Do a little meta-processing on the stack formats such as @@ -203,7 +205,7 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs continuationLabel (Continuation _ l _ _) = l data Continuation info = Continuation - info --(Either C_SRT CmmInfo) -- Left <=> Continuation created by the CPS + info -- Left <=> Continuation created by the CPS -- Right <=> Function or Proc point CLabel -- Used to generate both info & entry labels CmmFormals -- Argument locals live on entry (C-- procedure params) @@ -361,7 +363,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) = -- TODO prof: this is the same as the current implementation -- but I think it could be improved prof = ProfilingInfo zeroCLit zeroCLit - tag = rET_SMALL -- cmmToRawCmm will convert this to rET_BIG if needed + tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG format = maybe unknown_block id $ lookup label formats unknown_block = panic "unknown BlockId in applyStackFormat" diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index ee16fe9..86a27b5 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -1,7 +1,6 @@ module CmmCallConv ( ParamLocation(..), ArgumentFormat, - assignRegs, assignArguments, ) where @@ -15,26 +14,35 @@ import Constants import StaticFlags (opt_Unregisterised) import Panic +-- Calculate the 'GlobalReg' or stack locations for function call +-- parameters as used by the Cmm calling convention. + data ParamLocation = RegisterParam GlobalReg | StackParam WordOff -assignRegs :: [LocalReg] -> ArgumentFormat LocalReg -assignRegs regs = assignRegs' regs 0 availRegs - where - assignRegs' (r:rs) offset availRegs = (r,assignment):assignRegs' rs new_offset remaining - where - (assignment, new_offset, remaining) = assign_reg (localRegRep r) offset availRegs +type ArgumentFormat a = [(a, ParamLocation)] assignArguments :: (a -> MachRep) -> [a] -> ArgumentFormat a assignArguments f reps = assignArguments' reps 0 availRegs where assignArguments' [] offset availRegs = [] - assignArguments' (r:rs) offset availRegs = (r,assignment):assignArguments' rs new_offset remaining + assignArguments' (r:rs) offset availRegs = + (r,assignment):assignArguments' rs new_offset remaining where - (assignment, new_offset, remaining) = assign_reg (f r) offset availRegs + (assignment, new_offset, remaining) = + assign_reg (f r) offset availRegs -type ArgumentFormat a = [(a, ParamLocation)] +argumentsSize :: (a -> MachRep) -> [a] -> WordOff +argumentsSize f reps = maximum (0 : map arg_top args) + where + args = assignArguments f reps + + arg_top (a, StackParam offset) = -offset + arg_top (_, RegisterParam _) = 0 + +----------------------------------------------------------------------------- +-- Local information about the registers available type AvailRegs = ( [GlobalReg] -- available vanilla regs. , [GlobalReg] -- floats @@ -65,7 +73,8 @@ availRegs = (regList VanillaReg useVanillaRegs, regList f max = map f [1 .. max] slot_size :: LocalReg -> Int -slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1 +slot_size reg = + ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1 slot_size' :: MachRep -> Int slot_size' reg = ((machRepByteWidth reg - 1) `div` wORD_SIZE) + 1 diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 15a723a..5a159a6 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -12,31 +12,29 @@ 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" +-- Determine the proc points for a set of basic blocks. +-- +-- A proc point is any basic block that must start a new function. +-- The entry block of the original function is a proc point. +-- The continuation of a function call is also a proc point. +-- The third kind of proc point arises when there is a joint point +-- in the control flow. Suppose we have code like the following: +-- +-- if (...) { ...; call foo(); ...} +-- else { ...; call bar(); ...} +-- x = y; +-- +-- That last statement "x = y" must be a proc point because +-- it can be reached by blocks owned by different proc points +-- (the two branches of the conditional). +-- +-- We calculate these proc points by starting with the minimal set +-- and finding blocks that are reachable from more proc points than +-- one of their parents. (This ensures we don't choose a block +-- simply beause it is reachable from another block that is reachable +-- from multiple proc points.) These new blocks are added to the +-- set of proc points and the process is repeated until there +-- are no more proc points to be found. calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId calculateProcPoints blocks = @@ -61,20 +59,58 @@ calculateProcPoints' old_proc_points blocks = blocks_ufm = blocksToBlockEnv blocks owners = calculateOwnership blocks_ufm old_proc_points blocks - new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks)) + new_proc_points = + unionManyUniqSets + (old_proc_points: + map (calculateNewProcPoints owners) blocks) -calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId -calculateProcPoints'' owners block = - unionManyUniqSets (map (f parent_id) child_ids) +calculateNewProcPoints :: BlockEnv (UniqSet BlockId) + -> BrokenBlock + -> UniqSet BlockId +calculateNewProcPoints owners block = + unionManyUniqSets (map (maybe_proc_point parent_id) child_ids) where parent_id = brokenBlockId block child_ids = brokenBlockTargets block - -- TODO: name for f - f parent_id child_id = + maybe_proc_point 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 + needs_proc_point = not $ isEmptyUniqSet $ + child_owners `minusUniqSet` parent_owners + +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" -- 1.7.10.4