Commit 269b440b authored by Simon Marlow's avatar Simon Marlow

Remove dead code and optimise a bit

parent 7bbab6f4
......@@ -199,183 +199,6 @@ extendPPSet platform g blocks procPoints =
Nothing -> return procPoints'
------------------------------------------------------------------------
-- Computing Proc-Point Protocols --
------------------------------------------------------------------------
{-
There is one major trick, discovered by Michael Adams, which is that
we want to choose protocols in a way that enables us to optimize away
some continuations. The optimization is very much like branch-chain
elimination, except that it involves passing results as well as
control. The idea is that if a call's continuation k does nothing but
CopyIn its results and then goto proc point P, the call's continuation
may be changed to P, *provided* P's protocol is identical to the
protocol for the CopyIn. We choose protocols to make this so.
Here's an explanatory example; we begin with the source code (lines
separate basic blocks):
..1..;
x, y = g();
goto P;
-------
P: ..2..;
Zipperization converts this code as follows:
..1..;
call g() returns to k;
-------
k: CopyIn(x, y);
goto P;
-------
P: ..2..;
What we'd like to do is assign P the same CopyIn protocol as k, so we
can eliminate k:
..1..;
call g() returns to P;
-------
P: CopyIn(x, y); ..2..;
Of course, P may be the target of more than one continuation, and
different continuations may have different protocols. Michael Adams
implemented a voting mechanism, but he thinks a simple greedy
algorithm would be just as good, so that's what we do.
-}
{-
data Protocol = Protocol Convention [CmmFormal] Area
deriving Eq
instance Outputable Protocol where
ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
-- | Function 'optimize_calls' chooses protocols only for those proc
-- points that are relevant to the optimization explained above.
-- The others are assigned by 'add_unassigned', which is not yet clever.
addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelUniqSM CmmGraph
addProcPointProtocols callPPs procPoints g =
do liveness <- cmmLiveness g
(protos, g') <- optimize_calls liveness g
blocks'' <- add_CopyOuts protos procPoints g'
return $ ofBlockMap (g_entry g) blocks''
where optimize_calls liveness g = -- see Note [Separate Adams optimization]
do let (protos, blocks') =
foldGraphBlocks maybe_add_call (mapEmpty, mapEmpty) g
protos' = add_unassigned liveness procPoints protos
let g' = ofBlockMap (g_entry g) (add_CopyIns callPPs protos' blocks')
return (protos', removeUnreachableBlocks g')
maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
-> (BlockEnv Protocol, BlockEnv CmmBlock)
-- ^ If the block is a call whose continuation goes to a proc point
-- whose protocol either matches the continuation's or is not yet set,
-- redirect the call (cf 'newblock') and set the protocol if necessary
maybe_add_call block (protos, blocks) =
case lastNode block of
CmmCall tgt (Just k) args res s
| Just proto <- mapLookup k protos,
Just pee <- branchesToProcPoint k
-> let newblock = replaceLastNode block (CmmCall tgt (Just pee)
args res s)
changed_blocks = insertBlock newblock blocks
unchanged_blocks = insertBlock block blocks
in case mapLookup pee protos of
Nothing -> (mapInsert pee proto protos, changed_blocks)
Just proto' ->
if proto == proto' then (protos, changed_blocks)
else (protos, unchanged_blocks)
_ -> (protos, insertBlock block blocks)
branchesToProcPoint :: BlockId -> Maybe BlockId
-- ^ Tells whether the named block is just a branch to a proc point
branchesToProcPoint id =
let block = mapLookup id (toBlockMap g) `orElse`
panic "branch out of graph"
in case blockToNodeList block of
(_, [], JustC (CmmBranch pee)) | setMember pee procPoints -> Just pee
_ -> Nothing
-- | For now, following a suggestion by Ben Lippmeier, we pass all
-- live variables as arguments, hoping that a clever register
-- allocator might help.
add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol ->
BlockEnv Protocol
add_unassigned = pass_live_vars_as_args
pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
BlockEnv Protocol -> BlockEnv Protocol
pass_live_vars_as_args _liveness procPoints protos = protos'
where protos' = setFold addLiveVars protos procPoints
addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
addLiveVars id protos =
case mapLookup id protos of
Just _ -> protos
Nothing -> let live = emptyRegSet
--lookupBlockEnv _liveness id `orElse`
--panic ("no liveness at block " ++ show id)
formals = regSetToList live
prot = Protocol Private formals $ CallArea $ Young id
in mapInsert id prot protos
-- | Add copy-in instructions to each proc point that did not arise from a call
-- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks
where maybe_insert_CopyIns block blocks
| not $ setMember bid callPPs
, Just (Protocol c fs _area) <- mapLookup bid protos
= let nodes = copyInSlot c fs
(h, b) = blockSplitHead block
block' = blockJoinHead h (blockFromList nodes `blockAppend` b)
in insertBlock block' blocks
| otherwise = insertBlock block blocks
where bid = entryLabel block
-- | Add a CopyOut node before each procpoint.
-- If the predecessor is a call, then the copy outs should already be done by the callee.
-- Note: If we need to add copy-out instructions, they may require stack space,
-- so we accumulate a map from the successors to the necessary stack space,
-- then update the successors after we have finished inserting the copy-outs.
add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
FuelUniqSM (BlockEnv CmmBlock)
add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) g
where mb_copy_out :: CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) ->
FuelUniqSM (BlockEnv CmmBlock)
mb_copy_out b z | entryLabel b == g_entry g = skip b z
mb_copy_out b z =
case lastNode b of
CmmCall {} -> skip b z -- copy out done by callee
CmmForeignCall {} -> skip b z -- copy out done by callee
_ -> copy_out b z
copy_out b z = foldr trySucc init (successors b) >>= finish
where init = (\bmap -> (b, bmap)) `liftM` z
trySucc succId z =
if setMember succId procPoints then
case mapLookup succId protos of
Nothing -> z
Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
else z
insert z succId m =
do (b, bmap) <- z
(b, bs) <- insertBetween b m succId
-- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
return $ (b, foldl (flip insertBlock) bmap bs)
finish (b, bmap) = return $ insertBlock b bmap
skip b bs = insertBlock b `liftM` bs
-}
-- At this point, we have found a set of procpoints, each of which should be
-- the entry point of a procedure.
-- Now, we create the procedure for each proc point,
......@@ -410,9 +233,11 @@ splitAtProcPoints entry_label callPPs procPoints procMap
graph' = mapInsert bid b graph
graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g
-- Build a map from proc point BlockId to pairs of:
-- * Labels for their new procedures
-- * Labels for the info tables of their new procedures (only if the proc point is a callPP)
-- * 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
where lbls | pp == entry = (entry_label, Just entry_info_lbl)
......@@ -421,30 +246,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap
entry_info_lbl = cit_lbl info_tbl
procLabels = foldl add_label Map.empty
(filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-- For each procpoint, we need to know the SP offset on entry.
-- If the procpoint is:
-- - continuation of a call, the SP offset is in the call
-- - otherwise, 0 (and left out of the spEntryMap)
let add_sp_off :: CmmBlock -> BlockEnv CmmStackInfo -> BlockEnv CmmStackInfo
add_sp_off b env =
case lastNode b of
CmmCall {cml_cont = Just succ, cml_ret_args = off, cml_ret_off = updfr_off} ->
mapInsert succ (StackInfo { arg_space = off, updfr_space = Just updfr_off}) env
CmmForeignCall {succ = succ, updfr = updfr_off} ->
mapInsert succ (StackInfo { arg_space = wORD_SIZE, updfr_space = Just updfr_off}) env
_ -> env
spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry stack_info emptyBlockMap) g
getStackInfo id = mapLookup id spEntryMap `orElse` StackInfo {arg_space = 0, updfr_space = Nothing}
-- 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) =
do bid <- liftM mkBlockId getUniqueM
let b = blockOfNodeList (JustC (CmmEntry bid), [], JustC jump)
StackInfo {arg_space = argSpace, updfr_space = off} = getStackInfo pp
jump = CmmCall (CmmLit (CmmLabel l)) Nothing argSpace 0
(off `orElse` 0) -- Jump's shouldn't need the offset...
let b = blockJoin (CmmEntry bid) emptyBlock jump
jump = CmmCall (CmmLit (CmmLabel l)) Nothing 0 0 0
return (mapInsert pp bid env, b : bs)
add_jumps (newGraphEnv) (ppId, blockEnv) =
add_jumps newGraphEnv (ppId, blockEnv) =
do let needed_jumps = -- find which procpoints we currently branch to
mapFold add_if_branch_to_pp [] blockEnv
add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
......@@ -461,17 +271,16 @@ splitAtProcPoints entry_label callPPs procPoints procMap
foldM add_jump_block (mapEmpty, []) needed_jumps
-- update the entry block
let b = expectJust "block in env" $ mapLookup ppId blockEnv
off = getStackInfo ppId
blockEnv' = mapInsert ppId b blockEnv
-- replace branches to procpoints with branches to jumps
blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
-- add the jump blocks to the graph
blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
let g' = (off, ofBlockMap ppId blockEnv''')
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, (stack_info, g)) = case expectJust "pp label" $ Map.lookup bid procLabels of
let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
(lbl, Just info_lbl)
| bid == entry
-> CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
......@@ -482,15 +291,22 @@ splitAtProcPoints entry_label callPPs procPoints procMap
(lbl, Nothing)
-> CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info})
lbl (replacePPIds g)
-- References to procpoint IDs can now be replaced with the infotable's label
replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g
where
stack_info = panic "No StackInfo"
-- References to procpoint IDs can now be replaced with the
-- infotable's label
replacePPIds g = {-# SCC "replacePPIds" #-}
mapGraphNodes (id, mapExp repl, mapExp repl) g
where repl e@(CmmLit (CmmBlock bid)) =
case Map.lookup bid procLabels of
Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
_ -> e
repl e = e
-- The C back end expects to see return continuations before the call sites.
-- Here, we sort them in reverse order -- it gets reversed later.
-- The C back end expects to see return continuations before the
-- call sites. Here, we sort them in reverse order -- it gets
-- reversed later.
let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g)
add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
sort_fn (bid, _) (bid', _) =
......@@ -506,8 +322,12 @@ splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below.
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceBranches env g = mapGraphNodes (id, id, last) g
replaceBranches env cmmg
= {-# SCC "replaceBranches" #-}
ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
where
f block = replaceLastNode block $ last (lastNode block)
last :: CmmNode O C -> CmmNode O C
last (CmmBranch id) = CmmBranch (lookup id)
last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
......
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