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
081b86a6
Commit
081b86a6
authored
Sep 11, 2007
by
nr@eecs.harvard.edu
Browse files
renaming, reorganizing, and better doco for ZipCfg
parent
90dc6993
Changes
5
Expand all
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmCvt.hs
View file @
081b86a6
...
...
@@ -78,7 +78,7 @@ ofZgraph g = ListGraph $ swallow blocks
mid
m
@
(
CopyIn
{})
=
pcomment
(
ppr
m
<+>
text
"(proc point)"
)
pcomment
p
=
scomment
$
showSDoc
p
block'
id
prev'
|
id
==
G
.
g
r
_entry
g
=
BasicBlock
id
$
extend_entry
(
reverse
prev'
)
|
id
==
G
.
l
g_entry
g
=
BasicBlock
id
$
extend_entry
(
reverse
prev'
)
|
otherwise
=
BasicBlock
id
$
extend_block
id
(
reverse
prev'
)
last
id
prev'
l
n
=
let
endblock
stmt
=
block'
id
(
stmt
:
prev'
)
:
swallow
n
in
...
...
compiler/cmm/CmmProcPointZ.hs
View file @
081b86a6
...
...
@@ -122,7 +122,7 @@ forward = FComp "proc-point reachability" first middle last exit
minimalProcPointSet
::
CmmGraph
->
ProcPointSet
minimalProcPointSet
g
=
extendPPSet
g
(
postorder_dfs
g
)
entryPoint
where
entryPoint
=
unitUniqSet
(
g
r
_entry
g
)
where
entryPoint
=
unitUniqSet
(
l
g_entry
g
)
extendPPSet
::
CmmGraph
->
[
CmmBlock
]
->
ProcPointSet
->
ProcPointSet
extendPPSet
g
blocks
procPoints
=
...
...
@@ -217,7 +217,7 @@ addProcPointProtocols procPoints formals g =
where
optimize_calls
g
=
-- see Note [Separate Adams optimization]
let
(
protos
,
blocks'
)
=
fold_blocks
maybe_add_call
(
init_protocols
,
emptyBlockEnv
)
g
g'
=
LGraph
(
g
r
_entry
g
)
(
add_CopyIns
protos
blocks'
)
g'
=
LGraph
(
l
g_entry
g
)
(
add_CopyIns
protos
blocks'
)
in
(
protos
,
runTx
removeUnreachableBlocksZ
g'
)
maybe_add_call
::
CmmBlock
->
(
BlockEnv
Protocol
,
BlockEnv
CmmBlock
)
->
(
BlockEnv
Protocol
,
BlockEnv
CmmBlock
)
...
...
@@ -243,7 +243,7 @@ addProcPointProtocols procPoints formals g =
jumpsToProcPoint
::
BlockId
->
Maybe
BlockId
-- ^ Tells whether the named block is just a jump to a proc point
jumpsToProcPoint
id
=
let
(
Block
_
t
)
=
lookupBlockEnv
(
g
r
_blocks
g
)
id
`
orElse
`
let
(
Block
_
t
)
=
lookupBlockEnv
(
l
g_blocks
g
)
id
`
orElse
`
panic
"jump out of graph"
in
case
t
of
ZTail
(
CopyIn
{})
(
ZLast
(
LastOther
(
LastBranch
pee
[]
)))
...
...
@@ -253,7 +253,7 @@ addProcPointProtocols procPoints formals g =
maybe_add_proto
::
CmmBlock
->
BlockEnv
Protocol
->
BlockEnv
Protocol
maybe_add_proto
(
Block
id
(
ZTail
(
CopyIn
c
fs
_srt
)
_
))
env
=
extendBlockEnv
env
id
(
Protocol
c
fs
)
maybe_add_proto
(
Block
id
_
)
env
|
id
==
g
r
_entry
g
=
maybe_add_proto
(
Block
id
_
)
env
|
id
==
l
g_entry
g
=
extendBlockEnv
env
id
(
Protocol
(
Argument
CmmCallConv
)
hinted_formals
)
maybe_add_proto
_
env
=
env
hinted_formals
=
map
(
\
x
->
(
x
,
NoHint
))
formals
...
...
@@ -280,7 +280,7 @@ pass_live_vars_as_args procPoints (protos, g) = (protos', g')
-- panic ("no liveness at block " ++ show id)
formals
=
map
(
\
x
->
(
x
,
NoHint
))
$
uniqSetToList
live
in
extendBlockEnv
protos
id
(
Protocol
Local
formals
)
g'
=
g
{
g
r
_blocks
=
add_CopyIns
protos'
(
g
r
_blocks
g
)
}
g'
=
g
{
l
g_blocks
=
add_CopyIns
protos'
(
l
g_blocks
g
)
}
-- | Add a CopyIn node to each block that has a protocol but lacks the
...
...
compiler/cmm/PprCmmZ.hs
View file @
081b86a6
...
...
@@ -31,7 +31,7 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
mid
m
@
(
G
.
CopyIn
{})
=
ppr
m
<+>
text
"(proc point)"
mid
m
=
ppr
m
block'
id
prev'
|
id
==
Z
.
g
r
_entry
g
,
entry_has_no_pred
=
|
id
==
Z
.
l
g_entry
g
,
entry_has_no_pred
=
vcat
(
text
"<entry>"
:
reverse
prev'
)
|
otherwise
=
hang
(
ppr
id
<>
colon
)
4
(
vcat
(
reverse
prev'
))
last
id
prev'
l
n
=
...
...
@@ -88,7 +88,7 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
endblock (ppr $ CmmBranch id')
-}
preds
=
zipPreds
g
entry_has_no_pred
=
case
Z
.
lookupBlockEnv
preds
(
Z
.
g
r
_entry
g
)
of
entry_has_no_pred
=
case
Z
.
lookupBlockEnv
preds
(
Z
.
l
g_entry
g
)
of
Nothing
->
True
Just
s
->
isEmptyUniqSet
s
single_preds
=
...
...
compiler/cmm/ZipCfg.hs
View file @
081b86a6
This diff is collapsed.
Click to expand it.
compiler/cmm/ZipDataflow.hs
View file @
081b86a6
...
...
@@ -393,7 +393,7 @@ solve_graph_b comp fuel graph exit_fact =
in
do
{
fuel
<-
run
"backward"
(
bc_name
comp
)
(
return
()
)
set_block_fact
fuel
blocks
;
a
<-
getFact
(
G
.
g
r
_entry
graph
)
;
a
<-
getFact
(
G
.
l
g_entry
graph
)
;
facts
<-
allFacts
;
my_trace
"Solution to graph after pass 1 is"
(
pprFacts
graph
facts
a
)
$
return
(
fuel
,
a
)
}
...
...
@@ -438,7 +438,7 @@ solve_and_rewrite_b comp fuel graph exit_fact =
where
pprFacts
g
env
=
vcat
(
pprLgraph
g
:
map
pprFact
(
ufmToList
env
))
pprFact
(
id
,
a
)
=
hang
(
ppr
id
<>
colon
)
4
(
ppr
a
)
eid
=
G
.
g
r
_entry
graph
eid
=
G
.
l
g_entry
graph
backward_rewrite
comp
fuel
graph
=
rewrite_blocks
comp
fuel
emptyBlockEnv
$
reverse
(
G
.
postorder_dfs
graph
)
-- rewrite_blocks ::
...
...
@@ -470,7 +470,7 @@ solve_and_rewrite_b comp fuel graph exit_fact =
;
(
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
.
g
r
_blocks
g''
)
rewritten
;
let
rewritten'
=
plusUFM
(
G
.
l
g_blocks
g''
)
rewritten
;
my_trace
"Rewrote middle node"
(
f4sep
[
ppr
m
,
text
"to"
,
ppr
g
])
$
propagate
fuel
h
a
t
rewritten'
}
propagate
fuel
h
@
(
G
.
ZFirst
id
)
out
tail
rewritten
=
...
...
@@ -484,7 +484,7 @@ solve_and_rewrite_b comp fuel graph exit_fact =
;
(
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
.
g
r
_blocks
g''
)
rewritten
;
let
rewritten'
=
plusUFM
(
G
.
l
g_blocks
g''
)
rewritten
;
my_trace
"Rewrote label "
(
f4sep
[
ppr
id
,
text
"to"
,
ppr
g
])
$
propagate
fuel
h
a
t
rewritten'
}
in
rewrite_next_block
fuel
...
...
@@ -583,7 +583,7 @@ my_trace :: String -> SDoc -> a -> a
my_trace
=
if
dump_things
then
pprTrace
else
\
_
_
a
->
a
run_f_anal
comp
entry_fact
graph
=
refine_f_anal
comp
graph
set_entry
where
set_entry
=
setFact
(
G
.
g
r
_entry
graph
)
entry_fact
where
set_entry
=
setFact
(
G
.
l
g_entry
graph
)
entry_fact
refine_f_anal
comp
graph
initial
=
run
"forward"
(
fc_name
comp
)
initial
set_successor_facts
()
blocks
...
...
@@ -591,7 +591,7 @@ refine_f_anal comp graph initial =
set_successor_facts
()
(
G
.
Block
id
t
)
=
let
forward
in'
(
G
.
ZTail
m
t
)
=
forward
(
fc_middle_out
comp
in'
m
)
t
forward
in'
(
G
.
ZLast
l
)
=
setEdgeFacts
(
last_outs
comp
in'
l
)
_blockname
=
if
id
==
G
.
g
r
_entry
graph
then
"<entry>"
else
show
id
_blockname
=
if
id
==
G
.
l
g_entry
graph
then
"<entry>"
else
show
id
in
getFact
id
>>=
\
a
->
forward
(
fc_first_out
comp
a
id
)
t
setEdgeFacts
(
LastOutFacts
fs
)
=
mapM_
setEdgeFact
fs
setEdgeFact
(
id
,
a
)
=
setFact
id
a
...
...
@@ -626,12 +626,12 @@ solve_graph_f comp fuel g in_fact =
-- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
general_forward
comp
fuel
entry_fact
graph
=
let
blocks
=
G
.
postorder_dfs
g
is_local
id
=
isJust
$
lookupBlockEnv
(
G
.
g
r
_blocks
g
)
id
is_local
id
=
isJust
$
lookupBlockEnv
(
G
.
l
g_blocks
g
)
id
-- set_or_save :: LastOutFacts a -> DFM a ()
set_or_save
(
LastOutFacts
l
)
=
mapM_
set_or_save_one
l
set_or_save_one
(
id
,
a
)
=
if
is_local
id
then
setFact
id
a
else
addLastOutFact
(
id
,
a
)
set_entry
=
setFact
(
G
.
g
r
_entry
graph
)
entry_fact
set_entry
=
setFact
(
G
.
l
g_entry
graph
)
entry_fact
set_successor_facts
fuel
b
=
let
set_tail_facts
fuel
in'
(
G
.
ZTail
m
t
)
=
...
...
@@ -695,8 +695,8 @@ forward_rewrite comp fuel graph entry_fact =
do
setFact
eid
entry_fact
rewrite_blocks
fuel
emptyBlockEnv
(
G
.
postorder_dfs
graph
)
where
eid
=
G
.
g
r
_entry
graph
is_local
id
=
isJust
$
lookupBlockEnv
(
G
.
g
r
_blocks
graph
)
id
eid
=
G
.
l
g_entry
graph
is_local
id
=
isJust
$
lookupBlockEnv
(
G
.
l
g_blocks
graph
)
id
-- set_or_save :: LastOutFacts a -> DFM a ()
set_or_save
(
LastOutFacts
l
)
=
mapM_
set_or_save_one
l
set_or_save_one
(
id
,
a
)
=
...
...
@@ -727,7 +727,7 @@ forward_rewrite comp fuel graph entry_fact =
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
.
g
r
_blocks
g'
)
rewritten
)
bs
propagate
fuel
h'
a
t
(
plusUFM
(
G
.
l
g_blocks
g'
)
rewritten
)
bs
propagate
fuel
h
in'
(
G
.
ZLast
l
)
rewritten
bs
=
do
last_outs
comp
in'
l
fuel
>>=
\
x
->
case
x
of
Dataflow
outs
->
...
...
@@ -743,7 +743,7 @@ forward_rewrite comp fuel graph entry_fact =
(
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
.
g
r
_blocks
g'
)
rewritten
)
bs
rewrite_blocks
fuel
(
plusUFM
(
G
.
l
g_blocks
g'
)
rewritten
)
bs
f_rewrite
comp
entry_fact
g
=
do
{
fuel
<-
liftTx
txRemaining
...
...
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