summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorBen.Lippmeier@anu.edu.au <unknown>2009-09-17 09:03:35 +0000
committerBen.Lippmeier@anu.edu.au <unknown>2009-09-17 09:03:35 +0000
commit028c032b60567b8cd501e9d7248e4aa86088a19b (patch)
treebeab9f04257cb5fcb5c28aac1b3921546ff28100 /compiler
parent85981a6fc4bb94af433b0b3655c26c5ec4dda1bd (diff)
downloadhaskell-028c032b60567b8cd501e9d7248e4aa86088a19b.tar.gz
NCG: Add sanity checking to linear allocator
If there are are unreachable basic blocks in the native code then the linear allocator might loop. Detect this case and panic instead.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs24
1 files changed, 17 insertions, 7 deletions
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 229fd32f57..0014eec2d4 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -190,7 +190,7 @@ linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
= do
- blockss' <- process first_id block_live blocks [] (return [])
+ blockss' <- process first_id block_live blocks [] (return []) False
linearRA_SCCs first_id block_live
(reverse (concat blockss') ++ blocksAcc)
sccs
@@ -207,13 +207,21 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
more sanity checking to guard against this eventuality.
-}
-process _ _ [] [] accum
+process _ _ [] [] accum _
= return $ reverse accum
-process first_id block_live [] next_round accum
- = process first_id block_live next_round [] accum
+process first_id block_live [] next_round accum madeProgress
+ | not madeProgress
+ = pprPanic "RegAlloc.Linear.Main.process: no progress made, bailing out"
+ ( text "stalled blocks:"
+ $$ vcat (map ppr next_round))
+
+ | otherwise
+ = process first_id block_live
+ next_round [] accum False
-process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum
+process first_id block_live (b@(BasicBlock id _) : blocks)
+ next_round accum madeProgress
= do
block_assig <- getBlockAssigR
@@ -221,9 +229,11 @@ process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum
|| id == first_id
then do
b' <- processBlock block_live b
- process first_id block_live blocks next_round (b' : accum)
+ process first_id block_live blocks
+ next_round (b' : accum) True
- else process first_id block_live blocks (b : next_round) accum
+ else process first_id block_live blocks
+ (b : next_round) accum madeProgress
-- | Do register allocation on this basic block