From a915d9b47e3ff1bb3491f4d57f7c6cd6781fcd2a Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 1 Aug 2012 10:45:14 +0100 Subject: Inline into the last node Also lots of refactoring and tidyup --- compiler/cmm/CmmSink.hs | 192 +++++++++++++++++++++++++++++++++--------------- 1 file changed, 132 insertions(+), 60 deletions(-) (limited to 'compiler/cmm') diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 7cdc1f6ac3..f314805852 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -64,28 +64,21 @@ type Assignment = (LocalReg, CmmExpr, AbsAddr) cmmSink :: CmmGraph -> CmmGraph cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks where - liveness = cmmLiveness graph getLive l = mapFindWithDefault Set.empty l liveness blocks = postorderDfs graph - all_succs = concatMap successors blocks - succ_counts :: BlockEnv Int - succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs - join_pts = mapFilter (>1) succ_counts - + join_pts = findJoinPoints blocks sink :: BlockEnv [Assignment] -> [CmmBlock] -> [CmmBlock] sink _ [] = [] sink sunk (b:bs) = -- pprTrace "sink" (ppr lbl) $ - blockJoin first final_middle last : sink sunk' bs + blockJoin first final_middle final_last : sink sunk' bs where lbl = entryLabel b (first, middle, last) = blockSplit b - (middle', assigs) = walk ann_middles emptyBlock - (mapFindWithDefault [] lbl sunk) succs = successors last @@ -96,6 +89,10 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks live_middle = gen_kill last live ann_middles = annotate live_middle (blockToList middle) + -- Now sink and inline in this block + (middle', assigs) = walk ann_middles (mapFindWithDefault [] lbl sunk) + (final_last, assigs') = tryToInline live last assigs + -- We cannot sink into join points (successors with more than -- one predecessor), so identify the join points and the set -- of registers live in them. @@ -114,11 +111,11 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks _ -> False -- Now, drop any assignments that we will not sink any further. - (dropped_last, assigs') = dropAssignments drop_if init_live_sets assigs + (dropped_last, assigs'') = dropAssignments drop_if init_live_sets assigs' drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') where - should_drop = a `conflicts` last + should_drop = a `conflicts` final_last || {- not (isTiny rhs) && -} live_in_multi live_sets r || r `Set.member` live_in_joins @@ -133,7 +130,7 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks final_middle = foldl blockSnoc middle' dropped_last sunk' = mapUnion sunk $ - mapFromList [ (l, filterAssignments (getLive l) assigs') + mapFromList [ (l, filterAssignments (getLive l) assigs'') | l <- succs ] {- @@ -144,66 +141,85 @@ isTiny (CmmLit _) = True isTiny _other = False -} +-- -- annotate each node with the set of registers live *after* the node +-- annotate :: RegSet -> [CmmNode O O] -> [(RegSet, CmmNode O O)] -annotate live nodes = snd $ foldr (\n (live,nodes) -> (gen_kill n live, (live,n) : nodes)) (live,[]) nodes +annotate live nodes = snd $ foldr ann (live,[]) nodes + where ann n (live,nodes) = (gen_kill n live, (live,n) : nodes) + +-- +-- Find the blocks that have multiple successors (join points) +-- +findJoinPoints :: [CmmBlock] -> BlockEnv Int +findJoinPoints blocks = mapFilter (>1) succ_counts + where + all_succs = concatMap successors blocks + + succ_counts :: BlockEnv Int + succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs +-- +-- filter the list of assignments to remove any assignments that +-- are not live in a continuation. +-- filterAssignments :: RegSet -> [Assignment] -> [Assignment] filterAssignments live assigs = reverse (go assigs []) - where go [] kept = kept + where go [] kept = kept go (a@(r,_,_):as) kept | needed = go as (a:kept) | otherwise = go as kept where - needed = r `Set.member` live || any (a `conflicts`) (map toNode kept) - - -walk :: [(RegSet, CmmNode O O)] -> Block CmmNode O O -> [Assignment] - -> (Block CmmNode O O, [Assignment]) + needed = r `Set.member` live + || any (a `conflicts`) (map toNode kept) + -- Note that we must keep assignments that are + -- referred to by other assignments we have + -- already kept. -walk [] block as = (block, as) -walk ((live,node):ns) block as - | Just a <- shouldSink node1 = walk ns block (a : as1) - | otherwise = walk ns block' as' - where - (node1, as1) = tryToInline live usages node as - where usages :: UniqFM Int - usages = foldRegsUsed addUsage emptyUFM node - - (dropped, as') = dropAssignmentsSimple (`conflicts` node1) as1 - block' = foldl blockSnoc block dropped `blockSnoc` node1 - -tryToInline :: RegSet -> UniqFM Int -> CmmNode O x -> [Assignment] - -> (CmmNode O x, [Assignment]) -tryToInline _live _usages node [] - = (node, []) -tryToInline live usages node (a@(l,rhs,_) : rest) - | occurs_once_in_this_node = inline_and_discard - | False {- isTiny rhs -} = inline_and_keep - -- ^^ seems to make things slightly worse - where - inline_and_discard = tryToInline live' usages' node' rest - - inline_and_keep = (node'', a : rest') - where (node'',rest') = inline_and_discard +-- ----------------------------------------------------------------------------- +-- Walk through the nodes of a block, sinking and inlining assignments +-- as we go. - occurs_once_in_this_node = - not (l `elemRegSet` live) && lookupUFM usages l == Just 1 +walk :: [(RegSet, CmmNode O O)] -- nodes of the block, annotated with + -- the set of registers live *after* + -- this node. - live' = foldRegsUsed extendRegSet live rhs - usages' = foldRegsUsed addUsage usages rhs + -> [Assignment] -- The current list of + -- assignments we are sinking. + -- Later assignments may refer + -- to earlier ones. - node' = mapExpDeep inline node - where inline (CmmReg (CmmLocal l')) | l == l' = rhs - inline (CmmRegOff (CmmLocal l') off) | l == l' = cmmOffset rhs off - inline other = other -tryToInline live usages node (assig@(_,rhs,_) : rest) - = (node', assig : rest') - where (node', rest') = tryToInline live usages' node rest - usages' = foldRegsUsed addUsage usages rhs + -> ( Block CmmNode O O -- The new block + , [Assignment] -- Assignments to sink further + ) -addUsage :: UniqFM Int -> LocalReg -> UniqFM Int -addUsage m r = addToUFM_C (+) m r 1 +walk nodes assigs = go nodes emptyBlock assigs + where + go [] block as = (block, as) + go ((live,node):ns) block as + | discard = go ns block as + | Just a <- shouldSink node1 = go ns block (a : as1) + | otherwise = go ns block' as' + where + -- discard dead assignments. This doesn't do as good a job as + -- removeDeadAsssignments, because it would need multiple passes + -- to get all the dead code, but it catches the common case of + -- superfluous reloads from the stack that the stack allocator + -- leaves behind. + discard = case node of + CmmAssign (CmmLocal r) _ -> not (r `Set.member` live) + _otherwise -> False + + (node1, as1) = tryToInline live node as + + (dropped, as') = dropAssignmentsSimple (`conflicts` node1) as1 + block' = foldl blockSnoc block dropped `blockSnoc` node1 +-- +-- Heuristic to decide whether to pick up and sink an assignment +-- Currently we pick up all assignments to local registers. It might +-- be profitable to sink assignments to global regs too, but the +-- liveness analysis doesn't track those (yet) so we can't. +-- shouldSink :: CmmNode e x -> Maybe Assignment shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprAddr e) where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e @@ -212,10 +228,12 @@ shouldSink _other = Nothing toNode :: Assignment -> CmmNode O O toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs -dropAssignmentsSimple :: (Assignment -> Bool) -> [Assignment] -> ([CmmNode O O], [Assignment]) +dropAssignmentsSimple :: (Assignment -> Bool) -> [Assignment] + -> ([CmmNode O O], [Assignment]) dropAssignmentsSimple f = dropAssignments (\a _ -> (f a, ())) () -dropAssignments :: (Assignment -> s -> (Bool, s)) -> s -> [Assignment] -> ([CmmNode O O], [Assignment]) +dropAssignments :: (Assignment -> s -> (Bool, s)) -> s -> [Assignment] + -> ([CmmNode O O], [Assignment]) dropAssignments should_drop state assigs = (dropped, reverse kept) where @@ -229,6 +247,60 @@ dropAssignments should_drop state assigs (dropit, state') = should_drop assig state conflict = dropit || any (assig `conflicts`) dropped + +-- ----------------------------------------------------------------------------- +-- Try to inline assignments into a node. + +tryToInline + :: RegSet -- set of registers live after this + -- node. We cannot inline anything + -- that is live after the node, unless + -- it is small enough to duplicate. + -> CmmNode O x -- The node to inline into + -> [Assignment] -- Assignments to inline + -> ( + CmmNode O x -- New node + , [Assignment] -- Remaining assignments + ) + +tryToInline live node assigs = go live usages node assigs + where + usages :: UniqFM Int + usages = foldRegsUsed addUsage emptyUFM node + + go _live _usages node [] = (node, []) + + go live usages node (a@(l,rhs,_) : rest) + | occurs_once_in_this_node = inline_and_discard + | False {- isTiny rhs -} = inline_and_keep + -- ^^ seems to make things slightly worse + where + inline_and_discard = go live' usages' node' rest + + inline_and_keep = (node'', a : rest') + where (node'',rest') = inline_and_discard + + occurs_once_in_this_node = + not (l `elemRegSet` live) && lookupUFM usages l == Just 1 + + live' = foldRegsUsed extendRegSet live rhs + usages' = foldRegsUsed addUsage usages rhs + + node' = mapExpDeep inline node + where inline (CmmReg (CmmLocal l')) | l == l' = rhs + inline (CmmRegOff (CmmLocal l') off) | l == l' + = cmmOffset rhs off + inline other = other + + go live usages node (assig@(_,rhs,_) : rest) + = (node', assig : rest') + where (node', rest') = go live usages' node rest + usages' = foldRegsUsed addUsage usages rhs + +addUsage :: UniqFM Int -> LocalReg -> UniqFM Int +addUsage m r = addToUFM_C (+) m r 1 + + -- ----------------------------------------------------------------------------- -- | @conflicts (r,e) stmt@ is @False@ if and only if the assignment -- cgit v1.2.1