Commit 81285ec4 authored by Michael D. Adams's avatar Michael D. Adams

Comment and formatting updates for the CPS pass

parent 61c73ae3
......@@ -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)
......
......@@ -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"
......
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
......
......@@ -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"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment