Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
272f0ba8
Commit
272f0ba8
authored
Sep 05, 2007
by
Ben.Lippmeier@anu.edu.au
Browse files
warning police
parent
a7f409e8
Changes
13
Hide whitespace changes
Inline
Side-by-side
compiler/nativeGen/GraphBase.hs
View file @
272f0ba8
-- | 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
,
...
...
@@ -52,6 +46,7 @@ data Graph k cls color
graphMap
::
UniqFM
(
Node
k
cls
color
)
}
-- | An empty graph.
initGraph
::
Graph
k
cls
color
initGraph
=
Graph
{
graphMap
=
emptyUFM
}
...
...
compiler/nativeGen/GraphColor.hs
View file @
272f0ba8
...
...
@@ -3,13 +3,7 @@
-- 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
,
...
...
@@ -121,7 +115,7 @@ assignColors
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
)
...
...
@@ -189,12 +183,12 @@ selectColor colors graph u
-- 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
...
...
compiler/nativeGen/GraphOps.hs
View file @
272f0ba8
-- | 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
,
...
...
@@ -432,7 +425,7 @@ slurpNodeConflictCount
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
...
...
@@ -461,7 +454,7 @@ adjustWithDefaultUFM
adjustWithDefaultUFM
f
def
k
map
=
addToUFM_C
(
\
old
new
->
f
old
)
(
\
old
_
->
f
old
)
map
k
def
...
...
compiler/nativeGen/GraphPpr.hs
View file @
272f0ba8
-- | 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
...
...
@@ -34,6 +27,10 @@ dumpGraph 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 "
...
...
@@ -76,6 +73,13 @@ dotGraph colorMap triv graph
++
[
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
...
...
@@ -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.
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
...
...
@@ -148,9 +159,11 @@ dotNodeEdges visited node
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 ];"
compiler/nativeGen/RegAllocColor.hs
View file @
272f0ba8
...
...
@@ -12,13 +12,7 @@
--
-- 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
,
...
...
@@ -67,7 +61,7 @@ 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
...
...
@@ -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
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
...
...
@@ -270,10 +264,10 @@ graphAddCoalesce
->
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
...
...
@@ -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
$$
Color
.
dotGraph
(
\
x
->
text
"white"
)
trivColorable
graph
)
$$
Color
.
dotGraph
(
\
_
->
text
"white"
)
trivColorable
graph
)
in
patchEraseLive
patchF
code
...
...
compiler/nativeGen/RegAllocLinear.hs
View file @
272f0ba8
{-# 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
...
...
@@ -12,6 +5,7 @@
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-missing-signatures #-}
{-
The algorithm is roughly:
...
...
@@ -111,7 +105,7 @@ import State
#
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
...
...
@@ -195,7 +189,7 @@ initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
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
))
...
...
@@ -228,7 +222,7 @@ emptyStackMap :: StackMap
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
...
...
@@ -243,25 +237,25 @@ regAlloc
::
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
...
...
@@ -272,6 +266,9 @@ regAlloc cmm@(CmmProc static lbl params comps)
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
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
)
...
...
@@ -370,7 +367,7 @@ linearRA
->
[
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
)
...
...
@@ -390,10 +387,10 @@ raInsn :: BlockMap RegSet -- Live temporaries at each basic block
[
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
,
[]
)
...
...
@@ -432,12 +429,12 @@ raInsn block_live new_instrs (Instr instr (Just live))
-}
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
)
...
...
@@ -527,7 +524,7 @@ releaseRegs regs = do
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
)
=
...
...
@@ -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
(
entry
:
rest
)
clobber
assig
(
_
:
rest
)
=
clobber
assig
rest
-- -----------------------------------------------------------------------------
...
...
@@ -618,7 +615,7 @@ allocateRegsAndSpill
->
[
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
...
...
@@ -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.
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
...
...
@@ -734,7 +731,7 @@ loadTemp _ _ _ _ spills =
myHead
s
[]
=
panic
s
myHead
s
(
x
:
xs
)
=
x
myHead
_
(
x
:
_
)
=
x
-- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets
...
...
@@ -753,7 +750,7 @@ joinToTargets
->
[
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
...
...
@@ -787,7 +784,7 @@ 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
...
...
@@ -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
])]
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
...
...
@@ -870,7 +867,7 @@ 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
)
...
...
@@ -882,7 +879,7 @@ makeMove delta vreg (InReg src) (InMem 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)"
...
...
@@ -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
]
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
...
...
@@ -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
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
)
...
...
@@ -921,7 +918,7 @@ handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest))
getRestoreMoves
_
_
=
panic
"getRestoreMoves unknown case"
handleComponent
delta
instr
(
CyclicSCC
_
)
handleComponent
_
_
(
CyclicSCC
_
)
=
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
(
#
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
)
...
...
@@ -1067,8 +1064,8 @@ countRegRegMovesNat :: NatCmmTop -> 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
...
...
compiler/nativeGen/RegAllocStats.hs
View file @
272f0ba8
-- 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
(
..
),
...
...
@@ -178,7 +172,7 @@ binLifetimeCount fm
$
eltsUFM
fm
in
addListToUFM_C
(
\
(
l1
,
c1
)
(
l2
,
c2
)
->
(
l1
,
c1
+
c2
))
(
\
(
l1
,
c1
)
(
_
,
c2
)
->
(
l1
,
c1
+
c2
))
emptyUFM
lifes
...
...
@@ -188,7 +182,7 @@ pprStatsConflict
::
[
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
]
...
...
@@ -239,12 +233,12 @@ countSRM_block (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
|
RELOAD
slot
reg
<-
instr
|
RELOAD
_
_
<-
instr
=
do
modify
$
\
(
s
,
r
,
m
)
->
(
s
,
r
+
1
,
m
)
return
li
...
...
compiler/nativeGen/RegArchBase.hs
View file @
272f0ba8
...
...
@@ -12,13 +12,6 @@
-- 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
(
..
),
...
...
@@ -71,7 +64,7 @@ instance Uniquable Reg where
=
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
...
...
compiler/nativeGen/RegArchX86.hs
View file @
272f0ba8
...
...
@@ -6,13 +6,6 @@
-- 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
,
...
...
@@ -30,11 +23,11 @@ import UniqSet
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.
...
...
@@ -96,18 +89,18 @@ regAlias 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
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"
...
...
compiler/nativeGen/RegCoalesce.hs
View file @
272f0ba8
-- | Register coalescing.