+{-# OPTIONS -fno-warn-missing-signatures #-}
-----------------------------------------------------------------------------
--
-- The register allocator
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-missing-signatures #-}
{-
The algorithm is roughly:
#include "HsVersions.h"
+import BlockId
import MachRegs
import MachInstrs
import RegAllocInfo
import UniqSupply
import Outputable
import State
+import FastString
import Data.Maybe
import Data.List
getFreeRegs cls (FreeRegs g f)
| RcDouble <- cls = go f (0x80000000) 63
| RcInteger <- cls = go g (0x80000000) 31
+ | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad cls" (ppr cls)
where
- go x 0 i = []
+ go _ 0 _ = []
go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
| otherwise = go x (m `shiftR` 1) $! i-1
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
getStackSlotFor (StackMap [] _) _
- = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
+ = panic "RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph"
+ -- This happens with darcs' SHA1.hs, see #1993
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
case lookupUFM reserved reg of
, Nothing )
regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
- = return
- ( CmmProc info lbl params (ListGraph [])
- , Nothing )
+ = return ( CmmProc info lbl params (ListGraph [])
+ , Nothing )
regAlloc (CmmProc static lbl params (ListGraph comps))
| LiveInfo info (Just first_id) block_live <- static
= do
-- do register allocation on each component.
(final_blocks, stats)
- <- linearRegAlloc block_live
+ <- linearRegAlloc first_id block_live
$ map (\b -> case b of
BasicBlock _ [b] -> AcyclicSCC b
BasicBlock _ bs -> CyclicSCC bs)
-- | Do register allocation on some basic blocks.
+-- But be careful to allocate a block in an SCC only if it has
+-- an entry in the block map or it is the first block.
--
linearRegAlloc
- :: BlockMap RegSet -- ^ live regs on entry to each basic block
+ :: BlockId -- ^ the first block
+ -> BlockMap RegSet -- ^ live regs on entry to each basic block
-> [SCC LiveBasicBlock] -- ^ instructions annotated with "deaths"
-> UniqSM ([NatBasicBlock], RegAllocStats)
-linearRegAlloc block_live sccs
+linearRegAlloc first_id block_live sccs
= do us <- getUs
let (_, _, stats, blocks) =
runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
- $ linearRA_SCCs block_live [] sccs
+ $ linearRA_SCCs first_id block_live [] sccs
return (blocks, stats)
-linearRA_SCCs _ blocksAcc []
+linearRA_SCCs _ _ blocksAcc []
= return $ reverse blocksAcc
-linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs)
+linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
= do blocks' <- processBlock block_live block
- linearRA_SCCs block_live
+ linearRA_SCCs first_id block_live
((reverse blocks') ++ blocksAcc)
sccs
-linearRA_SCCs block_live blocksAcc (CyclicSCC blocks : sccs)
- = do blockss' <- mapM (processBlock block_live) blocks
- linearRA_SCCs block_live
+linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
+ = do let process [] [] accum = return $ reverse accum
+ process [] next_round accum = process next_round [] accum
+ process (b@(BasicBlock id _) : blocks) next_round accum =
+ do block_assig <- getBlockAssigR
+ if isJust (lookupBlockEnv block_assig id) || id == first_id
+ then do b' <- processBlock block_live b
+ process blocks next_round (b' : accum)
+ else process blocks (b : next_round) accum
+ blockss' <- process blocks [] (return [])
+ linearRA_SCCs first_id block_live
(reverse (concat blockss') ++ blocksAcc)
sccs
initBlock :: BlockId -> RegM ()
initBlock id
= do block_assig <- getBlockAssigR
- case lookupUFM block_assig id of
+ case lookupBlockEnv block_assig id of
-- no prior info about this block: assume everything is
-- free and the assignment is empty.
Nothing
setAssigR (addToUFM (delFromUFM assig src) dst loc)
-- we have elimianted this instruction
- {-
freeregs <- getFreeRegsR
assig <- getAssigR
- pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
- -}
+ {-
+ pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
+ -}
return (new_instrs, [])
_ -> genRaInsn block_live new_instrs instr
recordSpill (SpillClobber temp)
let new_assign = addToUFM assig temp (InBoth reg slot)
- clobber new_assign (spill : COMMENT FSLIT("spill clobber") : instrs) rest
+ clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest
clobberRegs :: [RegNo] -> RegM ()
clobberRegs [] = return () -- common case
(spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
let spill_store = (if reading then id else reverse)
- [ COMMENT FSLIT("spill alloc")
+ [ COMMENT (fsLit "spill alloc")
, spill_insn ]
-- record that this temp was spilled
= do
insn <- loadR (RealReg hreg) slot
recordSpill (SpillLoad $ getUnique vreg)
- return $ COMMENT FSLIT("spill load") : insn : spills
+ return $ COMMENT (fsLit "spill load") : insn : spills
loadTemp _ _ _ _ spills =
return spills
regsOfLoc (InBoth r _) = [r]
regsOfLoc (InMem _) = []
-- in
- case lookupUFM block_assig dest of
+ case lookupBlockEnv block_assig dest of
-- Nothing <=> this is the first time we jumped to this
-- block.
Nothing -> do
freeregs <- getFreeRegsR
let freeregs' = foldr releaseReg freeregs to_free
- setBlockAssigR (addToUFM block_assig dest
+ setBlockAssigR (extendBlockEnv block_assig dest
(freeregs',adjusted_assig))
joinToTargets block_live new_blocks instr dests
delta <- getDeltaR
let graph = makeRegMovementGraph adjusted_assig dest_assig
- let sccs = stronglyConnCompR graph
+ let sccs = stronglyConnCompFromEdgedVerticesR graph
fixUpInstrs <- mapM (handleComponent delta instr) sccs
block_id <- getUniqueR
joinToTargets block_live (block : new_blocks) instr' dests
--- | Construct a graph of register/spill movements.
+-- | Construct a graph of register\/spill movements.
--
-- We cut some corners by
-- a) not handling cyclic components
= expandNode vreg src
$ lookupWithDefaultUFM_Directly
dest_assig
- (panic "RegisterAlloc.joinToTargets")
+ (panic "RegAllocLinear.makeRegMovementGraph")
vreg
in [ node | (vreg, src) <- ufmToList adjusted_assig
= do
spill_id <- getUniqueR
(_, slot) <- spillR (RealReg sreg) spill_id
- remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest)
+ remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
restoreAndFixInstr <- getRestoreMoves dsts slot
return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
= do
restoreToReg <- loadR (RealReg reg) slot
moveInstr <- makeMove delta vreg r mem
- return $ [COMMENT FSLIT("spill join move"), restoreToReg, moveInstr]
+ return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
getRestoreMoves [InReg reg] slot
= loadR (RealReg reg) slot >>= return . (:[])
-- -----------------------------------------------------------------------------
-- Utils
-#ifdef DEBUG
-my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
+my_fromJust :: String -> SDoc -> Maybe a -> a
my_fromJust _ _ (Just x) = x
-#else
-my_fromJust _ _ = fromJust
-#endif
+my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
-lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
-lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)
+lookItUp :: String -> BlockMap a -> BlockId -> a
+lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)
projects / ghc-hetmet.git / blobdiff