diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-01-07 23:07:17 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-17 19:07:47 -0400 |
commit | fe6cad22353ee027358251cbf91a3811c6e925ff (patch) | |
tree | 119981d6f99fb86a7c0fd9b5f5a7ded848a08dc5 /compiler/GHC/CmmToAsm/Reg/Linear.hs | |
parent | 42049339cd7adfc5b7220ad49cca21efedf6a2ca (diff) | |
download | haskell-fe6cad22353ee027358251cbf91a3811c6e925ff.tar.gz |
CmmtoAsm.Reg.Linear: Rewrite process
CmmToAsm.Reg.Linear: More strictness
More strictness
Diffstat (limited to 'compiler/GHC/CmmToAsm/Reg/Linear.hs')
-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 |