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
b9bcf6e7
Commit
b9bcf6e7
authored
Sep 13, 2007
by
nr@eecs.harvard.edu
Browse files
new signatures for splicing functions, new postorder_dfs
parent
2f48dee3
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/ZipCfg.hs
View file @
b9bcf6e7
...
...
@@ -14,15 +14,15 @@ module ZipCfg
-- (open to renaming suggestions here)
,
blockId
,
zip
,
unzip
,
last
,
goto_end
,
zipht
,
tailOfLast
,
remove_entry_label
,
splice_tail
,
splice_head
,
splice_head_only
,
splice_tail
,
splice_head
,
splice_head_only
'
,
splice_head'
,
of_block_list
,
to_block_list
,
map_nodes
,
postorder_dfs
,
postorder_dfs
,
postorder_dfs_from
,
postorder_dfs_from_except
,
fold_layout
,
fold_blocks
,
translate
,
pprLgraph
,
pprLgraph
,
pprGraph
{-
-- the following functions might one day be useful and can be found
...
...
@@ -150,7 +150,7 @@ data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
-- | Blocks and flow graphs; see Note [Kinds of graphs]
data
Block
m
l
=
Block
BlockId
(
ZTail
m
l
)
data
Graph
m
l
=
Graph
(
ZTail
m
l
)
(
BlockEnv
(
Block
m
l
))
data
Graph
m
l
=
Graph
{
g_entry
::
(
ZTail
m
l
),
g_blocks
::
(
BlockEnv
(
Block
m
l
))
}
data
LGraph
m
l
=
LGraph
{
lg_entry
::
BlockId
,
lg_blocks
::
BlockEnv
(
Block
m
l
)
}
...
...
@@ -217,15 +217,16 @@ ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
-- , (???, [<blocks>,
-- N: y:=x; return (y,x)])
splice_head
::
ZHead
m
->
LGraph
m
l
->
(
LGraph
m
l
,
ZHead
m
)
splice_tail
::
LGraph
m
l
->
ZTail
m
l
->
(
ZTail
m
l
,
LGraph
m
l
)
splice_head
::
ZHead
m
->
LGraph
m
l
->
(
LGraph
m
l
,
ZHead
m
)
splice_head'
::
ZHead
m
->
Graph
m
l
->
(
BlockEnv
(
Block
m
l
),
ZHead
m
)
splice_tail
::
Graph
m
l
->
ZTail
m
l
->
Graph
m
l
-- | We can also splice a single-entry, no-exit
L
Graph into a head.
-- | We can also splice a single-entry, no-exit Graph into a head.
splice_head_only
::
ZHead
m
->
LGraph
m
l
->
LGraph
m
l
splice_head_only'
::
ZHead
m
->
Graph
m
l
->
LGraph
m
l
-- | Finally, we can remove the entry label of an LGraph and remove
-- it, leaving a Graph:
remove_entry_label
::
LGraph
m
l
->
Graph
m
l
-- | A safe operation
-- | Conversion to and from the environment form is convenient. For
-- layout or dataflow, however, one will want to use 'postorder_dfs'
...
...
@@ -323,6 +324,10 @@ instance LastNode l => HavingSuccessors (ZBlock m l) where
instance
LastNode
l
=>
HavingSuccessors
(
Block
m
l
)
where
succs
b
=
succs
(
unzip
b
)
instance
LastNode
l
=>
HavingSuccessors
(
ZTail
m
l
)
where
succs
b
=
succs
(
lastTail
b
)
-- ================ IMPLEMENTATION ================--
...
...
@@ -353,9 +358,11 @@ head_id :: ZHead m -> BlockId
head_id
(
ZFirst
id
)
=
id
head_id
(
ZHead
h
_
)
=
head_id
h
last
(
ZBlock
_
t
)
=
lastt
t
where
lastt
(
ZLast
l
)
=
l
lastt
(
ZTail
_
t
)
=
lastt
t
last
(
ZBlock
_
t
)
=
lastTail
t
lastTail
::
ZTail
m
l
->
ZLast
l
lastTail
(
ZLast
l
)
=
l
lastTail
(
ZTail
_
t
)
=
lastTail
t
tailOfLast
l
=
ZLast
(
LastOther
l
)
-- ^ tedious to write in every client
...
...
@@ -398,6 +405,13 @@ single_exit g = foldUFM check 0 (lg_blocks g) == 1
LastExit
->
count
+
(
1
::
Int
)
_
->
count
-- | Used in assertions; tells if a graph has exactly one exit
single_exitg
::
Graph
l
m
->
Bool
single_exitg
(
Graph
tail
blocks
)
=
foldUFM
add
(
exit_count
(
lastTail
tail
))
blocks
==
1
where
add
block
count
=
count
+
exit_count
(
last
(
unzip
block
))
exit_count
LastExit
=
1
::
Int
exit_count
_
=
0
------------------ graph traversals
-- | This is the most important traversal over this data structure. It drops
...
...
@@ -420,8 +434,9 @@ single_exit g = foldUFM check 0 (lg_blocks g) == 1
-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
-- Better to geot [A,B,C,D]
-- postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
postorder_dfs
g
@
(
LGraph
_
blocks
)
=
postorder_dfs'
::
LastNode
l
=>
LGraph
m
l
->
[
Block
m
l
]
postorder_dfs'
g
@
(
LGraph
_
blocks
)
=
let
FGraph
_
eblock
_
=
entry
g
in
vnode
(
zip
eblock
)
(
\
acc
_visited
->
acc
)
[]
emptyBlockSet
where
...
...
@@ -442,6 +457,39 @@ postorder_dfs g@(LGraph _ blocks) =
Just
b
->
b
:
rst
Nothing
->
rst
postorder_dfs
g
@
(
LGraph
_
blockenv
)
=
let
FGraph
id
eblock
_
=
entry
g
dfs1
=
zip
eblock
:
postorder_dfs_from_except
blockenv
eblock
(
unitUniqSet
id
)
dfs2
=
postorder_dfs'
g
in
ASSERT
(
map
blockId
dfs1
==
map
blockId
dfs2
)
dfs2
postorder_dfs_from
::
(
HavingSuccessors
b
,
LastNode
l
)
=>
BlockEnv
(
Block
m
l
)
->
b
->
[
Block
m
l
]
postorder_dfs_from
blocks
b
=
postorder_dfs_from_except
blocks
b
emptyBlockSet
postorder_dfs_from_except
::
forall
b
m
l
.
(
HavingSuccessors
b
,
LastNode
l
)
=>
BlockEnv
(
Block
m
l
)
->
b
->
BlockSet
->
[
Block
m
l
]
postorder_dfs_from_except
blocks
b
visited
=
vchildren
(
get_children
b
)
(
\
acc
_visited
->
acc
)
[]
visited
where
-- vnode ::
-- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
vnode
block
@
(
Block
id
_
)
cont
acc
visited
=
if
elemBlockSet
id
visited
then
cont
acc
visited
else
let
cont'
acc
visited
=
cont
(
block
:
acc
)
visited
in
vchildren
(
get_children
block
)
cont'
acc
(
extendBlockSet
visited
id
)
vchildren
bs
cont
acc
visited
=
let
next
children
acc
visited
=
case
children
of
[]
->
cont
acc
visited
(
b
:
bs
)
->
vnode
b
(
next
bs
)
acc
visited
in
next
bs
acc
visited
get_children
block
=
foldl
add_id
[]
(
succs
block
)
add_id
rst
id
=
case
lookupBlockEnv
blocks
id
of
Just
b
->
b
:
rst
Nothing
->
rst
-- | Slightly more complicated than the usual fold because we want to tell block
-- 'b1' what its inline successor is going to be, so that if 'b1' ends with
...
...
@@ -494,6 +542,22 @@ prepare_for_splicing g single multi =
case
gl
of
LastExit
->
multi
etail
gh
gblocks
_
->
panic
"exit is not exit?!"
prepare_for_splicing'
::
Graph
m
l
->
(
ZTail
m
l
->
a
)
->
(
ZTail
m
l
->
ZHead
m
->
BlockEnv
(
Block
m
l
)
->
a
)
->
a
prepare_for_splicing'
(
Graph
etail
gblocks
)
single
multi
=
if
isNullUFM
gblocks
then
case
lastTail
etail
of
LastExit
->
single
etail
_
->
panic
"bad single block"
else
case
splitp_blocks
is_exit
gblocks
of
Nothing
->
panic
"Can't find an exit block"
Just
(
gexit
,
gblocks
)
->
let
(
gh
,
gl
)
=
goto_end
$
unzip
gexit
in
case
gl
of
LastExit
->
multi
etail
gh
gblocks
_
->
panic
"exit is not exit?!"
is_exit
::
Block
m
l
->
Bool
is_exit
b
=
case
last
(
unzip
b
)
of
{
LastExit
->
True
;
_
->
False
}
...
...
@@ -507,8 +571,28 @@ splice_head head g =
splice_many_blocks
entry
exit
others
=
(
LGraph
eid
(
insertBlock
(
zipht
head
entry
)
others
),
exit
)
splice_head'
head
g
=
ASSERT
(
single_exitg
g
)
prepare_for_splicing'
g
splice_one_block
splice_many_blocks
where
splice_one_block
tail'
=
case
ht_to_last
head
tail'
of
(
head
,
LastExit
)
->
(
emptyBlockEnv
,
head
)
_
->
panic
"spliced LGraph without exit"
splice_many_blocks
entry
exit
others
=
(
insertBlock
(
zipht
head
entry
)
others
,
exit
)
-- splice_tail :: Graph m l -> ZTail m l -> Graph m l
splice_tail
g
tail
=
ASSERT
(
single_exit
g
)
prepare_for_splicing
g
splice_one_block
splice_many_blocks
ASSERT
(
single_exitg
g
)
prepare_for_splicing'
g
splice_one_block
splice_many_blocks
where
splice_one_block
tail'
=
Graph
(
tail'
`
append_tails
`
tail
)
emptyBlockEnv
append_tails
(
ZLast
LastExit
)
tail
=
tail
append_tails
(
ZLast
_
)
_
=
panic
"spliced single block without LastExit"
append_tails
(
ZTail
m
t
)
tail
=
ZTail
m
(
append_tails
t
tail
)
splice_many_blocks
entry
exit
others
=
Graph
entry
(
insertBlock
(
zipht
exit
tail
)
others
)
{-
splice_tail g tail =
AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
where splice_one_block tail' = -- return tail' .. tail
case ht_to_last (ZFirst (lg_entry g)) tail' of
(head', LastExit) ->
...
...
@@ -518,6 +602,7 @@ splice_tail g tail =
_ -> panic "spliced single block without Exit"
splice_many_blocks entry exit others =
(entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
-}
splice_head_only
head
g
=
let
FGraph
eid
gentry
gblocks
=
entry
g
...
...
@@ -525,12 +610,10 @@ splice_head_only head g =
ZBlock
(
ZFirst
_
)
tail
->
LGraph
eid
(
insertBlock
(
zipht
head
tail
)
gblocks
)
_
->
panic
"entry not at start of block?!"
remove_entry_label
g
=
let
FGraph
e
eblock
others
=
entry
g
in
case
eblock
of
ZBlock
(
ZFirst
id
)
tail
|
id
==
e
->
Graph
tail
others
_
->
panic
"id doesn't match on entry block"
splice_head_only'
head
(
Graph
tail
gblocks
)
=
let
eblock
=
zipht
head
tail
in
LGraph
(
blockId
eblock
)
(
insertBlock
eblock
gblocks
)
--- Translation
...
...
@@ -619,5 +702,11 @@ pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
where
pprBlock
(
Block
id
tail
)
=
ppr
id
<>
colon
$$
ppr
tail
blocks
=
postorder_dfs
g
pprGraph
::
(
Outputable
m
,
Outputable
l
,
LastNode
l
)
=>
Graph
m
l
->
SDoc
pprGraph
(
Graph
tail
blockenv
)
=
text
"{"
$$
nest
2
(
ppr
tail
$$
(
vcat
$
map
pprBlock
blocks
))
$$
text
"}"
where
pprBlock
(
Block
id
tail
)
=
ppr
id
<>
colon
$$
ppr
tail
blocks
=
postorder_dfs_from
blockenv
tail
_unused
::
FS
.
FastString
_unused
=
undefined
compiler/cmm/ZipCfgExtras.hs
View file @
b9bcf6e7
...
...
@@ -16,8 +16,6 @@ import Maybes
import
Panic
import
ZipCfg
import
UniqFM
import
Prelude
hiding
(
zip
,
unzip
,
last
)
...
...
@@ -31,12 +29,14 @@ unfocus :: FGraph m l -> LGraph m l -- lose focus
-- the current focus.
-- The new focus can be at either the entry edge or the exit edge.
{-
splice_focus_entry :: FGraph m l -> LGraph m l -> FGraph m l
splice_focus_exit :: FGraph m l -> LGraph m l -> FGraph m l
-}
_unused
::
()
_unused
=
all
`
seq
`
()
where
all
=
(
exit
,
focusp
,
unfocus
,
splice_focus_entry
,
splice_focus_exit
where
all
=
(
exit
,
focusp
,
unfocus
{-
, splice_focus_entry, splice_focus_exit
-}
,
fold_fwd_block
,
foldM_fwd_block
(
\
_
a
->
Just
a
)
)
...
...
@@ -49,6 +49,8 @@ exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others
where
FGraph
_
b
others
=
focusp
is_exit
g
`
orElse
`
panic
"no exit in flow graph"
(
h
,
l
)
=
goto_end
b
{-
splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g =
let (tail', g') = splice_tail g tail in
FGraph eid (ZBlock head tail') (plusUFM (lg_blocks g') blocks)
...
...
@@ -56,6 +58,7 @@ splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g =
splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g =
let (g', head') = splice_head head g in
FGraph eid (ZBlock head' tail) (plusUFM (lg_blocks g') blocks)
-}
-- | Fold from first to last
fold_fwd_block
::
...
...
compiler/cmm/ZipDataflow.hs
View file @
b9bcf6e7
{-# LANGUAGE MultiParamTypeClasses #-}
module
ZipDataflow
(
Answer
(
..
)
...
...
@@ -368,9 +367,8 @@ solve_graph_b comp fuel graph exit_fact =
Dataflow
a
->
head_in
fuel
h
a
Rewrite
g
->
do
{
bot
<-
botFact
;
g
<-
lgraphOfGraph
g
;
(
fuel
,
a
)
<-
subAnalysis'
$
solve_graph_b
comp
(
fuel
-
1
)
g
bot
solve_graph_b
_g
comp
(
fuel
-
1
)
g
bot
;
head_in
fuel
h
a
}
;
my_trace
"result of"
(
text
(
bc_name
comp
)
<+>
text
"on"
<+>
ppr
(
G
.
blockId
b
)
<+>
text
"is"
<+>
ppr
block_in
)
$
...
...
@@ -381,15 +379,14 @@ solve_graph_b comp fuel graph exit_fact =
bc_middle_in
comp
out
m
fuel
>>=
\
x
->
case
x
of
Dataflow
a
->
head_in
fuel
h
a
Rewrite
g
->
do
{
g
<-
lgraphOfGraph
g
;
(
fuel
,
a
)
<-
subAnalysis'
$
solve_graph_b
comp
(
fuel
-
1
)
g
out
;
my_trace
"Rewrote middle node"
(
f4sep
[
ppr
m
,
text
"to"
,
ppr
g
])
$
do
{
(
fuel
,
a
)
<-
subAnalysis'
$
solve_graph_b_g
comp
(
fuel
-
1
)
g
out
;
my_trace
"Rewrote middle node"
(
f4sep
[
ppr
m
,
text
"to"
,
ppr
Graph
g
])
$
head_in
fuel
h
a
}
head_in
fuel
(
G
.
ZFirst
id
)
out
=
bc_first_in
comp
out
id
fuel
>>=
\
x
->
case
x
of
Dataflow
a
->
return
(
fuel
,
a
)
Rewrite
g
->
do
{
g
<-
lgraphOfGraph
g
;
subAnalysis'
$
solve_graph_b
comp
(
fuel
-
1
)
g
out
}
Rewrite
g
->
do
{
subAnalysis'
$
solve_graph_b_g
comp
(
fuel
-
1
)
g
out
}
in
do
{
fuel
<-
run
"backward"
(
bc_name
comp
)
(
return
()
)
set_block_fact
fuel
blocks
...
...
@@ -402,6 +399,12 @@ solve_graph_b comp fuel graph exit_fact =
pprFacts
g
env
a
=
(
ppr
a
<+>
text
"with"
)
$$
vcat
(
pprLgraph
g
:
map
pprFact
(
ufmToList
env
))
pprFact
(
id
,
a
)
=
hang
(
ppr
id
<>
colon
)
4
(
ppr
a
)
solve_graph_b_g
::
(
DebugNodes
m
l
,
Outputable
a
)
=>
BPass
m
l
a
->
OptimizationFuel
->
G
.
Graph
m
l
->
a
->
DFM
a
(
OptimizationFuel
,
a
)
solve_graph_b_g
comp
fuel
graph
exit_fact
=
do
{
g
<-
lgraphOfGraph
graph
;
solve_graph_b
comp
fuel
g
exit_fact
}
lgraphOfGraph
::
G
.
Graph
m
l
->
DFM
f
(
G
.
LGraph
m
l
)
lgraphOfGraph
g
=
...
...
@@ -411,6 +414,16 @@ lgraphOfGraph g =
labelGraph
::
BlockId
->
G
.
Graph
m
l
->
G
.
LGraph
m
l
labelGraph
id
(
Graph
tail
blocks
)
=
LGraph
id
(
insertBlock
(
Block
id
tail
)
blocks
)
-- | We can remove the entry label of an LGraph and remove
-- it, leaving a Graph. Notice that this operation is NOT SAFE if a
-- block within the LGraph branches to the entry point. It should
-- be used only to complement 'lgraphOfGraph' above.
remove_entry_label
::
LGraph
m
l
->
Graph
m
l
remove_entry_label
g
=
let
FGraph
e
(
ZBlock
(
ZFirst
id
tail
))
others
=
entry
g
in
ASSERT
(
id
==
e
)
Graph
tail
others
{-
We solve and rewrite in two passes: the first pass iterates to a fixed
point to reach a dataflow solution, and the second pass uses that
...
...
@@ -425,6 +438,10 @@ The tail is in final form; the head is still to be rewritten.
solve_and_rewrite_b
::
(
DebugNodes
m
l
,
Outputable
a
)
=>
BPass
m
l
a
->
OptimizationFuel
->
LGraph
m
l
->
a
->
DFM
a
(
OptimizationFuel
,
a
,
LGraph
m
l
)
solve_and_rewrite_b_graph
::
(
DebugNodes
m
l
,
Outputable
a
)
=>
BPass
m
l
a
->
OptimizationFuel
->
Graph
m
l
->
a
->
DFM
a
(
OptimizationFuel
,
a
,
Graph
m
l
)
solve_and_rewrite_b
comp
fuel
graph
exit_fact
=
do
{
(
_
,
a
)
<-
solve_graph_b
comp
fuel
graph
exit_fact
-- pass 1
...
...
@@ -450,49 +467,62 @@ solve_and_rewrite_b comp fuel graph exit_fact =
let
(
h
,
l
)
=
G
.
goto_end
(
G
.
unzip
b
)
in
factsEnv
>>=
\
env
->
last_in
comp
env
l
fuel
>>=
\
x
->
case
x
of
Dataflow
a
->
propagate
fuel
h
a
(
G
.
ZLast
l
)
rewritten
Rewrite
g
->
-- see Note [Rewriting labelled LGraphs]
do
{
bot
<-
botFact
;
g
<-
lgraphOfGraph
g
;
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_b
comp
(
fuel
-
1
)
g
bot
;
let
G
.
Graph
t
new_blocks
=
G
.
remove_entry_label
g'
;
markGraphRewritten
;
let
rewritten'
=
plusUFM
new_blocks
rewritten
;
-- continue at entry of g
propagate
fuel
h
a
t
rewritten'
Rewrite
g
->
do
{
markGraphRewritten
;
bot
<-
botFact
;
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_b_graph
comp
(
fuel
-
1
)
g
bot
;
let
G
.
Graph
t
new_blocks
=
g'
;
let
rewritten'
=
new_blocks
`
plusUFM
`
rewritten
;
propagate
fuel
h
a
t
rewritten'
-- continue at entry of g'
}
-- propagate :: OptimizationFuel
--
-> G.ZHead m
-- Part of current block yet to be rewritten
-- -> a
-- Fact on edge between head and tail
--
-> G.ZTail m l
-- Part of current block already rewritten
-- -> BlockEnv (Block m l)
--
These blocks have been
rewritten
--
-> DFM a (OptimizationFuel, G.LGraph m l)
-- propagate :: OptimizationFuel
-- Number of rewrites permitted
--
-> G.ZHead m
-- Part of current block yet to be rewritten
-- -> a
-- Fact on edge between head and tail
--
-> G.ZTail m l
-- Part of current block already rewritten
-- -> BlockEnv (Block m l)
--
Blocks already
rewritten
--
-> DFM a (OptimizationFuel, G.LGraph m l)
propagate
fuel
(
G
.
ZHead
h
m
)
out
tail
rewritten
=
bc_middle_in
comp
out
m
fuel
>>=
\
x
->
case
x
of
Dataflow
a
->
propagate
fuel
h
a
(
G
.
ZTail
m
tail
)
rewritten
Rewrite
g
->
do
{
g
<-
lgraphOfGraph
g
;
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_b
comp
(
fuel
-
1
)
g
out
;
markGraphRewritten
;
let
(
t
,
g''
)
=
G
.
splice_tail
g'
tail
;
let
rewritten'
=
plusUFM
(
G
.
lg_blocks
g''
)
rewritten
;
my_trace
"Rewrote middle node"
(
f4sep
[
ppr
m
,
text
"to"
,
ppr
g
])
$
propagate
fuel
h
a
t
rewritten'
}
do
{
markGraphRewritten
;
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_b_graph
comp
(
fuel
-
1
)
g
out
;
let
G
.
Graph
t
newblocks
=
G
.
splice_tail
g'
tail
;
my_trace
"Rewrote middle node"
(
f4sep
[
ppr
m
,
text
"to"
,
pprGraph
g'
])
$
propagate
fuel
h
a
t
(
newblocks
`
plusUFM
`
rewritten
)
}
propagate
fuel
h
@
(
G
.
ZFirst
id
)
out
tail
rewritten
=
bc_first_in
comp
out
id
fuel
>>=
\
x
->
case
x
of
Dataflow
a
->
let
b
=
G
.
Block
id
tail
in
do
{
checkFactMatch
id
a
;
rewrite_blocks
comp
fuel
(
extendBlockEnv
rewritten
id
b
)
bs
}
Rewrite
fg
->
do
{
g
<-
lgraphOfGraph
fg
;
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_b
comp
(
fuel
-
1
)
g
out
;
markGraphRewritten
;
let
(
t
,
g''
)
=
G
.
splice_tail
g'
tail
;
let
rewritten'
=
plusUFM
(
G
.
lg_blocks
g''
)
rewritten
;
my_trace
"Rewrote label "
(
f4sep
[
ppr
id
,
text
"to"
,
ppr
g
])
$
propagate
fuel
h
a
t
rewritten'
}
Rewrite
g
->
do
{
markGraphRewritten
;
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_b_graph
comp
(
fuel
-
1
)
g
out
;
let
G
.
Graph
t
newblocks
=
G
.
splice_tail
g'
tail
;
my_trace
"Rewrote label "
(
f4sep
[
ppr
id
,
text
"to"
,
pprGraph
g
])
$
propagate
fuel
h
a
t
(
newblocks
`
plusUFM
`
rewritten
)
}
in
rewrite_next_block
fuel
{- Note [Rewriting labelled LGraphs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's hugely annoying that we get in an LGraph and in order to solve it
we have to slap on a new label which we then immediately strip off.
But the alternative is to have all the iterative solvers work on
Graphs, and then suddenly instead of a single case (ZBlock) every
solver has to deal with two cases (ZBlock and ZTail). So until
somebody comes along who is smart enough to do this and still leave
the code understandable for mortals, it stays as it is.
(One part of the solution will be postorder_dfs_from_except.)
-}
solve_and_rewrite_b_graph
comp
fuel
graph
exit_fact
=
do
g
<-
lgraphOfGraph
graph
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_b
comp
fuel
g
exit_fact
return
(
fuel
,
a
,
remove_entry_label
g'
)
b_rewrite
comp
g
=
do
{
fuel
<-
liftTx
txRemaining
;
bot
<-
botFact
...
...
@@ -643,18 +673,16 @@ solve_graph_f comp fuel g in_fact =
fc_middle_out
comp
in'
m
fuel
>>=
\
x
->
case
x
of
Dataflow
a
->
set_tail_facts
fuel
a
t
Rewrite
g
->
do
g
<-
lgraphOfGraph
g
(
fuel
,
out
,
last_outs
)
<-
subAnalysis'
$
solve_graph_f
comp
(
fuel
-
1
)
g
in'
do
(
fuel
,
out
,
last_outs
)
<-
subAnalysis'
$
solve_graph_f_g
comp
(
fuel
-
1
)
g
in'
set_or_save
last_outs
set_tail_facts
fuel
out
t
set_tail_facts
fuel
in'
(
G
.
ZLast
l
)
=
last_outs
comp
in'
l
fuel
>>=
\
x
->
case
x
of
Dataflow
outs
->
do
{
set_or_save
outs
;
return
fuel
}
Rewrite
g
->
do
g
<-
lgraphOfGraph
g
(
fuel
,
_
,
last_outs
)
<-
subAnalysis'
$
solve_graph_f
comp
(
fuel
-
1
)
g
in'
do
(
fuel
,
_
,
last_outs
)
<-
subAnalysis'
$
solve_graph_f_g
comp
(
fuel
-
1
)
g
in'
set_or_save
last_outs
return
fuel
G
.
Block
id
t
=
b
...
...
@@ -662,13 +690,18 @@ solve_graph_f comp fuel g in_fact =
infact
<-
fc_first_out
comp
idfact
id
fuel
case
infact
of
Dataflow
a
->
set_tail_facts
fuel
a
t
Rewrite
g
->
do
g
<-
lgraphOfGraph
g
(
fuel
,
out
,
last_outs
)
<-
subAnalysis'
$
solve_graph_f
comp
(
fuel
-
1
)
g
idfact
do
(
fuel
,
out
,
last_outs
)
<-
subAnalysis'
$
solve_graph_f_g
comp
(
fuel
-
1
)
g
idfact
set_or_save
last_outs
set_tail_facts
fuel
out
t
in
run
"forward"
(
fc_name
comp
)
set_entry
set_successor_facts
fuel
blocks
solve_graph_f_g
::
(
DebugNodes
m
l
,
Outputable
a
)
=>
FPass
m
l
a
->
OptimizationFuel
->
G
.
Graph
m
l
->
a
->
DFM
a
(
OptimizationFuel
,
a
,
LastOutFacts
a
)
solve_graph_f_g
comp
fuel
graph
in_fact
=
do
{
g
<-
lgraphOfGraph
graph
;
solve_graph_f
comp
fuel
g
in_fact
}
{-
...
...
@@ -691,6 +724,15 @@ solve_and_rewrite_f comp fuel graph in_fact =
exit_fact
<-
getFact
exit_id
return
(
fuel
,
exit_fact
,
g
)
solve_and_rewrite_f_graph
::
(
DebugNodes
m
l
,
Outputable
a
)
=>
FPass
m
l
a
->
OptimizationFuel
->
Graph
m
l
->
a
->
DFM
a
(
OptimizationFuel
,
a
,
Graph
m
l
)
solve_and_rewrite_f_graph
comp
fuel
graph
in_fact
=
do
g
<-
lgraphOfGraph
graph
(
fuel
,
a
,
g'
)
<-
solve_and_rewrite_f
comp
fuel
g
in_fact
return
(
fuel
,
a
,
remove_entry_label
g'
)
forward_rewrite
::
(
DebugNodes
m
l
,
Outputable
a
)
=>
FPass
m
l
a
->
OptimizationFuel
->
G
.
LGraph
m
l
->
a
->
...
...
@@ -715,9 +757,9 @@ forward_rewrite comp fuel graph entry_fact =
first_out
<-
fc_first_out
comp
id_fact
id
fuel
case
first_out
of
Dataflow
a
->
propagate
fuel
(
G
.
ZFirst
id
)
a
t
rewritten
bs
Rewrite
f
g
->
do
{
markGraphRewritten
Rewrite
g
->
do
{
markGraphRewritten
;
rewrite_blocks
(
fuel
-
1
)
rewritten
(
G
.
postorder_dfs
(
labelGraph
id
f
g
)
++
bs
)
}
(
G
.
postorder_dfs
(
labelGraph
id
g
)
++
bs
)
}
-- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
-- [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
propagate
fuel
h
in'
(
G
.
ZTail
m
t
)
rewritten
bs
=
...
...
@@ -725,13 +767,10 @@ forward_rewrite comp fuel graph entry_fact =
do
fc_middle_out
comp
in'
m
fuel
>>=
\
x
->
case
x
of
Dataflow
a
->
propagate
fuel
(
G
.
ZHead
h
m
)
a
t
rewritten
bs
Rewrite
g
->
my_trace
"Rewriting middle node...
\n
"
empty
$
do
g
<-
lgraphOfGraph
g
(
fuel
,
a
,
g
)
<-
solve_and_rewrite_f
comp
(
fuel
-
1
)
g
in'
markGraphRewritten
my_trace
"Rewrite of middle node completed
\n
"
empty
$
let
(
g'
,
h'
)
=
G
.
splice_head
h
g
in
propagate
fuel
h'
a
t
(
plusUFM
(
G
.
lg_blocks
g'
)
rewritten
)
bs
do
markGraphRewritten
(
fuel
,
a
,
g
)
<-
solve_and_rewrite_f_graph
comp
(
fuel
-
1
)
g
in'
let
(
blocks
,
h'
)
=
G
.
splice_head'
h
g
propagate
fuel
h'
a
t
(
blocks
`
plusUFM
`
rewritten
)
bs
propagate
fuel
h
in'
(
G
.
ZLast
l
)
rewritten
bs
=
do
last_outs
comp
in'
l
fuel
>>=
\
x
->
case
x
of
Dataflow
outs
->
...
...
@@ -739,15 +778,10 @@ forward_rewrite comp fuel graph entry_fact =
let
b
=
G
.
zip
(
G
.
ZBlock
h
(
G
.
ZLast
l
))
rewrite_blocks
fuel
(
G
.
insertBlock
b
rewritten
)
bs
Rewrite
g
->
-- could test here that [[exits g = exits (G.Entry, G.ZLast l)]]
{- if Debug.on "rewrite-last" then
Printf.eprintf "ZLast node %s rewritten to:\n"
(RS.rtl (G.last_instr l)); -}
do
g
<-
lgraphOfGraph
g
(
fuel
,
_
,
g
)
<-
solve_and_rewrite_f
comp
(
fuel
-
1
)
g
in'
markGraphRewritten
let
g'
=
G
.
splice_head_only
h
g
rewrite_blocks
fuel
(
plusUFM
(
G
.
lg_blocks
g'
)
rewritten
)
bs
do
markGraphRewritten
(
fuel
,
_
,
g
)
<-
solve_and_rewrite_f_graph
comp
(
fuel
-
1
)
g
in'
let
g'
=
G
.
splice_head_only'
h
g
rewrite_blocks
fuel
(
G
.
lg_blocks
g'
`
plusUFM
`
rewritten
)
bs
f_rewrite
comp
entry_fact
g
=
do
{
fuel
<-
liftTx
txRemaining
...
...
@@ -807,22 +841,6 @@ a_t_f anal tx =
,
fc_first_out
=
first_out
,
fc_exit_outs
=
exit_outs
}
{- Note [Rewriting labelled LGraphs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's hugely annoying that we get in an LGraph and in order to solve it
we have to slap on a new label which we then immediately strip off.
But the alternative is to have all the iterative solvers work on
Graphs, and then suddenly instead of a single case (ZBlock) every
solver has to deal with two cases (ZBlock and ZTail). So until
somebody comes along who is smart enough to do this and still leave
the code understandable for mortals, it stays as it is.
(A good place to start changing things would be to figure out what is
the analogue of postorder_dfs for Graphs, and to figure out what
higher-order functions would do for dealing with the resulting
sequences of *things*.)
-}
f4sep
::
[
SDoc
]
->
SDoc
f4sep
[]
=
fsep
[]
f4sep
(
d
:
ds
)
=
fsep
(
d
:
map
(
nest
4
)
ds
)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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