diff options
-rw-r--r-- | compiler/GHC/CmmToAsm/Reg/Linear.hs | 62 |
1 files changed, 29 insertions, 33 deletions
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs index fc35db1874..19da3721e0 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -172,18 +172,18 @@ regAlloc config (CmmProc static lbl live sccs) | LiveInfo info entry_ids@(first_id:_) block_live _ <- static = do -- do register allocation on each component. - (final_blocks, stats, stack_use) + !(!final_blocks, !stats, !stack_use) <- linearRegAlloc config entry_ids block_live sccs -- make sure the block that was first in the input list -- stays at the front of the output - let ((first':_), rest') + let !(!(!first':_), !rest') = partition ((== first_id) . blockId) final_blocks let max_spill_slots = maxSpillSlots config extra_stack | stack_use > max_spill_slots - = Just (stack_use - max_spill_slots) + = Just $! stack_use - max_spill_slots | otherwise = Nothing @@ -277,7 +277,7 @@ linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process entry_ids block_live blocks [] (return []) False + blockss' <- process entry_ids block_live blocks linearRA_SCCs entry_ids block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -294,45 +294,41 @@ linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} -process :: OutputableRegConstraint freeRegs instr +process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) => [BlockId] -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] - -> [GenBasicBlock (LiveInstr instr)] - -> [[NatBasicBlock instr]] - -> Bool -> RegM freeRegs [[NatBasicBlock instr]] - -process _ _ [] [] accum _ - = return $ reverse accum - -process entry_ids block_live [] next_round accum madeProgress - | not madeProgress - +process entry_ids block_live = + \blocks -> go blocks [] (return []) False + where + go :: [GenBasicBlock (LiveInstr instr)] + -> [GenBasicBlock (LiveInstr instr)] + -> [[NatBasicBlock instr]] + -> Bool + -> RegM freeRegs [[NatBasicBlock instr]] + go [] [] accum _madeProgress + = return $ reverse accum + + go [] next_round accum madeProgress + | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." ( text "Unreachable blocks:" $$ vcat (map ppr next_round)) -} - = return $ reverse accum - - | otherwise - = process entry_ids block_live - next_round [] accum False + = return $ reverse accum -process entry_ids block_live (b@(BasicBlock id _) : blocks) - next_round accum madeProgress - = do - block_assig <- getBlockAssigR + | otherwise + = go next_round [] accum False - if isJust (mapLookup id block_assig) - || id `elem` entry_ids - then do - b' <- processBlock block_live b - process entry_ids block_live blocks - next_round (b' : accum) True + go (b@(BasicBlock id _) : blocks) next_round accum madeProgress + = do + block_assig <- getBlockAssigR + if isJust (mapLookup id block_assig) || id `elem` entry_ids + then do b' <- processBlock block_live b + go blocks next_round (b' : accum) True - else process entry_ids block_live blocks - (b : next_round) accum madeProgress + else do go blocks (b : next_round) accum madeProgress -- | Do register allocation on this basic block @@ -856,7 +852,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc case freeRegs_thisClass of -- case (2): we have a free register (first_free : _) -> - do let final_reg + do let !final_reg | Just reg <- pref_reg , reg `elem` freeRegs_thisClass = reg |