-- | Types for the general graph colorer.
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
module GraphBase (
Triv,
graphMap :: UniqFM (Node k cls color) }
-- | An empty graph.
+initGraph :: Graph k cls color
initGraph
= Graph
{ graphMap = emptyUFM }
-- This is a generic graph coloring library, abstracted over the type of
-- the node keys, nodes and colors.
--
-
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
module GraphColor (
module GraphBase,
assignColors colors graph ks
= assignColors' colors graph [] ks
- where assignColors' colors graph prob []
+ where assignColors' _ graph prob []
= (graph, prob)
assignColors' colors graph prob (k:ks)
-- we got one of our preferences, score!
| not $ isEmptyUniqSet colors_ok_pref
- , c : rest <- uniqSetToList colors_ok_pref
+ , c : _ <- uniqSetToList colors_ok_pref
= Just c
-- it wasn't a preference, but it was still ok
| not $ isEmptyUniqSet colors_ok
- , c : rest <- uniqSetToList colors_ok
+ , c : _ <- uniqSetToList colors_ok
= Just c
-- leave this node uncolored
-
-- | Basic operations on graphs.
--
-
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
module GraphOps (
addNode, delNode, getNode, lookupNode, modNode,
slurpNodeConflictCount graph
= addListToUFM_C
- (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
+ (\(c1, n1) (_, n2) -> (c1, n1 + n2))
emptyUFM
$ map (\node
-> let count = sizeUniqSet $ nodeConflicts node
adjustWithDefaultUFM f def k map
= addToUFM_C
- (\old new -> f old)
+ (\old _ -> f old)
map
k def
-- | Pretty printing of graphs.
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
-
module GraphPpr (
dumpGraph,
dotGraph
= text "Graph"
$$ (vcat $ map dumpNode $ eltsUFM $ graphMap graph)
+dumpNode
+ :: (Outputable k, Outputable cls, Outputable color)
+ => Node k cls color -> SDoc
+
dumpNode node
= text "Node " <> ppr (nodeId node)
$$ text "conflicts "
++ [ text "}"
, space ])
+
+dotNode :: ( Uniquable k
+ , Outputable k, Outputable cls, Outputable color)
+ => (color -> SDoc)
+ -> Triv k cls color
+ -> Node k cls color -> SDoc
+
dotNode colorMap triv node
= let name = ppr $ nodeId node
cls = ppr $ nodeClass node
-- conflict if the graphviz graph. Traverse over the graph, but make sure
-- to only print the edges for each node once.
+dotNodeEdges
+ :: ( Uniquable k
+ , Outputable k, Outputable cls, Outputable color)
+ => UniqSet k
+ -> Node k cls color
+ -> (UniqSet k, Maybe SDoc)
+
dotNodeEdges visited node
| elementOfUniqSet (nodeId node) visited
= ( visited
in ( addOneToUniqSet visited (nodeId node)
, Just out)
-dotEdgeConflict u1 u2
- = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> text ";"
+ where dotEdgeConflict u1 u2
+ = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+ <> text ";"
-dotEdgeCoalesce u1 u2
- = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> space <> text "[ style = dashed ];"
+ dotEdgeCoalesce u1 u2
+ = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+ <> space <> text "[ style = dashed ];"
--
-- Colors in graphviz graphs could be nicer.
--
-
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
module RegAllocColor (
regAlloc,
regAlloc dump regsFree slotsFree code
= do
- (code_final, debug_codeGraphs, graph_final)
+ (code_final, debug_codeGraphs, _)
<- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
return ( code_final
-- build a map of how many instructions each reg lives for.
-- this is lazy, it won't be computed unless we need to spill
- let fmLife = plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2))
+ let fmLife = plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
$ map lifetimeCount code
-- record startup state
-> Color.Graph Reg RegClass Reg
graphAddCoalesce (r1, r2) graph
- | RealReg regno <- r1
+ | RealReg _ <- r1
= Color.addPreference (regWithClass r2) r1 graph
- | RealReg regno <- r2
+ | RealReg _ <- r2
= Color.addPreference (regWithClass r1) r2 graph
| otherwise
= pprPanic "patchRegsFromGraph: register mapping failed."
( text "There is no node in the graph for register " <> ppr reg
$$ ppr code
- $$ Color.dotGraph (\x -> text "white") trivColorable graph)
+ $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
in patchEraseLive patchF code
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
-
-----------------------------------------------------------------------------
--
-- The register allocator
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
+{-# OPTIONS -fno-warn-missing-signatures #-}
{-
The algorithm is roughly:
#ifndef DEBUG
import Data.Maybe ( fromJust )
#endif
-import Data.List ( nub, partition, mapAccumL, foldl')
+import Data.List ( nub, partition, foldl')
import Control.Monad ( when )
import Data.Word
import Data.Bits
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
+getStackSlotFor (StackMap [] _) _
= panic "RegAllocLinear.getStackSlotFor: out of stack slots"
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
case lookupUFM reserved reg of
:: 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 [])
+regAlloc (CmmProc (LiveInfo info _ _) lbl params [])
= return
( CmmProc info lbl params []
, Nothing )
-regAlloc cmm@(CmmProc static lbl params comps)
+regAlloc (CmmProc static lbl params comps)
| LiveInfo info (Just first_id) block_live <- static
= do
-- do register allocation on each component.
(final_blocks, stats)
<- linearRegAlloc 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
return ( CmmProc info lbl params (first' : rest')
, Just stats)
+-- bogus. to make non-exhaustive match warning go away.
+regAlloc (CmmProc _ _ _ _)
+ = panic "RegAllocLinear.regAlloc: no match"
-- -----------------------------------------------------------------------------
linearRegAlloc 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
return (blocks, stats)
-linearRA_SCCs block_live blocksAcc []
+linearRA_SCCs _ blocksAcc []
= return $ reverse blocksAcc
linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs)
-> [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, [])
-}
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)
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) =
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
myHead s [] = panic s
-myHead s (x:xs) = x
+myHead _ (x:_) = 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
(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
| 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
+ (_, slot) <- spillR (RealReg sreg) spill_id
remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest)
restoreAndFixInstr <- getRestoreMoves dsts slot
return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
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
-
-- Carries interesting info for debugging / profiling of the
-- graph coloring register allocator.
-
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
+--
+{-# OPTIONS -fno-warn-missing-signatures #-}
module RegAllocStats (
RegAllocStats (..),
$ eltsUFM fm
in addListToUFM_C
- (\(l1, c1) (l2, c2) -> (l1, c1 + c2))
+ (\(l1, c1) (_, c2) -> (l1, c1 + c2))
emptyUFM
lifes
:: [RegAllocStats] -> SDoc
pprStatsConflict stats
- = let confMap = foldl' (plusUFM_C (\(c1, n1) (c2, n2) -> (c1, n1 + n2)))
+ = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
emptyUFM
$ map Color.slurpNodeConflictCount
[ raGraph s | s@RegAllocStatsStart{} <- stats ]
= do instrs' <- mapM countSRM_instr instrs
return $ BasicBlock i instrs'
-countSRM_instr li@(Instr instr live)
- | SPILL reg slot <- instr
+countSRM_instr li@(Instr instr _)
+ | SPILL _ _ <- instr
= do modify $ \(s, r, m) -> (s + 1, r, m)
return li
- | RELOAD slot reg <- instr
+ | RELOAD _ _ <- instr
= do modify $ \(s, r, m) -> (s, r + 1, m)
return li
-- This code is here because we can test the architecture specific code against it.
--
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
-
module RegArchBase (
RegClass(..),
Reg(..),
= mkUnique 'S'
$ fromEnum s * 10000 + fromEnum c * 1000 + i
- getUnique (RegSub s (RegSub c _))
+ getUnique (RegSub _ (RegSub _ _))
= error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
-- | A subcomponent of another register
-- See MachRegs.hs for the actual trivColorable function used in GHC.
--
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
-
module RegArchX86 (
classOfReg,
regsOfClass,
classOfReg :: Reg -> RegClass
classOfReg reg
= case reg of
- Reg c i -> c
+ Reg c _ -> c
- RegSub SubL16 r -> ClassG16
- RegSub SubL8 r -> ClassG8
- RegSub SubL8H r -> ClassG8
+ RegSub SubL16 _ -> ClassG16
+ RegSub SubL8 _ -> ClassG8
+ RegSub SubL8H _ -> ClassG8
-- | Determine all the regs that make up a certain class.
-- 16 bit subregs alias the whole reg
- RegSub SubL16 r@(Reg ClassG32 i)
+ RegSub SubL16 r@(Reg ClassG32 _)
-> regAlias r
-- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
- RegSub SubL8 r@(Reg ClassG32 i)
+ RegSub SubL8 r@(Reg ClassG32 _)
-> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
- RegSub SubL8H r@(Reg ClassG32 i)
+ RegSub SubL8H r@(Reg ClassG32 _)
-> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
-- fp
- Reg ClassF64 i
+ Reg ClassF64 _
-> unitUniqSet reg
_ -> error "regAlias: invalid register"
-
-- | Register coalescing.
--
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
-
module RegCoalesce (
regCoalesce,
slurpJoinMovs
where
slurpCmm rs CmmData{} = rs
slurpCmm rs (CmmProc _ _ _ blocks) = foldl' slurpComp rs blocks
- slurpComp rs (BasicBlock i blocks) = foldl' slurpBlock rs blocks
- slurpBlock rs (BasicBlock i instrs) = foldl' slurpLI rs instrs
+ slurpComp rs (BasicBlock _ blocks) = foldl' slurpBlock rs blocks
+ slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs
slurpLI rs (Instr _ Nothing) = rs
slurpLI rs (Instr instr (Just live))
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
-
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
module RegLiveness (
RegSet,
type RegSet = UniqSet Reg
type RegMap a = UniqFM a
+
+emptyRegMap :: UniqFM a
emptyRegMap = emptyUFM
type BlockMap a = UniqFM a
+
+emptyBlockMap :: UniqFM a
emptyBlockMap = emptyUFM
=> (LiveBasicBlock -> m LiveBasicBlock)
-> LiveCmmTop -> m LiveCmmTop
-mapBlockTopM f cmm@(CmmData{})
+mapBlockTopM _ cmm@(CmmData{})
= return cmm
mapBlockTopM f (CmmProc header label params comps)
=> (GenBasicBlock i -> m (GenBasicBlock i))
-> (GenCmmTop d h i -> m (GenCmmTop d h i))
-mapGenBlockTopM f cmm@(CmmData{})
+mapGenBlockTopM _ cmm@(CmmData{})
= return cmm
mapGenBlockTopM f (CmmProc header label params blocks)
slurpCmm rs (CmmProc info _ _ blocks)
= foldl' (slurpComp info) rs blocks
- slurpComp info rs (BasicBlock i blocks)
+ slurpComp info rs (BasicBlock _ blocks)
= foldl' (slurpBlock info) rs blocks
slurpBlock info rs (BasicBlock blockId instrs)
slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
- slurpLIs rsLiveEntry (conflicts, moves) (li@(Instr instr (Just live)) : lis)
+ slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
= let
-- regs that die because they are read for the last time at the start of an instruction
-- are not live across it.
stripCmm (CmmProc (LiveInfo info _ _) label params comps)
= CmmProc info label params (concatMap stripComp comps)
- stripComp (BasicBlock i blocks) = map stripBlock blocks
+ stripComp (BasicBlock _ blocks) = map stripBlock blocks
stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
stripLI (Instr instr _) = instr
spillNat acc []
= return (reverse acc)
- spillNat acc (instr@(DELTA i) : instrs)
+ spillNat acc (DELTA i : instrs)
= do put i
spillNat acc instrs
countCmm fm (CmmProc info _ _ blocks)
= foldl' (countComp info) fm blocks
- countComp info fm (BasicBlock i blocks)
+ countComp info fm (BasicBlock _ blocks)
= foldl' (countBlock info) fm blocks
countBlock info fm (BasicBlock blockId instrs)
| otherwise
= error "RegLiveness.countBlock: bad block"
- countLIs rsLive fm [] = fm
+ countLIs _ fm [] = fm
countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
where
patchCmm cmm@CmmData{} = cmm
- patchCmm cmm@(CmmProc info label params comps)
+ patchCmm (CmmProc info label params comps)
| LiveInfo static id blockMap <- info
= let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
blockMap' = mapUFM patchRegSet blockMap
:: NatCmmTop
-> UniqSM LiveCmmTop
-regLiveness cmm@(CmmData sec d)
- = returnUs $ CmmData sec d
+regLiveness (CmmData i d)
+ = returnUs $ CmmData i d
-regLiveness cmm@(CmmProc info lbl params [])
+regLiveness (CmmProc info lbl params [])
= returnUs $ CmmProc
(LiveInfo info Nothing emptyUFM)
lbl params []
-regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
+regLiveness (CmmProc info lbl params blocks@(first : _))
= let first_id = blockId first
sccs = sccBlocks blocks
(ann_sccs, block_live) = computeLiveness sccs
-> NatBasicBlock
-> (BlockMap RegSet, LiveBasicBlock)
-livenessBlock blockmap block@(BasicBlock block_id instrs)
+livenessBlock blockmap (BasicBlock block_id instrs)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
:: RegSet -- regs live on this instr
-> [LiveInstr] -> [LiveInstr]
-livenessForward rsLiveEntry [] = []
+livenessForward _ [] = []
livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
| Nothing <- mLive
= li : livenessForward rsLiveEntry lis
- | Just live <- mLive
- , RU read written <- regUsage instr
+ | Just live <- mLive
+ , RU _ written <- regUsage instr
= let
-- Regs that are written to but weren't live on entry to this instruction
-- are recorded as being born here.
in Instr instr (Just live { liveBorn = rsBorn })
: livenessForward rsLiveNext lis
+livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
+
-- | Calculate liveness going backwards,
-- filling in when regs die, and what regs are live across each instruction
-> [Instr] -- instructions
-> (RegSet, [LiveInstr])
-livenessBack liveregs blockmap done [] = (liveregs, done)
+livenessBack liveregs _ done [] = (liveregs, done)
livenessBack liveregs blockmap acc (instr : instrs)
= let (liveregs', instr') = liveness1 liveregs blockmap instr
in livenessBack liveregs' blockmap (instr' : acc) instrs
-- don't bother tagging comments or deltas with liveness
-liveness1 liveregs blockmap (instr@COMMENT{})
+liveness1 liveregs _ (instr@COMMENT{})
= (liveregs, Instr instr Nothing)
-liveness1 liveregs blockmap (instr@DELTA{})
+liveness1 liveregs _ (instr@DELTA{})
= (liveregs, Instr instr Nothing)
liveness1 liveregs blockmap instr
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
module RegSpill (
regSpill,
where
-#include "HsVersions.h"
-
import RegLiveness
import RegAllocInfo
import MachRegs
= do return [li]
regSpill_instr regSlotMap
- (Instr instr (Just live))
+ (Instr instr (Just _))
= do
-- work out which regs are read and written in this instr
let RU rlRead rlWritten = regUsage instr
modify $ \s -> s { stateUS = us2 }
return uniq
-accSpillSL (r1, s1, l1) (r2, s2, l2)
+accSpillSL (r1, s1, l1) (_, s2, l2)
= (r1, s1 + s2, l1 + l2)
-- spilling %r1 to a slot makes that slot have the same value as %r1.
--
-{-# 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/Commentary/CodingStyle#Warnings
--- for details
-
module RegSpillClean (
cleanSpills
)
import UniqSet
import UniqFM
import State
-import Outputable
import Data.Maybe
import Data.List
-> [LiveInstr] -- ^ instrs to clean (in backwards order)
-> CleanM [LiveInstr] -- ^ cleaned instrs (in forward order)
-cleanReload assoc acc []
+cleanReload _ acc []
= return acc
-cleanReload assoc acc (li@(Instr instr live) : instrs)
+cleanReload assoc acc (li@(Instr instr _) : instrs)
| SPILL reg slot <- instr
= let assoc' = addAssoc reg slot -- doing the spill makes reg and slot the same value
in cleanReload assoc' (li : acc) instrs
-- on a jump, remember the reg/slot association.
- | targets <- jumpDests instr []
+ | targets <- jumpDests instr []
, not $ null targets
= do mapM_ (accJumpValid assoc) targets
cleanReload assoc (li : acc) instrs
-- writing to a reg changes its value.
- | RU read written <- regUsage instr
+ | RU _ written <- regUsage instr
= let assoc' = foldr deleteAAssoc assoc written
in cleanReload assoc' (li : acc) instrs
-> [LiveInstr] -- ^ instrs to clean (in forwards order)
-> CleanM [LiveInstr] -- ^ cleaned instrs (in backwards order)
-cleanSpill unused acc []
+cleanSpill _ acc []
= return acc
-cleanSpill unused acc (li@(Instr instr live) : instrs)
- | SPILL reg slot <- instr
+cleanSpill unused acc (li@(Instr instr _) : instrs)
+ | SPILL _ slot <- instr
= if elementOfUniqSet slot unused
-- we can erase this spill because the slot won't be read until after the next one
cleanSpill unused' (li : acc) instrs
-- if we reload from a slot then it's no longer unused
- | RELOAD slot reg <- instr
+ | RELOAD slot _ <- instr
, unused' <- delOneFromUniqSet unused slot
= cleanSpill unused' (li : acc) instrs
, sCleanedSpillsAcc :: Int
, sCleanedReloadsAcc :: Int }
+initCleanS :: CleanS
initCleanS
= CleanS
{ sJumpValid = emptyUFM
projects / ghc-hetmet.git / commitdiff