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
-----------------------------------------------------------------------------
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
[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"
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
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)
--
-- 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
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)
-- 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
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
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
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 =
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"
projects / ghc-hetmet.git / commitdiff