Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
93883372
Commit
93883372
authored
Jul 30, 2012
by
Simon Marlow
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
bug fixes for the sinker
parent
e26161ff
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
76 additions
and
37 deletions
+76
-37
compiler/cmm/CmmSink.hs
compiler/cmm/CmmSink.hs
+76
-37
No files found.
compiler/cmm/CmmSink.hs
View file @
93883372
...
...
@@ -10,8 +10,7 @@ import CmmUtils
import
Hoopl
import
UniqFM
import
Unique
import
Outputable
-- import Outputable
import
Data.List
(
partition
)
import
qualified
Data.Set
as
Set
...
...
@@ -67,6 +66,7 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
where
liveness
=
cmmLiveness
graph
getLive
l
=
mapFindWithDefault
Set
.
empty
l
liveness
blocks
=
postorderDfs
graph
...
...
@@ -75,10 +75,11 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
succ_counts
=
foldr
(
\
l
->
mapInsertWith
(
+
)
l
1
)
mapEmpty
all_succs
join_pts
=
mapFilter
(
>
1
)
succ_counts
sink
::
BlockEnv
[
Assignment
]
->
[
CmmBlock
]
->
[
CmmBlock
]
sink
_
[]
=
[]
sink
sunk
(
b
:
bs
)
=
pprTrace
"sink"
(
ppr
lbl
)
$
--
pprTrace "sink" (ppr lbl) $
blockJoin
first
final_middle
last
:
sink
sunk'
bs
where
lbl
=
entryLabel
b
...
...
@@ -86,30 +87,48 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
(
middle'
,
assigs
)
=
walk
ann_middles
emptyBlock
(
mapFindWithDefault
[]
lbl
sunk
)
live
=
Set
.
unions
[
mapFindWithDefault
Set
.
empty
l
liveness
|
l
<-
succs
]
live_middle
=
gen_kill
last
live
succs
=
successors
last
-- Annotate the middle nodes with the registers live *after*
-- the node. This will help us decide whether we can inline
-- an assignment in the current node or not.
live
=
Set
.
unions
(
map
getLive
succs
)
live_middle
=
gen_kill
last
live
ann_middles
=
annotate
live_middle
(
blockToList
middle
)
getLive
l
=
mapFindWithDefault
Set
.
empty
l
liveness
succs
=
successors
last
-- We cannot sink into join points (successors with more than
-- one predecessor), so identify the join points and the set
-- of registers live in them.
(
joins
,
nonjoins
)
=
partition
(`
mapMember
`
join_pts
)
succs
live_in_nonjoins
=
concatMap
(
Set
.
toList
.
getLive
)
nonjoins
live_in_joins
::
[
LocalReg
]
live_in_joins
=
concatMap
(
Set
.
toList
.
getLive
)
joins
live_in_joins
=
Set
.
unions
(
map
getLive
joins
)
-- We do not want to sink an assignment into multiple branches,
-- so identify the set of registers live in multiple successors.
-- This is made more complicated because when we sink an assignment
-- into one branch, this might change the set of registers that are
-- now live in multiple branches.
init_live_sets
=
map
getLive
nonjoins
live_in_multi
live_sets
r
=
case
filter
(
Set
.
member
r
)
live_sets
of
(
_one
:
_two
:
_
)
->
True
_
->
False
-- Now, drop any assignments that we will not sink any further.
(
dropped_last
,
assigs'
)
=
dropAssignments
drop_if
init_live_sets
assigs
drop_if
a
@
(
r
,
rhs
,
_
)
live_sets
=
(
should_drop
,
live_sets'
)
where
should_drop
=
a
`
conflicts
`
last
||
{- not (isTiny rhs) && -}
live_in_multi
live_sets
r
||
r
`
Set
.
member
`
live_in_joins
-- multilive is a list of registers that are live in more than
-- one successor branch, and we should therefore drop them here.
multilive
=
[
r
|
(
r
,
n
)
<-
ufmToList
livemap
,
n
>
1
]
where
livemap
=
foldr
(
\
r
m
->
addToUFM_C
(
+
)
m
r
(
1
::
Int
))
emptyUFM
live_in_nonjoins
live_sets'
|
should_drop
=
live_sets
|
otherwise
=
map
upd
live_sets
(
dropped_last
,
assigs'
)
=
dropAssignments
drop_if
assigs
upd
set
|
r
`
Set
.
member
`
set
=
set
`
Set
.
union
`
live_rhs
|
otherwise
=
set
drop_if
a
@
(
r
,
_
,
_
)
=
a
`
conflicts
`
last
||
(
getUnique
r
`
elem
`
multilive
)
||
(
r
`
elem
`
live_in_joins
)
live_rhs
=
foldRegsUsed
extendRegSet
emptyRegSet
rhs
final_middle
=
foldl
blockSnoc
middle'
dropped_last
...
...
@@ -117,6 +136,11 @@ cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
mapFromList
[
(
l
,
filterAssignments
(
getLive
l
)
assigs'
)
|
l
<-
succs
]
-- tiny: an expression we don't mind duplicating
isTiny
::
CmmExpr
->
Bool
isTiny
(
CmmReg
_
)
=
True
isTiny
(
CmmLit
_
)
=
True
isTiny
_other
=
False
-- annotate each node with the set of registers live *after* the node
annotate
::
RegSet
->
[
CmmNode
O
O
]
->
[(
RegSet
,
CmmNode
O
O
)]
...
...
@@ -143,18 +167,26 @@ walk ((live,node):ns) block as
where
usages
::
UniqFM
Int
usages
=
foldRegsUsed
addUsage
emptyUFM
node
(
dropped
,
as'
)
=
dropAssignments
(`
conflicts
`
node1
)
as1
(
dropped
,
as'
)
=
dropAssignments
Simple
(`
conflicts
`
node1
)
as1
block'
=
foldl
blockSnoc
block
dropped
`
blockSnoc
`
node1
tryToInline
::
RegSet
->
UniqFM
Int
->
CmmNode
O
x
->
[
Assignment
]
->
(
CmmNode
O
x
,
[
Assignment
])
tryToInline
live
usages
node
[]
tryToInline
_
live
_
usages
node
[]
=
(
node
,
[]
)
tryToInline
live
usages
node
((
l
,
rhs
,
_
)
:
rest
)
|
not
(
l
`
elemRegSet
`
live
),
Just
1
<-
lookupUFM
usages
l
=
tryToInline
live'
usages'
node'
rest
tryToInline
live
usages
node
(
a
@
(
l
,
rhs
,
_
)
:
rest
)
|
occurs_once_in_this_node
=
inline_and_discard
|
False
{- isTiny rhs -}
=
inline_and_keep
-- ^^ seems to make things slightly worse
where
inline_and_discard
=
tryToInline
live'
usages'
node'
rest
inline_and_keep
=
(
node''
,
a
:
rest'
)
where
(
node''
,
rest'
)
=
inline_and_discard
occurs_once_in_this_node
=
not
(
l
`
elemRegSet
`
live
)
&&
lookupUFM
usages
l
==
Just
1
live'
=
foldRegsUsed
extendRegSet
live
rhs
usages'
=
foldRegsUsed
addUsage
usages
rhs
...
...
@@ -162,33 +194,40 @@ tryToInline live usages node ((l,rhs,_) : rest)
where
inline
(
CmmReg
(
CmmLocal
l'
))
|
l
==
l'
=
rhs
inline
(
CmmRegOff
(
CmmLocal
l'
)
off
)
|
l
==
l'
=
cmmOffset
rhs
off
inline
other
=
other
tryToInline
live
usages
node
(
assig
:
rest
)
tryToInline
live
usages
node
(
assig
@
(
_
,
rhs
,
_
)
:
rest
)
=
(
node'
,
assig
:
rest'
)
where
(
node'
,
rest'
)
=
tryToInline
live
usages
node
rest
where
(
node'
,
rest'
)
=
tryToInline
live
usages'
node
rest
usages'
=
foldRegsUsed
addUsage
usages
rhs
addUsage
::
UniqFM
Int
->
LocalReg
->
UniqFM
Int
addUsage
m
r
=
addToUFM_C
(
+
)
m
r
1
shouldSink
::
CmmNode
e
x
->
Maybe
Assignment
shouldSink
(
CmmAssign
(
CmmLocal
r
)
e
)
|
no_local_regs
=
Just
(
r
,
e
,
exprAddr
e
)
where
no_local_regs
=
foldRegsUsed
(
\
_
_
->
False
)
True
e
where
no_local_regs
=
True
--
foldRegsUsed (\_ _ -> False) True e
shouldSink
_other
=
Nothing
toNode
::
Assignment
->
CmmNode
O
O
toNode
(
r
,
rhs
,
_
)
=
CmmAssign
(
CmmLocal
r
)
rhs
dropAssignments
::
(
Assignment
->
Bool
)
->
[
Assignment
]
->
([
CmmNode
O
O
],
[
Assignment
])
dropAssignments
should_drop
assigs
dropAssignmentsSimple
::
(
Assignment
->
Bool
)
->
[
Assignment
]
->
([
CmmNode
O
O
],
[
Assignment
])
dropAssignmentsSimple
f
=
dropAssignments
(
\
a
_
->
(
f
a
,
()
))
()
dropAssignments
::
(
Assignment
->
s
->
(
Bool
,
s
))
->
s
->
[
Assignment
]
->
([
CmmNode
O
O
],
[
Assignment
])
dropAssignments
should_drop
state
assigs
=
(
dropped
,
reverse
kept
)
where
(
dropped
,
kept
)
=
go
assigs
[]
[]
(
dropped
,
kept
)
=
go
state
assigs
[]
[]
go
[]
dropped
kept
=
(
dropped
,
kept
)
go
(
assig
:
rest
)
dropped
kept
|
conflict
=
go
rest
(
toNode
assig
:
dropped
)
kept
|
otherwise
=
go
rest
dropped
(
assig
:
kept
)
go
_
[]
dropped
kept
=
(
dropped
,
kept
)
go
state
(
assig
:
rest
)
dropped
kept
|
conflict
=
go
state'
rest
(
toNode
assig
:
dropped
)
kept
|
otherwise
=
go
state'
rest
dropped
(
assig
:
kept
)
where
conflict
=
should_drop
assig
||
any
(
assig
`
conflicts
`)
dropped
(
dropit
,
state'
)
=
should_drop
assig
state
conflict
=
dropit
||
any
(
assig
`
conflicts
`)
dropped
-- -----------------------------------------------------------------------------
-- | @conflicts (r,e) stmt@ is @False@ if and only if the assignment
-- @r = e@ can be safely commuted past @stmt@.
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment