projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
a7f409e
)
warning police
author
Ben.Lippmeier@anu.edu.au
<unknown>
Wed, 5 Sep 2007 09:45:09 +0000
(09:45 +0000)
committer
Ben.Lippmeier@anu.edu.au
<unknown>
Wed, 5 Sep 2007 09:45:09 +0000
(09:45 +0000)
13 files changed:
compiler/nativeGen/GraphBase.hs
patch
|
blob
|
history
compiler/nativeGen/GraphColor.hs
patch
|
blob
|
history
compiler/nativeGen/GraphOps.hs
patch
|
blob
|
history
compiler/nativeGen/GraphPpr.hs
patch
|
blob
|
history
compiler/nativeGen/RegAllocColor.hs
patch
|
blob
|
history
compiler/nativeGen/RegAllocLinear.hs
patch
|
blob
|
history
compiler/nativeGen/RegAllocStats.hs
patch
|
blob
|
history
compiler/nativeGen/RegArchBase.hs
patch
|
blob
|
history
compiler/nativeGen/RegArchX86.hs
patch
|
blob
|
history
compiler/nativeGen/RegCoalesce.hs
patch
|
blob
|
history
compiler/nativeGen/RegLiveness.hs
patch
|
blob
|
history
compiler/nativeGen/RegSpill.hs
patch
|
blob
|
history
compiler/nativeGen/RegSpillClean.hs
patch
|
blob
|
history
diff --git
a/compiler/nativeGen/GraphBase.hs
b/compiler/nativeGen/GraphBase.hs
index
5b0971d
..
c4e9eb3
100644
(file)
--- a/
compiler/nativeGen/GraphBase.hs
+++ b/
compiler/nativeGen/GraphBase.hs
@@
-1,11
+1,5
@@
-- | Types for the general graph colorer.
-- | 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,
module GraphBase (
Triv,
@@
-52,6
+46,7
@@
data Graph k cls color
graphMap :: UniqFM (Node k cls color) }
-- | An empty graph.
graphMap :: UniqFM (Node k cls color) }
-- | An empty graph.
+initGraph :: Graph k cls color
initGraph
= Graph
{ graphMap = emptyUFM }
initGraph
= Graph
{ graphMap = emptyUFM }
diff --git
a/compiler/nativeGen/GraphColor.hs
b/compiler/nativeGen/GraphColor.hs
index
ecebf27
..
c60c12d
100644
(file)
--- a/
compiler/nativeGen/GraphColor.hs
+++ b/
compiler/nativeGen/GraphColor.hs
@@
-3,13
+3,7
@@
-- This is a generic graph coloring library, abstracted over the type of
-- the node keys, nodes and colors.
--
-- 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,
module GraphColor (
module GraphBase,
@@
-121,7
+115,7
@@
assignColors
assignColors colors graph ks
= assignColors' colors graph [] ks
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)
= (graph, prob)
assignColors' colors graph prob (k:ks)
@@
-189,12
+183,12
@@
selectColor colors graph u
-- we got one of our preferences, score!
| not $ isEmptyUniqSet colors_ok_pref
-- 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
= 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
= Just c
-- leave this node uncolored
diff --git
a/compiler/nativeGen/GraphOps.hs
b/compiler/nativeGen/GraphOps.hs
index
e61b9d1
..
f620d8a
100644
(file)
--- a/
compiler/nativeGen/GraphOps.hs
+++ b/
compiler/nativeGen/GraphOps.hs
@@
-1,13
+1,6
@@
-
-- | Basic operations on graphs.
--
-- | 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,
module GraphOps (
addNode, delNode, getNode, lookupNode, modNode,
@@
-432,7
+425,7
@@
slurpNodeConflictCount
slurpNodeConflictCount graph
= addListToUFM_C
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
emptyUFM
$ map (\node
-> let count = sizeUniqSet $ nodeConflicts node
@@
-461,7
+454,7
@@
adjustWithDefaultUFM
adjustWithDefaultUFM f def k map
= addToUFM_C
adjustWithDefaultUFM f def k map
= addToUFM_C
- (\old new -> f old)
+ (\old _ -> f old)
map
k def
map
k def
diff --git
a/compiler/nativeGen/GraphPpr.hs
b/compiler/nativeGen/GraphPpr.hs
index
4f84cbd
..
1df5158
100644
(file)
--- a/
compiler/nativeGen/GraphPpr.hs
+++ b/
compiler/nativeGen/GraphPpr.hs
@@
-1,13
+1,6
@@
-- | Pretty printing of graphs.
-- | 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
module GraphPpr (
dumpGraph,
dotGraph
@@
-34,6
+27,10
@@
dumpGraph graph
= text "Graph"
$$ (vcat $ map dumpNode $ eltsUFM $ graphMap graph)
= 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 "
dumpNode node
= text "Node " <> ppr (nodeId node)
$$ text "conflicts "
@@
-76,6
+73,13
@@
dotGraph colorMap triv graph
++ [ text "}"
, space ])
++ [ 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
dotNode colorMap triv node
= let name = ppr $ nodeId node
cls = ppr $ nodeClass node
@@
-126,6
+130,13
@@
dotNode colorMap triv node
-- conflict if the graphviz graph. Traverse over the graph, but make sure
-- to only print the edges for each node once.
-- 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
dotNodeEdges visited node
| elementOfUniqSet (nodeId node) visited
= ( visited
@@
-148,9
+159,11
@@
dotNodeEdges visited node
in ( addOneToUniqSet visited (nodeId node)
, Just out)
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 ];"
diff --git
a/compiler/nativeGen/RegAllocColor.hs
b/compiler/nativeGen/RegAllocColor.hs
index
b9eda1b
..
2e3d40e
100644
(file)
--- a/
compiler/nativeGen/RegAllocColor.hs
+++ b/
compiler/nativeGen/RegAllocColor.hs
@@
-12,13
+12,7
@@
--
-- Colors in graphviz graphs could be nicer.
--
--
-- 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,
module RegAllocColor (
regAlloc,
@@
-67,7
+61,7
@@
regAlloc
regAlloc dump regsFree slotsFree code
= do
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
<- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
return ( code_final
@@
-89,7
+83,7
@@
regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
-- build a map of how many instructions each reg lives for.
-- this is lazy, it won't be computed unless we need to spill
-- 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
$ map lifetimeCount code
-- record startup state
@@
-270,10
+264,10
@@
graphAddCoalesce
-> Color.Graph Reg RegClass Reg
graphAddCoalesce (r1, r2) graph
-> Color.Graph Reg RegClass Reg
graphAddCoalesce (r1, r2) graph
- | RealReg regno <- r1
+ | RealReg _ <- r1
= Color.addPreference (regWithClass r2) r1 graph
= Color.addPreference (regWithClass r2) r1 graph
- | RealReg regno <- r2
+ | RealReg _ <- r2
= Color.addPreference (regWithClass r1) r2 graph
| otherwise
= Color.addPreference (regWithClass r1) r2 graph
| otherwise
@@
-306,7
+300,7
@@
patchRegsFromGraph graph code
= pprPanic "patchRegsFromGraph: register mapping failed."
( text "There is no node in the graph for register " <> ppr reg
$$ ppr code
= 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
in patchEraseLive patchF code
diff --git
a/compiler/nativeGen/RegAllocLinear.hs
b/compiler/nativeGen/RegAllocLinear.hs
index
bd9b82a
..
c3a7319
100644
(file)
--- a/
compiler/nativeGen/RegAllocLinear.hs
+++ b/
compiler/nativeGen/RegAllocLinear.hs
@@
-1,10
+1,3
@@
-{-# 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
-----------------------------------------------------------------------------
--
-- The register allocator
@@
-12,6
+5,7
@@
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
+{-# OPTIONS -fno-warn-missing-signatures #-}
{-
The algorithm is roughly:
{-
The algorithm is roughly:
@@
-111,7
+105,7
@@
import State
#ifndef DEBUG
import Data.Maybe ( fromJust )
#endif
#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
import Control.Monad ( when )
import Data.Word
import Data.Bits
@@
-195,7
+189,7
@@
initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
getFreeRegs cls f = go f 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))
go n m
| n .&. 1 /= 0 && regClass (RealReg m) == cls
= m : (go (n `shiftR` 1) $! (m+1))
@@
-228,7
+222,7
@@
emptyStackMap :: StackMap
emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
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
= panic "RegAllocLinear.getStackSlotFor: out of stack slots"
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
case lookupUFM reserved reg of
@@
-243,25
+237,25
@@
regAlloc
:: LiveCmmTop
-> UniqSM (NatCmmTop, Maybe RegAllocStats)
:: LiveCmmTop
-> UniqSM (NatCmmTop, Maybe RegAllocStats)
-regAlloc cmm@(CmmData sec d)
+regAlloc (CmmData sec d)
= return
( CmmData sec d
, Nothing )
= return
( CmmData sec d
, Nothing )
-regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params [])
+regAlloc (CmmProc (LiveInfo info _ _) lbl params [])
= return
( CmmProc info lbl params []
, Nothing )
= 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
| 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
$ comps
-- make sure the block that was first in the input list
@@
-272,6
+266,9
@@
regAlloc cmm@(CmmProc static lbl params comps)
return ( CmmProc info lbl params (first' : rest')
, Just stats)
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"
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
@@
-310,13
+307,13
@@
linearRegAlloc
linearRegAlloc block_live sccs
= do us <- getUs
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)
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)
= return $ reverse blocksAcc
linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs)
@@
-370,7
+367,7
@@
linearRA
-> [Instr] -> [NatBasicBlock] -> [LiveInstr]
-> RegM ([Instr], [NatBasicBlock])
-> [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)
= return (reverse instr_acc, fixups)
linearRA block_live instr_acc fixups (instr:instrs)
@@
-390,10
+387,10
@@
raInsn :: BlockMap RegSet -- Live temporaries at each basic block
[NatBasicBlock] -- extra fixup blocks
)
[NatBasicBlock] -- extra fixup blocks
)
-raInsn block_live new_instrs (Instr instr@(COMMENT _) Nothing)
+raInsn _ new_instrs (Instr (COMMENT _) Nothing)
= return (new_instrs, [])
= 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, [])
= do
setDeltaR n
return (new_instrs, [])
@@
-432,12
+429,12
@@
raInsn block_live new_instrs (Instr instr (Just live))
-}
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)
(uniqSetToList $ liveDieRead live)
(uniqSetToList $ liveDieWrite live)
-raInsn block_live new_instrs li
+raInsn _ _ li
= pprPanic "raInsn" (text "no match for:" <> ppr li)
= pprPanic "raInsn" (text "no match for:" <> ppr li)
@@
-527,7
+524,7
@@
releaseRegs regs = do
free <- getFreeRegsR
loop assig free regs
where
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) =
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) =
@@
-597,7
+594,7
@@
clobberRegs clobbered = do
clobber assig ((temp, InBoth reg slot) : rest)
| reg `elem` clobbered
= clobber (addToUFM assig temp (InMem slot)) rest
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
-- -----------------------------------------------------------------------------
= clobber assig rest
-- -----------------------------------------------------------------------------
@@
-618,7
+615,7
@@
allocateRegsAndSpill
-> [Reg] -- temps to allocate
-> RegM ([Instr], [RegNo])
-> [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
= return (spills,reverse alloc)
allocateRegsAndSpill reading keep spills alloc (r:rs) = do
@@
-633,7
+630,7
@@
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.
-- 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
when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
@@
-734,7
+731,7
@@
loadTemp _ _ _ _ spills =
myHead s [] = panic s
myHead s [] = panic s
-myHead s (x:xs) = x
+myHead _ (x:_) = x
-- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets
-- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets
@@
-753,7
+750,7
@@
joinToTargets
-> [BlockId]
-> RegM ([NatBasicBlock], Instr)
-> [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
= return (new_blocks, instr)
joinToTargets block_live new_blocks instr (dest:dests) = do
@@
-787,7
+784,7
@@
joinToTargets block_live new_blocks instr (dest:dests) = do
(freeregs',adjusted_assig))
joinToTargets block_live new_blocks instr dests
(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
-- the assignments match
| ufmToList dest_assig == ufmToList adjusted_assig
@@
-852,13
+849,13
@@
expandNode vreg loc@(InMem src) (InBoth dst mem)
| src == mem = [(vreg, loc, [InReg dst])]
| otherwise = [(vreg, loc, [InReg dst, InMem mem])]
| 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
| src == dst = [] -- guaranteed to be true
-expandNode vreg loc@(InBoth src _) (InReg dst)
+expandNode _ (InBoth src _) (InReg dst)
| src == dst = []
| src == dst = []
-expandNode vreg loc@(InBoth src _) dst
+expandNode vreg (InBoth src _) dst
= expandNode vreg (InReg src) dst
expandNode vreg src dst
= expandNode vreg (InReg src) dst
expandNode vreg src dst
@@
-870,7
+867,7
@@
expandNode vreg src dst
-- can join together allocations for different basic blocks.
--
makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr
-- 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 (SpillJoinRR vreg)
return $ mkRegRegMoveInstr (RealReg src) (RealReg dst)
@@
-882,7
+879,7
@@
makeMove delta vreg (InReg src) (InMem dst)
= do recordSpill (SpillJoinRM vreg)
return $ mkSpillInstr (RealReg src) delta 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)"
= panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
++ show dst ++ ")"
++ " (workaround: use -fviaC)"
@@
-891,7
+888,7
@@
makeMove delta vreg src dst
-- we have eliminated any possibility of single-node cylces
-- in expandNode above.
handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
-- 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
= mapM (makeMove delta vreg src) dsts
-- we can not have cycles that involve memory
@@
-899,10
+896,10
@@
handleComponent delta instr (AcyclicSCC (vreg,src,dsts))
-- because memory locations (stack slots) are
-- allocated exclusively for a virtual register and
-- therefore can not require a fixup
-- 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
= 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)
remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest)
restoreAndFixInstr <- getRestoreMoves dsts slot
return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
@@
-921,7
+918,7
@@
handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest))
getRestoreMoves _ _ = panic "getRestoreMoves unknown case"
getRestoreMoves _ _ = panic "getRestoreMoves unknown case"
-handleComponent delta instr (CyclicSCC _)
+handleComponent _ _ (CyclicSCC _)
= panic "Register Allocator: handleComponent cyclic"
= panic "Register Allocator: handleComponent cyclic"
@@
-963,7
+960,7
@@
runR block_assig freeregs assig stack us thing =
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
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)
-> (block_assig, stack', makeRAStats state', returned_thing)
spillR :: Reg -> Unique -> RegM (Instr, Int)
@@
-1067,8
+1064,8
@@
countRegRegMovesNat :: NatCmmTop -> Int
countRegRegMovesNat cmm
= execState (mapGenBlockTopM countBlock cmm) 0
where
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
return b
countInstr instr
diff --git
a/compiler/nativeGen/RegAllocStats.hs
b/compiler/nativeGen/RegAllocStats.hs
index
fca3bfd
..
728225a
100644
(file)
--- a/
compiler/nativeGen/RegAllocStats.hs
+++ b/
compiler/nativeGen/RegAllocStats.hs
@@
-1,13
+1,7
@@
-
-- Carries interesting info for debugging / profiling of the
-- graph coloring register allocator.
-- 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 (..),
module RegAllocStats (
RegAllocStats (..),
@@
-178,7
+172,7
@@
binLifetimeCount fm
$ eltsUFM fm
in addListToUFM_C
$ eltsUFM fm
in addListToUFM_C
- (\(l1, c1) (l2, c2) -> (l1, c1 + c2))
+ (\(l1, c1) (_, c2) -> (l1, c1 + c2))
emptyUFM
lifes
emptyUFM
lifes
@@
-188,7
+182,7
@@
pprStatsConflict
:: [RegAllocStats] -> SDoc
pprStatsConflict stats
:: [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 ]
emptyUFM
$ map Color.slurpNodeConflictCount
[ raGraph s | s@RegAllocStatsStart{} <- stats ]
@@
-239,12
+233,12
@@
countSRM_block (BasicBlock i instrs)
= do instrs' <- mapM countSRM_instr instrs
return $ BasicBlock i instrs'
= 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
= 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
= do modify $ \(s, r, m) -> (s, r + 1, m)
return li
diff --git
a/compiler/nativeGen/RegArchBase.hs
b/compiler/nativeGen/RegArchBase.hs
index
f8512eb
..
4709b4c
100644
(file)
--- a/
compiler/nativeGen/RegArchBase.hs
+++ b/
compiler/nativeGen/RegArchBase.hs
@@
-12,13
+12,6
@@
-- This code is here because we can test the architecture specific code against it.
--
-- 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(..),
module RegArchBase (
RegClass(..),
Reg(..),
@@
-71,7
+64,7
@@
instance Uniquable Reg where
= mkUnique 'S'
$ fromEnum s * 10000 + fromEnum c * 1000 + i
= 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
= error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
-- | A subcomponent of another register
diff --git
a/compiler/nativeGen/RegArchX86.hs
b/compiler/nativeGen/RegArchX86.hs
index
d05538e
..
c6c3050
100644
(file)
--- a/
compiler/nativeGen/RegArchX86.hs
+++ b/
compiler/nativeGen/RegArchX86.hs
@@
-6,13
+6,6
@@
-- See MachRegs.hs for the actual trivColorable function used in GHC.
--
-- 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,
module RegArchX86 (
classOfReg,
regsOfClass,
@@
-30,11
+23,11
@@
import UniqSet
classOfReg :: Reg -> RegClass
classOfReg reg
= case reg of
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.
-- | Determine all the regs that make up a certain class.
@@
-96,18
+89,18
@@
regAlias reg
-- 16 bit subregs alias the whole reg
-- 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
-> 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 ]
-> 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
-> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
-- fp
- Reg ClassF64 i
+ Reg ClassF64 _
-> unitUniqSet reg
_ -> error "regAlias: invalid register"
-> unitUniqSet reg
_ -> error "regAlias: invalid register"
diff --git
a/compiler/nativeGen/RegCoalesce.hs
b/compiler/nativeGen/RegCoalesce.hs
index
76cd672
..
2bcc6ec
100644
(file)
--- a/
compiler/nativeGen/RegCoalesce.hs
+++ b/
compiler/nativeGen/RegCoalesce.hs
@@
-1,14
+1,6
@@
-
-- | Register coalescing.
--
-- | 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
module RegCoalesce (
regCoalesce,
slurpJoinMovs
@@
-71,8
+63,8
@@
slurpJoinMovs live
where
slurpCmm rs CmmData{} = rs
slurpCmm rs (CmmProc _ _ _ blocks) = foldl' slurpComp rs blocks
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))
slurpLI rs (Instr _ Nothing) = rs
slurpLI rs (Instr instr (Just live))
diff --git
a/compiler/nativeGen/RegLiveness.hs
b/compiler/nativeGen/RegLiveness.hs
index
f2db089
..
c47ce96
100644
(file)
--- a/
compiler/nativeGen/RegLiveness.hs
+++ b/
compiler/nativeGen/RegLiveness.hs
@@
-5,13
+5,7
@@
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
-- (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,
module RegLiveness (
RegSet,
@@
-60,9
+54,13
@@
import Data.Maybe
type RegSet = UniqSet Reg
type RegMap a = UniqFM a
type RegSet = UniqSet Reg
type RegMap a = UniqFM a
+
+emptyRegMap :: UniqFM a
emptyRegMap = emptyUFM
type BlockMap a = UniqFM a
emptyRegMap = emptyUFM
type BlockMap a = UniqFM a
+
+emptyBlockMap :: UniqFM a
emptyBlockMap = emptyUFM
emptyBlockMap = emptyUFM
@@
-149,7
+147,7
@@
mapBlockTopM
=> (LiveBasicBlock -> m LiveBasicBlock)
-> LiveCmmTop -> m LiveCmmTop
=> (LiveBasicBlock -> m LiveBasicBlock)
-> LiveCmmTop -> m LiveCmmTop
-mapBlockTopM f cmm@(CmmData{})
+mapBlockTopM _ cmm@(CmmData{})
= return cmm
mapBlockTopM f (CmmProc header label params comps)
= return cmm
mapBlockTopM f (CmmProc header label params comps)
@@
-176,7
+174,7
@@
mapGenBlockTopM
=> (GenBasicBlock i -> m (GenBasicBlock i))
-> (GenCmmTop d h i -> m (GenCmmTop d h i))
=> (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)
= return cmm
mapGenBlockTopM f (CmmProc header label params blocks)
@@
-196,7
+194,7
@@
slurpConflicts live
slurpCmm rs (CmmProc info _ _ blocks)
= foldl' (slurpComp info) rs 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)
= foldl' (slurpBlock info) rs blocks
slurpBlock info rs (BasicBlock blockId instrs)
@@
-213,7
+211,7
@@
slurpConflicts live
slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
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.
= let
-- regs that die because they are read for the last time at the start of an instruction
-- are not live across it.
@@
-255,7
+253,7
@@
stripLive live
stripCmm (CmmProc (LiveInfo info _ _) label params comps)
= CmmProc info label params (concatMap stripComp comps)
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
stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
stripLI (Instr instr _) = instr
@@
-271,7
+269,7
@@
spillNatBlock (BasicBlock i is)
spillNat acc []
= return (reverse acc)
spillNat acc []
= return (reverse acc)
- spillNat acc (instr@(DELTA i) : instrs)
+ spillNat acc (DELTA i : instrs)
= do put i
spillNat acc instrs
= do put i
spillNat acc instrs
@@
-300,7
+298,7
@@
lifetimeCount cmm
countCmm fm (CmmProc info _ _ blocks)
= foldl' (countComp info) fm blocks
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)
= foldl' (countBlock info) fm blocks
countBlock info fm (BasicBlock blockId instrs)
@@
-311,7
+309,7
@@
lifetimeCount cmm
| otherwise
= error "RegLiveness.countBlock: bad block"
| 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)
countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
@@
-357,7
+355,7
@@
patchEraseLive patchF cmm
where
patchCmm cmm@CmmData{} = cmm
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
| LiveInfo static id blockMap <- info
= let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
blockMap' = mapUFM patchRegSet blockMap
@@
-424,15
+422,15
@@
regLiveness
:: NatCmmTop
-> UniqSM LiveCmmTop
:: 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 []
= 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
= let first_id = blockId first
sccs = sccBlocks blocks
(ann_sccs, block_live) = computeLiveness sccs
@@
-531,7
+529,7
@@
livenessBlock
-> NatBasicBlock
-> (BlockMap RegSet, LiveBasicBlock)
-> 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)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
@@
-550,13
+548,13
@@
livenessForward
:: RegSet -- regs live on this instr
-> [LiveInstr] -> [LiveInstr]
:: RegSet -- regs live on this instr
-> [LiveInstr] -> [LiveInstr]
-livenessForward rsLiveEntry [] = []
+livenessForward _ [] = []
livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
| Nothing <- mLive
= li : livenessForward rsLiveEntry lis
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.
= let
-- Regs that are written to but weren't live on entry to this instruction
-- are recorded as being born here.
@@
-570,6
+568,8
@@
livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
in Instr instr (Just live { liveBorn = rsBorn })
: livenessForward rsLiveNext lis
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
-- | Calculate liveness going backwards,
-- filling in when regs die, and what regs are live across each instruction
@@
-581,17
+581,17
@@
livenessBack
-> [Instr] -- instructions
-> (RegSet, [LiveInstr])
-> [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
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)
= (liveregs, Instr instr Nothing)
-liveness1 liveregs blockmap (instr@DELTA{})
+liveness1 liveregs _ (instr@DELTA{})
= (liveregs, Instr instr Nothing)
liveness1 liveregs blockmap instr
= (liveregs, Instr instr Nothing)
liveness1 liveregs blockmap instr
diff --git
a/compiler/nativeGen/RegSpill.hs
b/compiler/nativeGen/RegSpill.hs
index
9379e6e
..
0fdb8ce
100644
(file)
--- a/
compiler/nativeGen/RegSpill.hs
+++ b/
compiler/nativeGen/RegSpill.hs
@@
-1,10
+1,5
@@
-{-# 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,
module RegSpill (
regSpill,
@@
-14,8
+9,6
@@
module RegSpill (
where
where
-#include "HsVersions.h"
-
import RegLiveness
import RegAllocInfo
import MachRegs
import RegLiveness
import RegAllocInfo
import MachRegs
@@
-86,7
+79,7
@@
regSpill_instr _ li@(Instr _ Nothing)
= do return [li]
regSpill_instr regSlotMap
= 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
= do
-- work out which regs are read and written in this instr
let RU rlRead rlWritten = regUsage instr
@@
-214,7
+207,7
@@
newUnique
modify $ \s -> s { stateUS = us2 }
return uniq
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)
= (r1, s1 + s2, l1 + l2)
diff --git
a/compiler/nativeGen/RegSpillClean.hs
b/compiler/nativeGen/RegSpillClean.hs
index
0ec8023
..
a4be8ed
100644
(file)
--- a/
compiler/nativeGen/RegSpillClean.hs
+++ b/
compiler/nativeGen/RegSpillClean.hs
@@
-23,13
+23,6
@@
-- spilling %r1 to a slot makes that slot have the same value as %r1.
--
-- 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
)
module RegSpillClean (
cleanSpills
)
@@
-44,7
+37,6
@@
import Cmm
import UniqSet
import UniqFM
import State
import UniqSet
import UniqFM
import State
-import Outputable
import Data.Maybe
import Data.List
import Data.Maybe
import Data.List
@@
-125,10
+117,10
@@
cleanReload
-> [LiveInstr] -- ^ instrs to clean (in backwards order)
-> CleanM [LiveInstr] -- ^ cleaned instrs (in forward order)
-> [LiveInstr] -- ^ instrs to clean (in backwards order)
-> CleanM [LiveInstr] -- ^ cleaned instrs (in forward order)
-cleanReload assoc acc []
+cleanReload _ acc []
= return 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
| SPILL reg slot <- instr
= let assoc' = addAssoc reg slot -- doing the spill makes reg and slot the same value
@@
-153,13
+145,13
@@
cleanReload assoc acc (li@(Instr instr live) : instrs)
in cleanReload assoc' (li : acc) instrs
-- on a jump, remember the reg/slot association.
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.
, 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
= let assoc' = foldr deleteAAssoc assoc written
in cleanReload assoc' (li : acc) instrs
@@
-175,11
+167,11
@@
cleanSpill
-> [LiveInstr] -- ^ instrs to clean (in forwards order)
-> CleanM [LiveInstr] -- ^ cleaned instrs (in backwards order)
-> [LiveInstr] -- ^ instrs to clean (in forwards order)
-> CleanM [LiveInstr] -- ^ cleaned instrs (in backwards order)
-cleanSpill unused acc []
+cleanSpill _ acc []
= return 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
= if elementOfUniqSet slot unused
-- we can erase this spill because the slot won't be read until after the next one
@@
-193,7
+185,7
@@
cleanSpill unused acc (li@(Instr instr live) : instrs)
cleanSpill unused' (li : acc) instrs
-- if we reload from a slot then it's no longer unused
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
, unused' <- delOneFromUniqSet unused slot
= cleanSpill unused' (li : acc) instrs
@@
-238,6
+230,7
@@
data CleanS
, sCleanedSpillsAcc :: Int
, sCleanedReloadsAcc :: Int }
, sCleanedSpillsAcc :: Int
, sCleanedReloadsAcc :: Int }
+initCleanS :: CleanS
initCleanS
= CleanS
{ sJumpValid = emptyUFM
initCleanS
= CleanS
{ sJumpValid = emptyUFM