Commit 8e4dc8fb authored by Joachim Breitner's avatar Joachim Breitner

Greatly speed up nativeCodeGen/seqBlocks

When working on #10397, I noticed that "reorder" in
nativeCodeGen/seqBlocks took more than 60% of the time. With this
refactoring, it does not even show up in the profile any more. This
fixes #10422.

Differential Revision: https://phabricator.haskell.org/D893
parent c2563572
......@@ -63,6 +63,7 @@ import UniqFM
import UniqSupply
import DynFlags
import Util
import Unique
import BasicTypes ( Alignment )
import Digraph
......@@ -779,25 +780,41 @@ mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
-> [GenBasicBlock t1]
seqBlocks _ [] = []
seqBlocks infos ((block,_,[]) : rest)
= block : seqBlocks infos rest
seqBlocks infos ((block@(BasicBlock id instrs),_,[next]) : rest)
| can_fallthrough = BasicBlock id (init instrs) : seqBlocks infos rest'
| otherwise = block : seqBlocks infos rest'
seqBlocks infos blocks = placeNext pullable0 todo0
where
can_fallthrough = not (mapMember next infos) && can_reorder
(can_reorder, rest') = reorder next [] rest
-- TODO: we should do a better job for cycles; try to maximise the
-- fallthroughs within a loop.
seqBlocks _ _ = panic "AsmCodegen:seqBlocks"
reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
reorder _ accum [] = (False, reverse accum)
reorder id accum (b@(block,id',out) : rest)
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
-- pullable: Blocks that are not yet placed
-- todo: Original order of blocks, to be followed if we have no good
-- reason not to;
-- may include blocks that have already been placed, but then
-- these are not in pullable
pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ]
todo0 = [i | (_,i,_) <- blocks ]
placeNext _ [] = []
placeNext pullable (i:rest)
| Just (block, pullable') <- lookupDeleteUFM pullable i
= place pullable' rest block
| otherwise
-- We already placed this block, so ignore
= placeNext pullable rest
place pullable todo (block,[])
= block : placeNext pullable todo
place pullable todo (block@(BasicBlock id instrs),[next])
| mapMember next infos
= block : placeNext pullable todo
| Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
= BasicBlock id (init instrs) : place pullable' todo nextBlock
| otherwise
= block : placeNext pullable todo
place _ _ (_,tooManyNextNodes)
= pprPanic "seqBlocks" (ppr tooManyNextNodes)
lookupDeleteUFM :: Uniquable key => UniqFM elt -> key -> Maybe (elt, UniqFM elt)
lookupDeleteUFM m k = do -- Maybe monad
v <- lookupUFM m k
return (v, delFromUFM m k)
-- -----------------------------------------------------------------------------
-- Generate jump tables
......
......@@ -394,7 +394,7 @@ test('T783',
# 2014-09-03: 223377364 (Windows) better specialisation, raft of core-to-core optimisations
# 2014-12-22: 235002220 (Windows) not sure why
(wordsize(64), 719814352, 10)]),
(wordsize(64), 548288760, 10)]),
# prev: 349263216 (amd64/Linux)
# 07/08/2012: 384479856 (amd64/Linux)
# 29/08/2012: 436927840 (amd64/Linux)
......@@ -413,6 +413,8 @@ test('T783',
# (changed order of cmm block causes analyses to allocate much more,
# but the changed order is slighly better in terms of runtime, and
# this test seems to be an extreme outlier.)
# 2015-05-16: 548288760 (amd64/Linux)
# (improved sequenceBlocks in nativeCodeGen, #10422)
extra_hc_opts('-static')
],
compile,[''])
......
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