-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
--- for details
-
+{-# OPTIONS -fno-warn-missing-signatures #-}
-----------------------------------------------------------------------------
--
-- The register allocator
#include "HsVersions.h"
+import BlockId
import MachRegs
import MachInstrs
import RegAllocInfo
import RegLiveness
-import Cmm
+import Cmm hiding (RegSet)
+import PprMach
import Digraph
import Unique ( Uniquable(getUnique), Unique )
import UniqSupply
import Outputable
import State
+import FastString
+import MonadUtils
-#ifndef DEBUG
-import Data.Maybe ( fromJust )
-#endif
-import Data.List ( nub, partition, mapAccumL, foldl')
-import Control.Monad ( when )
+import Data.Maybe
+import Data.List
+import Control.Monad
import Data.Word
import Data.Bits
+import Debug.Trace
+
+#include "../includes/MachRegs.h"
-- -----------------------------------------------------------------------------
-- The free register set
allocateReg f r = filter (/= r) f
-}
-#if defined(powerpc_TARGET_ARCH)
+#if defined(powerpc_TARGET_ARCH)
-- The PowerPC has 32 integer and 32 floating point registers.
-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
getFreeRegs cls (FreeRegs g f)
| RcDouble <- cls = go f (0x80000000) 63
| RcInteger <- cls = go g (0x80000000) 31
+ | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (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
| r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
| otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
-#else
+
+#elif defined(sparc_TARGET_ARCH)
+--------------------------------------------------------------------------------
+-- SPARC is like PPC, except for twinning of floating point regs.
+-- When we allocate a double reg we must take an even numbered
+-- float reg, as well as the one after it.
+
+
+-- Holds bitmaps showing what registers are currently allocated.
+-- The float and double reg bitmaps overlap, but we only alloc
+-- float regs into the float map, and double regs into the double map.
+--
+-- Free regs have a bit set in the corresponding bitmap.
+--
+data FreeRegs
+ = FreeRegs
+ !Word32 -- int reg bitmap regs 0..31
+ !Word32 -- float reg bitmap regs 32..63
+ !Word32 -- double reg bitmap regs 32..63
+ deriving( Show )
+
+
+-- | A reg map where no regs are free to be allocated.
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0 0
+
+
+-- | The initial set of free regs.
+-- Don't treat the top half of reg pairs we're using as doubles as being free.
+initFreeRegs :: FreeRegs
+initFreeRegs
+ = regs
+ where
+ freeDouble = getFreeRegs RcDouble regs
+ regs = foldr releaseReg noFreeRegs allocable
+ allocable = allocatableRegs \\ doublePairs
+ doublePairs = [43, 45, 47, 49, 51, 53]
+
+
+-- | Get all the free registers of this class.
+getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
+getFreeRegs cls (FreeRegs g f d)
+ | RcInteger <- cls = go g 1 0
+ | RcFloat <- cls = go f 1 32
+ | RcDouble <- cls = go d 1 32
+ | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
+ where
+ go _ 0 _ = []
+ go x m i | x .&. m /= 0 = i : (go x (m `shiftL` 1) $! i+1)
+ | otherwise = go x (m `shiftL` 1) $! i+1
+
+showFreeRegs :: FreeRegs -> String
+showFreeRegs regs
+ = "FreeRegs\n"
+ ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n"
+ ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n"
+ ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n"
+
+
+-- | Check whether a reg is free
+regIsFree :: RegNo -> FreeRegs -> Bool
+regIsFree r (FreeRegs g f d)
+
+ -- a general purpose reg
+ | r <= 31
+ , mask <- 1 `shiftL` fromIntegral r
+ = g .&. mask /= 0
+
+ -- use the first 22 float regs as double precision
+ | r >= 32
+ , r <= 53
+ , mask <- 1 `shiftL` (fromIntegral r - 32)
+ = d .&. mask /= 0
+
+ -- use the last 10 float regs as single precision
+ | otherwise
+ , mask <- 1 `shiftL` (fromIntegral r - 32)
+ = f .&. mask /= 0
+
+
+-- | Grab a register.
+grabReg :: RegNo -> FreeRegs -> FreeRegs
+grabReg r (FreeRegs g f d)
+
+ -- a general purpose reg
+ | r <= 31
+ , mask <- complement (1 `shiftL` fromIntegral r)
+ = FreeRegs (g .&. mask) f d
+
+ -- use the first 22 float regs as double precision
+ | r >= 32
+ , r <= 53
+ , mask <- complement (1 `shiftL` (fromIntegral r - 32))
+ = FreeRegs g f (d .&. mask)
+
+ -- use the last 10 float regs as single precision
+ | otherwise
+ , mask <- complement (1 `shiftL` (fromIntegral r - 32))
+ = FreeRegs g (f .&. mask) d
+
+
+
+-- | Release a register from allocation.
+-- The register liveness information says that most regs die after a C call,
+-- but we still don't want to allocate to some of them.
+--
+releaseReg :: RegNo -> FreeRegs -> FreeRegs
+releaseReg r regs@(FreeRegs g f d)
+
+ -- used by STG machine, or otherwise unavailable
+ | r >= 0 && r <= 15 = regs
+ | r >= 17 && r <= 21 = regs
+ | r >= 24 && r <= 31 = regs
+ | r >= 32 && r <= 41 = regs
+ | r >= 54 && r <= 59 = regs
+
+ -- never release the high part of double regs.
+ | r == 43 = regs
+ | r == 45 = regs
+ | r == 47 = regs
+ | r == 49 = regs
+ | r == 51 = regs
+ | r == 53 = regs
+
+ -- a general purpose reg
+ | r <= 31
+ , mask <- 1 `shiftL` fromIntegral r
+ = FreeRegs (g .|. mask) f d
+
+ -- use the first 22 float regs as double precision
+ | r >= 32
+ , r <= 53
+ , mask <- 1 `shiftL` (fromIntegral r - 32)
+ = FreeRegs g f (d .|. mask)
+
+ -- use the last 10 float regs as single precision
+ | otherwise
+ , mask <- 1 `shiftL` (fromIntegral r - 32)
+ = FreeRegs g (f .|. mask) d
+
+
+-- | Allocate a register in the map.
+allocateReg :: RegNo -> FreeRegs -> FreeRegs
+allocateReg r regs@(FreeRegs g f d)
+
+ -- if the reg isn't actually free then we're in trouble
+{- | not $ regIsFree r regs
+ = pprPanic
+ "RegAllocLinear.allocateReg"
+ (text "reg " <> ppr r <> text " is not free")
+-}
+ | otherwise
+ = grabReg r regs
+
+
+
+--------------------------------------------------------------------------------
-- If we have less than 32 registers, or if we have efficient 64-bit words,
-- we will just use a single bitfield.
-#if defined(alpha_TARGET_ARCH)
-type FreeRegs = Word64
#else
+
+# if defined(alpha_TARGET_ARCH)
+type FreeRegs = Word64
+# else
type FreeRegs = Word32
-#endif
+# endif
noFreeRegs :: FreeRegs
noFreeRegs = 0
getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
getFreeRegs cls f = go f 0
- where go 0 m = []
+ where go 0 _ = []
go n m
| n .&. 1 /= 0 && regClass (RealReg m) == cls
= m : (go (n `shiftR` 1) $! (m+1))
emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
-getStackSlotFor fs@(StackMap [] reserved) reg
- = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
+getStackSlotFor (StackMap [] _) _
+ = 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
Just slot -> (fs,slot)
:: LiveCmmTop
-> UniqSM (NatCmmTop, Maybe RegAllocStats)
-regAlloc cmm@(CmmData sec d)
+regAlloc (CmmData sec d)
= return
( CmmData sec d
, Nothing )
-regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params [])
- = return
- ( CmmProc info lbl params []
- , Nothing )
+regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
+ = return ( CmmProc info lbl params (ListGraph [])
+ , Nothing )
-regAlloc cmm@(CmmProc static lbl params comps)
+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 i [b] -> AcyclicSCC b
- BasicBlock i bs -> CyclicSCC bs)
+ BasicBlock _ [b] -> AcyclicSCC b
+ BasicBlock _ bs -> CyclicSCC bs)
$ comps
-- make sure the block that was first in the input list
let ((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
- return ( CmmProc info lbl params (first' : rest')
+ return ( CmmProc info lbl params (ListGraph (first' : rest'))
, Just stats)
+-- bogus. to make non-exhaustive match warning go away.
+regAlloc (CmmProc _ _ _ _)
+ = panic "RegAllocLinear.regAlloc: no match"
-- -----------------------------------------------------------------------------
instruction might still want to read it.
-}
-#ifdef DEBUG
instance Outputable Loc where
ppr l = text (show l)
-#endif
-- | 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 (block_assig', stackMap', stats, blocks) =
+ 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 block_live 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
-> [Instr] -> [NatBasicBlock] -> [LiveInstr]
-> RegM ([Instr], [NatBasicBlock])
-linearRA block_live instr_acc fixups []
+linearRA _ instr_acc fixups []
= return (reverse instr_acc, fixups)
linearRA block_live instr_acc fixups (instr:instrs)
[NatBasicBlock] -- extra fixup blocks
)
-raInsn block_live new_instrs (Instr instr@(COMMENT _) Nothing)
+raInsn _ new_instrs (Instr (COMMENT _) Nothing)
= return (new_instrs, [])
-raInsn block_live new_instrs (Instr instr@(DELTA n) Nothing)
+raInsn _ new_instrs (Instr (DELTA n) Nothing)
= do
setDeltaR n
return (new_instrs, [])
Just loc ->
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
- -}
+ -- we have eliminated 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
+ -}
return (new_instrs, [])
- other -> genRaInsn block_live new_instrs instr
+ _ -> genRaInsn block_live new_instrs instr
(uniqSetToList $ liveDieRead live)
(uniqSetToList $ liveDieWrite live)
-raInsn block_live new_instrs li
+raInsn _ _ li
= pprPanic "raInsn" (text "no match for:" <> ppr li)
-- (a) save any temporaries which will be clobbered by this instruction
clobber_saves <- saveClobberedTemps real_written r_dying
- {-
- freeregs <- getFreeRegsR
+
+{- freeregs <- getFreeRegsR
assig <- getAssigR
- pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
- -}
+ pprTrace "raInsn"
+ (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written
+ $$ text (show freeregs) $$ ppr assig)
+ $ do
+-}
-- (b), (c) allocate real regs for all regs read by this instruction.
(r_spills, r_allocd) <-
free <- getFreeRegsR
loop assig free regs
where
- loop assig free _ | free `seq` False = undefined
+ loop _ free _ | free `seq` False = undefined
loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
loop assig free (r:rs) =
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
clobberRegs clobbered = do
freeregs <- getFreeRegsR
+-- setFreeRegsR $! foldr grabReg freeregs clobbered
setFreeRegsR $! foldr allocateReg freeregs clobbered
+
assig <- getAssigR
setAssigR $! clobber assig (ufmToList assig)
where
clobber assig ((temp, InBoth reg slot) : rest)
| reg `elem` clobbered
= clobber (addToUFM assig temp (InMem slot)) rest
- clobber assig (entry:rest)
+ clobber assig (_:rest)
= clobber assig rest
-- -----------------------------------------------------------------------------
-> [Reg] -- temps to allocate
-> RegM ([Instr], [RegNo])
-allocateRegsAndSpill reading keep spills alloc []
+allocateRegsAndSpill _ _ spills alloc []
= return (spills,reverse alloc)
allocateRegsAndSpill reading keep spills alloc (r:rs) = do
-- InReg, because the memory value is no longer valid.
-- NB2. This is why we must process written registers here, even if they
-- are also read by the same instruction.
- Just (InBoth my_reg mem) -> do
+ Just (InBoth my_reg _) -> do
when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
case getFreeRegs (regClass r) freeregs of
-- case (2): we have a free register
- my_reg:_ -> do
+ freeClass@(my_reg:_) -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -}
+ do
spills' <- loadTemp reading r loc my_reg spills
let new_loc
| Just (InMem slot) <- loc, reading = InBoth my_reg slot
| otherwise = InReg my_reg
setAssigR (addToUFM assig r $! new_loc)
- setFreeRegsR (allocateReg my_reg freeregs)
+ setFreeRegsR $ allocateReg my_reg freeregs
allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
-- case (3): we need to push something out to free up a register
-- to spill. We just pick the first one that isn't used in
-- the current instruction for now.
- let (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
-
+ let (temp_to_push_out, my_reg)
+ = case candidates2 of
+ [] -> panic $ "RegAllocLinear.allocRegsAndSpill: no spill candidates"
+ ++ "assignment: " ++ show (ufmToList assig) ++ "\n"
+ (x:_) -> x
+
(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
-myHead s [] = panic s
-myHead s (x:xs) = x
-
-- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets
-> [BlockId]
-> RegM ([NatBasicBlock], Instr)
-joinToTargets block_live new_blocks instr []
+joinToTargets _ new_blocks instr []
= return (new_blocks, instr)
joinToTargets block_live new_blocks instr (dest:dests) = do
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
- Just (freeregs,dest_assig)
+ Just (_, dest_assig)
-- the assignments match
| ufmToList dest_assig == ufmToList adjusted_assig
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
| src == mem = [(vreg, loc, [InReg dst])]
| otherwise = [(vreg, loc, [InReg dst, InMem mem])]
-expandNode vreg loc@(InBoth _ src) (InMem dst)
+expandNode _ (InBoth _ src) (InMem dst)
| src == dst = [] -- guaranteed to be true
-expandNode vreg loc@(InBoth src _) (InReg dst)
+expandNode _ (InBoth src _) (InReg dst)
| src == dst = []
-expandNode vreg loc@(InBoth src _) dst
+expandNode vreg (InBoth src _) dst
= expandNode vreg (InReg src) dst
expandNode vreg src dst
-- can join together allocations for different basic blocks.
--
makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr
-makeMove delta vreg (InReg src) (InReg dst)
+makeMove _ vreg (InReg src) (InReg dst)
= do recordSpill (SpillJoinRR vreg)
return $ mkRegRegMoveInstr (RealReg src) (RealReg dst)
= do recordSpill (SpillJoinRM vreg)
return $ mkSpillInstr (RealReg src) delta dst
-makeMove delta vreg src dst
+makeMove _ vreg src dst
= panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
++ show dst ++ ")"
++ " (workaround: use -fviaC)"
-- we have eliminated any possibility of single-node cylces
-- in expandNode above.
handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
-handleComponent delta instr (AcyclicSCC (vreg,src,dsts))
+handleComponent delta _ (AcyclicSCC (vreg,src,dsts))
= mapM (makeMove delta vreg src) dsts
-- we can not have cycles that involve memory
-- because memory locations (stack slots) are
-- allocated exclusively for a virtual register and
-- therefore can not require a fixup
-handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest))
+handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
= do
spill_id <- getUniqueR
- (saveInstr,slot) <- spillR (RealReg sreg) spill_id
- remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest)
+ (_, slot) <- spillR (RealReg sreg) spill_id
+ 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 . (:[])
getRestoreMoves _ _ = panic "getRestoreMoves unknown case"
-handleComponent delta instr (CyclicSCC _)
+handleComponent _ _ (CyclicSCC _)
= panic "Register Allocator: handleComponent cyclic"
case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack,
ra_us = us, ra_spills = [] }) of
- (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack', ra_spills=spills' }, returned_thing #)
+ (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #)
-> (block_assig, stack', makeRAStats state', returned_thing)
spillR :: Reg -> Unique -> RegM (Instr, Int)
countRegRegMovesNat cmm
= execState (mapGenBlockTopM countBlock cmm) 0
where
- countBlock b@(BasicBlock i instrs)
- = do instrs' <- mapM countInstr instrs
+ countBlock b@(BasicBlock _ instrs)
+ = do mapM_ countInstr instrs
return b
countInstr instr
-- -----------------------------------------------------------------------------
-- Utils
-#ifdef DEBUG
-my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
-my_fromJust s p (Just x) = x
-#else
-my_fromJust _ _ = fromJust
-#endif
+my_fromJust :: String -> SDoc -> Maybe a -> a
+my_fromJust _ _ (Just x) = x
+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