Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
46b03136
Commit
46b03136
authored
Jan 17, 2012
by
Simon Marlow
Browse files
Snapshot
parent
919a298f
Changes
17
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmBuildInfoTables.hs
View file @
46b03136
...
...
@@ -55,7 +55,7 @@ import Platform
import
SMRep
import
UniqSupply
import
Compiler.
Hoopl
import
Hoopl
import
Data.Map
(
Map
)
import
qualified
Data.Map
as
Map
...
...
@@ -216,7 +216,7 @@ cafTransfers platform = mkBTransfer3 first middle last
cafAnal
::
Platform
->
CmmGraph
->
FuelUniqSM
CAFEnv
cafAnal
platform
g
=
liftM
snd
$
dataflow
Pass
Bwd
g
[]
$
analBwd
cafLattice
(
cafTransfers
platform
)
=
dataflow
Anal
Bwd
g
[]
$
analBwd
cafLattice
(
cafTransfers
platform
)
-----------------------------------------------------------------------
-- Building the SRTs
...
...
compiler/cmm/CmmCommonBlockElim.hs
View file @
46b03136
...
...
@@ -13,17 +13,16 @@ where
import
BlockId
import
Cmm
import
CmmUtils
import
CmmContFlowOpt
import
Prelude
hiding
(
iterate
,
succ
,
unzip
,
zip
)
import
Compiler.Hoopl
import
Hoopl
hiding
(
ChangeFlag
)
import
Data.Bits
import
qualified
Data.List
as
List
import
Data.Word
import
FastString
import
Control.Monad
import
Outputable
import
UniqFM
import
Unique
my_trace
::
String
->
SDoc
->
a
->
a
my_trace
=
if
False
then
pprTrace
else
\
_
_
a
->
a
...
...
@@ -71,7 +70,7 @@ common_block (old_change, bmap, subst) (hash, b) =
(
Just
b'
,
Nothing
)
->
addSubst
b'
(
Just
b'
,
Just
b''
)
|
entryLabel
b'
/=
b''
->
addSubst
b'
_
->
(
old_change
,
addToUFM
bmap
hash
(
b
:
bs
),
subst
)
Nothing
->
(
old_change
,
(
addToUFM
bmap
hash
[
b
],
subst
)
)
Nothing
->
(
old_change
,
addToUFM
bmap
hash
[
b
],
subst
)
where
bid
=
entryLabel
b
addSubst
b'
=
my_trace
"found new common block"
(
ppr
(
entryLabel
b'
))
$
(
True
,
bmap
,
mapInsert
bid
(
entryLabel
b'
)
subst
)
...
...
@@ -142,11 +141,13 @@ lookupBid subst bid = case mapLookup bid subst of
Just
bid
->
lookupBid
subst
bid
Nothing
->
bid
-- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
-- Equality on the body of a block, modulo a function mapping block
-- IDs to block IDs.
eqBlockBodyWith
::
(
BlockId
->
BlockId
->
Bool
)
->
CmmBlock
->
CmmBlock
->
Bool
eqBlockBodyWith
eqBid
block
block'
=
middles
==
middles'
&&
eqLastWith
eqBid
last
last'
where
(
_
,
middles
,
JustC
last
::
MaybeC
C
(
CmmNode
O
C
))
=
blockToNodeList
block
(
_
,
middles'
,
JustC
last'
::
MaybeC
C
(
CmmNode
O
C
))
=
blockToNodeList
block'
eqBlockBodyWith
eqBid
block
block'
=
blockToList
m
==
blockToList
m'
&&
eqLastWith
eqBid
l
l'
where
(
_
,
m
,
l
)
=
blockSplit
block
(
_
,
m'
,
l'
)
=
blockSplit
block'
eqLastWith
::
(
BlockId
->
BlockId
->
Bool
)
->
CmmNode
O
C
->
CmmNode
O
C
->
Bool
eqLastWith
eqBid
(
CmmBranch
bid1
)
(
CmmBranch
bid2
)
=
eqBid
bid1
bid2
...
...
compiler/cmm/CmmContFlowOpt.hs
View file @
46b03136
...
...
@@ -3,7 +3,7 @@
module
CmmContFlowOpt
(
cmmCfgOpts
,
runCmmContFlowOpts
,
cmmCfgOptsProc
,
removeUnreachableBlocks
,
replaceLabels
)
...
...
@@ -16,9 +16,10 @@ import Digraph
import
Maybes
import
Outputable
import
Compiler.
Hoopl
import
Hoopl
import
Control.Monad
import
Prelude
hiding
(
succ
,
unzip
,
zip
)
import
qualified
Data.IntMap
as
Map
-----------------------------------------------------------------------------
--
...
...
@@ -26,12 +27,12 @@ import Prelude hiding (succ, unzip, zip)
--
-----------------------------------------------------------------------------
runCmmContFlowOpts
::
CmmGroup
->
CmmGroup
runCmmContFlowOpts
=
map
(
optProc
cmmCfgOpts
)
cmmCfgOpts
::
CmmGraph
->
CmmGraph
cmmCfgOpts
=
removeUnreachableBlocks
.
blockConcat
cmmCfgOptsProc
::
CmmDecl
->
CmmDecl
cmmCfgOptsProc
=
optProc
cmmCfgOpts
optProc
::
(
g
->
g
)
->
GenCmmDecl
d
h
g
->
GenCmmDecl
d
h
g
optProc
opt
(
CmmProc
info
lbl
g
)
=
CmmProc
info
lbl
(
opt
g
)
optProc
_
top
=
top
...
...
@@ -99,22 +100,22 @@ blockConcat g@CmmGraph { g_entry = entry_id }
maybe_concat
::
CmmBlock
->
(
BlockEnv
CmmBlock
,
BlockEnv
BlockId
)
->
(
BlockEnv
CmmBlock
,
BlockEnv
BlockId
)
maybe_concat
block
unchanged
@
(
blocks
,
shortcut_map
)
=
maybe_concat
block
unchanged
@
(
blocks
,
shortcut_map
)
|
CmmBranch
b'
<-
last
,
Just
blk'
<-
mapLookup
b'
blocks
,
shouldConcatWith
b'
bl
ocks
->
(
mapInsert
bid
(
splice
head
blk'
)
blocks
,
shortcut_map
)
,
shouldConcatWith
b'
bl
k'
=
(
mapInsert
bid
(
splice
head
blk'
)
blocks
,
shortcut_map
)
|
Just
b'
<-
callContinuation_maybe
last
,
Just
blk'
<-
mapLookup
b'
blocks
,
Just
dest
<-
canShortcut
b'
blk'
->
(
blocks
,
mapInsert
b'
dest
shortcut_map
)
,
Just
dest
<-
canShortcut
blk'
=
(
blocks
,
mapInsert
b'
dest
shortcut_map
)
-- replaceLabels will substitute dest for b' everywhere, later
|
otherwise
=
unchanged
where
(
head
,
last
)
=
blockTail
block
bid
=
entryLabel
b
(
head
,
last
)
=
block
Split
Tail
block
bid
=
entryLabel
b
lock
shouldConcatWith
b
block
|
num_preds
b
==
1
=
True
-- only one predecessor: go for it
...
...
@@ -122,20 +123,20 @@ blockConcat g@CmmGraph { g_entry = entry_id }
|
otherwise
=
False
where
num_preds
bid
=
mapLookup
bid
backEdges
`
orElse
`
0
canShortcut
::
Block
C
C
->
Maybe
BlockId
canShortcut
::
Cmm
Block
->
Maybe
BlockId
canShortcut
block
|
(
_
,
middle
,
CmmBranch
dest
)
<-
block
HeadTail
block
|
(
_
,
middle
,
CmmBranch
dest
)
<-
block
Split
block
,
isEmptyBlock
middle
=
Just
dest
|
otherwise
=
Nothing
backEdges
::
BlockEnv
Int
-- number of predecessors for each block
backEdges
=
map
Map
setSize
$
predMap
blocks
ToDo
:
add
1
for
the
entry
id
backEdges
=
map
InsertWith
(
+
)
entry_id
1
$
-- add 1 for the entry id
mapMap
setSize
$
predMap
blocks
splice
::
Block
CmmNode
C
O
->
CmmBlock
->
CmmBlock
splice
head
rest
=
head
`
cat
`
snd
(
blockHead
rest
)
splice
head
rest
=
head
`
blockAppend
`
snd
(
block
Split
Head
rest
)
callContinuation_maybe
::
CmmNode
O
C
->
Maybe
BlockId
...
...
@@ -143,9 +144,9 @@ callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
callContinuation_maybe
(
CmmForeignCall
{
succ
=
b
})
=
Just
b
callContinuation_maybe
_
=
Nothing
okToDuplicate
::
Block
C
C
->
Bool
okToDuplicate
::
Cmm
Block
->
Bool
okToDuplicate
block
=
case
block
ToNodeLis
t
block
of
(
_
,
m
,
_
)
->
null
m
=
case
block
Spli
t
block
of
(
_
,
m
,
_
)
->
isEmptyBlock
m
-- cheap and cheerful; we might expand this in the future to
-- e.g. spot blocks that represent a single instruction or two
...
...
@@ -155,8 +156,8 @@ okToDuplicate block
replaceLabels
::
BlockEnv
BlockId
->
CmmGraph
->
CmmGraph
replaceLabels
env
g
|
isEmptyMap
env
=
g
|
otherwise
=
replace_eid
.
mapGraphNodes1
txnode
|
mapNull
env
=
g
|
otherwise
=
replace_eid
$
mapGraphNodes1
txnode
g
where
replace_eid
g
=
g
{
g_entry
=
lookup
(
g_entry
g
)}
lookup
id
=
mapLookup
id
env
`
orElse
`
id
...
...
@@ -175,7 +176,7 @@ replaceLabels env g
exp
(
CmmStackSlot
(
CallArea
(
Young
id
))
i
)
=
CmmStackSlot
(
CallArea
(
Young
(
lookup
id
)))
i
exp
e
=
e
mkCmmCondBranch
::
CmmExpr
->
CmmExpr
->
CmmExpr
->
CmmExpr
mkCmmCondBranch
::
CmmExpr
->
Label
->
Label
->
CmmNode
O
C
mkCmmCondBranch
p
t
f
=
if
t
==
f
then
CmmBranch
t
else
CmmCondBranch
p
t
f
----------------------------------------------------------------
...
...
@@ -191,8 +192,6 @@ predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
-----------------------------------------------------------------------------
--
-- Removing unreachable blocks
--
-----------------------------------------------------------------------------
removeUnreachableBlocks
::
CmmGraph
->
CmmGraph
removeUnreachableBlocks
g
...
...
compiler/cmm/CmmCvt.hs
View file @
46b03136
...
...
@@ -12,7 +12,7 @@ import CmmUtils
import
qualified
OldCmm
as
Old
import
OldPprCmm
()
import
Compiler.
Hoopl
hiding
((
<*>
),
mkLabel
,
mkBranch
)
import
Hoopl
hiding
((
<*>
),
mkLabel
,
mkBranch
)
import
Data.Maybe
import
Maybes
import
Outputable
...
...
compiler/cmm/CmmLint.hs
View file @
46b03136
...
...
@@ -11,9 +11,10 @@ module CmmLint (
)
where
import
Cmm
import
Outputable
cmmLint
::
CmmGraph
->
IO
()
cmmLint
g
=
pprTrace
"ToDo! CmmLint"
return
()
cmmLint
g
=
return
()
-- TODO!!
-- Things to check:
-- - invariant on CmmBlock in CmmExpr (see comment there)
...
...
compiler/cmm/CmmLive.hs
View file @
46b03136
...
...
@@ -18,7 +18,7 @@ import Control.Monad
import
OptimizationFuel
import
PprCmmExpr
()
import
Compiler.
Hoopl
import
Hoopl
import
Maybes
import
Outputable
import
UniqSet
...
...
@@ -45,7 +45,7 @@ type BlockEntryLiveness = BlockEnv CmmLive
cmmLiveness
::
CmmGraph
->
FuelUniqSM
BlockEntryLiveness
cmmLiveness
graph
=
liftM
check
$
liftM
snd
$
dataflow
Pass
Bwd
graph
[]
$
analBwd
liveLattice
xferLive
liftM
check
$
dataflow
Anal
Bwd
graph
[]
$
analBwd
liveLattice
xferLive
where
entry
=
g_entry
graph
check
facts
=
noLiveOnEntry
entry
(
expectJust
"check"
$
mapLookup
entry
facts
)
facts
...
...
compiler/cmm/CmmPipeline.hs
View file @
46b03136
...
...
@@ -11,6 +11,7 @@ module CmmPipeline (
import
CLabel
import
Cmm
import
CmmLint
import
CmmLive
import
CmmBuildInfoTables
import
CmmCommonBlockElim
...
...
@@ -74,10 +75,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
dumpIfSet_dyn
dflags
Opt_D_dump_cps_cmm
"Post CPS Cmm"
(
pprPlatform
(
targetPlatform
dflags
)
cmms
)
-- SRT is not affected by control flow optimization pass
let
prog'
=
runCmmContFlowOpts
cmms
return
(
topSRT
,
prog'
:
rst
)
return
(
topSRT
,
cmms
:
rst
)
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
...
...
@@ -98,86 +96,91 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- insertLateReloads, rewriteAssignments?
----------- Control-flow optimisations ---------------
g
<-
return
$
cmmCfgOpts
g
g
<-
{-# SCC "cmmCfgOpts(1)" #-}
return
$
cmmCfgOpts
g
dump
Opt_D_dump_cmmz_cfg
"Post control-flow optimsations"
g
----------- Eliminate common blocks -------------------
g
<-
return
$
elimCommonBlocks
g
g
<-
{-# SCC "elimCommonBlocks" #-}
return
$
elimCommonBlocks
g
dump
Opt_D_dump_cmmz_cbe
"Post common block elimination"
g
-- Any work storing block Labels must be performed _after_
-- elimCommonBlocks
----------- Proc points -------------------
let
callPPs
=
callProcPoints
g
procPoints
<-
run
$
minimalProcPointSet
(
targetPlatform
dflags
)
callPPs
g
g
<-
run
$
addProcPointProtocols
callPPs
procPoints
g
let
callPPs
=
{-# SCC "callProcPoints" #-}
callProcPoints
g
procPoints
<-
{-# SCC "minimalProcPointSet" #-}
run
$
minimalProcPointSet
(
targetPlatform
dflags
)
callPPs
g
g
<-
{-# SCC "addProcPointProtocols" #-}
run
$
addProcPointProtocols
callPPs
procPoints
g
dump
Opt_D_dump_cmmz_proc
"Post Proc Points Added"
g
----------- Spills and reloads -------------------
g
<-
run
$
dualLivenessWithInsertion
procPoints
g
g
<-
{-# SCC "dualLivenessWithInsertion" #-}
run
$
dualLivenessWithInsertion
procPoints
g
dump
Opt_D_dump_cmmz_spills
"Post spills and reloads"
g
----------- Sink and inline assignments -------------------
g
<-
runOptimization
$
rewriteAssignments
platform
g
g
<-
{-# SCC "rewriteAssignments" #-}
runOptimization
$
rewriteAssignments
platform
g
dump
Opt_D_dump_cmmz_rewrite
"Post rewrite assignments"
g
----------- Eliminate dead assignments -------------------
g
<-
runOptimization
$
removeDeadAssignments
g
g
<-
{-# SCC "removeDeadAssignments" #-}
runOptimization
$
removeDeadAssignments
g
dump
Opt_D_dump_cmmz_dead
"Post remove dead assignments"
g
----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early
g
<-
if
opt_StubDeadValues
then
run
$
stubSlotsOnDeath
g
then
{-# SCC "stubSlotsOnDeath" #-}
run
$
stubSlotsOnDeath
g
else
return
g
dump
Opt_D_dump_cmmz_stub
"Post stub dead stack slots"
g
--------------- Stack layout ----------------
slotEnv
<-
run
$
liveSlotAnal
g
slotEnv
<-
{-# SCC "liveSlotAnal" #-}
run
$
liveSlotAnal
g
let
spEntryMap
=
getSpEntryMap
entry_off
g
mbpprTrace
"live slot analysis results: "
(
ppr
slotEnv
)
$
return
()
let
areaMap
=
layout
procPoints
spEntryMap
slotEnv
entry_off
g
let
areaMap
=
{-# SCC "layout" #-}
layout
procPoints
spEntryMap
slotEnv
entry_off
g
mbpprTrace
"areaMap"
(
ppr
areaMap
)
$
return
()
------------ Manifest the stack pointer --------
g
<-
run
$
manifestSP
spEntryMap
areaMap
entry_off
g
g
<-
{-# SCC "manifestSP" #-}
run
$
manifestSP
spEntryMap
areaMap
entry_off
g
dump
Opt_D_dump_cmmz_sp
"Post manifestSP"
g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------
procPointMap
<-
run
$
procPointAnalysis
procPoints
g
dumpWith
ppr
Opt_D_dump_cmmz_procmap
"procpoint map"
procPointMap
gs
<-
run
$
splitAtProcPoints
l
callPPs
procPoints
procPointMap
procPointMap
<-
{-# SCC "procPointAnalysis" #-}
run
$
procPointAnalysis
procPoints
g
dumpWith
dflags
ppr
Opt_D_dump_cmmz_procmap
"procpoint map"
procPointMap
gs
<-
{-# SCC "splitAtProcPoints" #-}
run
$
splitAtProcPoints
l
callPPs
procPoints
procPointMap
(
CmmProc
h
l
g
)
mapM_
(
dump
Opt_D_dump_cmmz_split
"Post splitting"
)
gs
dump
s
Opt_D_dump_cmmz_split
"Post splitting"
gs
------------- More CAFs and foreign calls ------------
cafEnv
<-
run
$
cafAnal
platform
g
cafEnv
<-
{-# SCC "cafAnal" #-}
run
$
cafAnal
platform
g
let
localCAFs
=
catMaybes
$
map
(
localCAFInfo
platform
cafEnv
)
gs
mbpprTrace
"localCAFs"
(
pprPlatform
platform
localCAFs
)
$
return
()
gs
<-
run
$
mapM
(
lowerSafeForeignCalls
areaMap
)
gs
mapM_
(
dump
Opt_D_dump_cmmz_lower
"Post lowerSafeForeignCalls"
)
gs
gs
<-
{-# SCC "lowerSafeForeignCalls" #-}
run
$
mapM
(
lowerSafeForeignCalls
areaMap
)
gs
dump
s
Opt_D_dump_cmmz_lower
"Post lowerSafeForeignCalls"
gs
----------- Control-flow optimisations ---------------
gs
<-
return
$
map
cmmCfgOpts
gs
mapM_
(
dump
Opt_D_dump_cmmz_cfg
"Post control-flow optimsations"
)
gs
gs
<-
{-# SCC "cmmCfgOpts(2)" #-}
return
$
map
cmmCfgOpts
Proc
gs
dump
s
Opt_D_dump_cmmz_cfg
"Post control-flow optimsations"
gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs
<-
return
$
map
(
setInfoTableStackMap
slotEnv
areaMap
)
gs
mapM_
(
dump
Opt_D_dump_cmmz_info
"after setInfoTableStackMap"
)
gs
gs
<-
return
$
map
(
bundleCAFs
cafEnv
)
gs
mapM_
(
dump
Opt_D_dump_cmmz_cafs
"after bundleCAFs"
)
gs
gs
<-
{-# SCC "setInfoTableStackMap" #-}
return
$
map
(
setInfoTableStackMap
slotEnv
areaMap
)
gs
dump
s
Opt_D_dump_cmmz_info
"after setInfoTableStackMap"
gs
gs
<-
{-# SCC "bundleCAFs" #-}
return
$
map
(
bundleCAFs
cafEnv
)
gs
dump
s
Opt_D_dump_cmmz_cafs
"after bundleCAFs"
gs
return
(
localCAFs
,
gs
)
-- gs :: [ (CAFSet, CmmDecl) ]
-- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
where
dflags
=
hsc_dflags
hsc_env
mbpprTrace
x
y
z
=
if
dopt
Opt_D_dump_cmmz
dflags
then
pprTrace
x
y
z
else
z
platform
=
targetPlatform
dflags
mbpprTrace
x
y
z
|
dopt
Opt_D_dump_cmmz
dflags
=
pprTrace
x
y
z
|
otherwise
=
z
dump
=
dumpGraph
dflags
dumps
flag
name
=
mapM_
(
dumpWith
dflags
(
pprPlatform
platform
)
flag
name
)
-- Runs a required transformation/analysis
run
=
runInfiniteFuelIO
(
hsc_OptFuel
hsc_env
)
-- Runs an optional transformation/analysis (and should
...
...
@@ -185,20 +188,19 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
runOptimization
=
runFuelIO
(
hsc_OptFuel
hsc_env
)
dumpGraph
::
DynFlags
->
DynFlag
->
CmmGraph
->
IO
()
dumpGraph
dflags
flag
g
=
do
dumpGraph
::
DynFlags
->
DynFlag
->
String
->
CmmGraph
->
IO
()
dumpGraph
dflags
flag
name
g
=
do
cmmLint
g
dumpWith
(
pprPlatform
platform
)
where
platform
=
targetPlatform
dflags
dumpWith
pprFun
flag
txt
g
=
do
-- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely
-- with -ddump-to-file, since the headers get omitted.
dumpIfSet_dyn
dflags
flag
txt
(
pprFun
g
)
when
(
not
(
dopt
flag
dflags
))
$
dumpIfSet_dyn
dflags
Opt_D_dump_cmmz
txt
(
pprFun
g
)
dumpWith
dflags
(
pprPlatform
(
targetPlatform
dflags
))
flag
name
g
dumpWith
::
DynFlags
->
(
a
->
SDoc
)
->
DynFlag
->
String
->
a
->
IO
()
dumpWith
dflags
pprFun
flag
txt
g
=
do
-- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely
-- with -ddump-to-file, since the headers get omitted.
dumpIfSet_dyn
dflags
flag
txt
(
pprFun
g
)
when
(
not
(
dopt
flag
dflags
))
$
dumpIfSet_dyn
dflags
Opt_D_dump_cmmz
txt
(
pprFun
g
)
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
...
...
compiler/cmm/CmmProcPoint.hs
View file @
46b03136
...
...
@@ -28,7 +28,7 @@ import Platform
import
UniqSet
import
UniqSupply
import
Compiler.
Hoopl
import
Hoopl
import
qualified
Data.Map
as
Map
...
...
@@ -110,23 +110,23 @@ procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
-- Once you know what the proc-points are, figure out
-- what proc-points each block is reachable from
procPointAnalysis
procPoints
g
=
liftM
snd
$
dataflowPassFwd
g
initProcPoints
$
analFwd
lattice
forward
-- pprTrace "procPointAnalysis" (ppr procPoints) $
dataflowAnalFwd
g
initProcPoints
$
analFwd
lattice
forward
where
initProcPoints
=
[(
id
,
ProcPoint
)
|
id
<-
setElems
procPoints
]
-- transfer equations
forward
::
FwdTransfer
CmmNode
Status
forward
=
mkFTransfer
transfer
forward
=
mkFTransfer
3
first
middle
last
where
transfer
::
CmmNode
e
x
->
Status
->
Fact
x
Status
transfer
n
s
=
case
shapeX
n
of
Open
->
case
n
of
CmmEntry
id
|
ProcPoint
<-
s
->
ReachedBy
$
setSingleton
id
_
->
s
Closed
->
mkFactBase
lattice
$
map
(
\
id
->
(
id
,
x
))
(
successors
l
)
first
::
CmmNode
C
O
->
Status
->
Status
first
(
CmmEntry
id
)
ProcPoint
=
ReachedBy
$
setSingleton
id
first
_
x
=
x
middle
_
x
=
x
last
::
CmmNode
O
C
->
Status
->
FactBase
Status
last
l
x
=
mkFactBase
lattice
$
map
(
\
id
->
(
id
,
x
))
(
successors
l
)
lattice
::
DataflowLattice
Status
lattice
=
DataflowLattice
"direct proc-point reachability"
unreached
add_to
...
...
@@ -165,6 +165,7 @@ minimalProcPointSet platform callProcPoints g
extendPPSet
::
Platform
->
CmmGraph
->
[
CmmBlock
]
->
ProcPointSet
->
FuelUniqSM
ProcPointSet
extendPPSet
platform
g
blocks
procPoints
=
do
env
<-
procPointAnalysis
procPoints
g
-- pprTrace "extensPPSet" (ppr env) $ return ()
let
add
block
pps
=
let
id
=
entryLabel
block
in
case
mapLookup
id
env
of
Just
ProcPoint
->
setInsert
id
pps
...
...
@@ -331,8 +332,9 @@ add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks
|
not
$
setMember
bid
callPPs
,
Just
(
Protocol
c
fs
_area
)
<-
mapLookup
bid
protos
=
let
nodes
=
copyInSlot
c
fs
(
h
,
m
,
l
)
=
blockToNodeList
block
in
insertBlock
(
blockOfNodeList
(
h
,
nodes
++
m
,
l
))
blocks
(
h
,
b
)
=
blockSplitHead
block
block'
=
blockJoinHead
h
(
blockFromList
nodes
`
blockAppend
`
b
)
in
insertBlock
block'
blocks
|
otherwise
=
insertBlock
block
blocks
where
bid
=
entryLabel
block
...
...
compiler/cmm/CmmRewriteAssignments.hs
View file @
46b03136
...
...
@@ -27,7 +27,7 @@ import UniqFM
import
Unique
import
BlockId
import
Compiler.Hoopl
hiding
(
Unique
)
import
Hoopl
import
Data.Maybe
import
Prelude
hiding
(
succ
,
zip
)
...
...
compiler/cmm/CmmSpillReload.hs
View file @
46b03136
...
...
@@ -23,7 +23,7 @@ import Outputable hiding (empty)
import
qualified
Outputable
as
PP
import
UniqSet
import
Compiler.Hoopl
hiding
(
Unique
)
import
Hoopl
import
Data.Maybe
import
Prelude
hiding
(
succ
,
zip
)
...
...
compiler/cmm/CmmStackLayout.hs
View file @
46b03136
...
...
@@ -39,7 +39,7 @@ import OptimizationFuel
import
Outputable
import
SMRep
(
ByteOff
)
import
Compiler.
Hoopl
import
Hoopl
import
Data.Map
(
Map
)
import
qualified
Data.Map
as
Map
...
...
@@ -94,7 +94,7 @@ type SlotEnv = BlockEnv SubAreaSet
-- The sub-areas live on entry to the block
liveSlotAnal
::
CmmGraph
->
FuelUniqSM
SlotEnv
liveSlotAnal
g
=
liftM
snd
$
dataflow
Pass
Bwd
g
[]
$
analBwd
slotLattice
liveSlotTransfers
liveSlotAnal
g
=
dataflow
Anal
Bwd
g
[]
$
analBwd
slotLattice
liveSlotTransfers
-- Add the subarea s to the subareas in the list-set (possibly coalescing it with
-- adjacent subareas), and also return whether s was a new addition.
...
...
compiler/cmm/CmmUtils.hs
View file @
46b03136
...
...
@@ -66,7 +66,7 @@ module CmmUtils(
foldGraphBlocks
,
mapGraphNodes
,
postorderDfs
,
mapGraphNodes1
,
analFwd
,
analBwd
,
analRewFwd
,
analRewBwd
,
dataflowPassFwd
,
dataflowPassBwd
dataflowPassFwd
,
dataflowPassBwd
,
dataflowAnalFwd
,
dataflowAnalBwd
)
where
#
include
"HsVersions.h"
...
...
@@ -88,7 +88,7 @@ import Data.Word
import
Data.Maybe
import
Data.Bits
import
Control.Monad
import
Compiler.Hoopl
hiding
(
Unique
)
import
Hoopl
---------------------------------------------------
--
...
...
@@ -440,18 +440,6 @@ foldGraphBlocks k z g = mapFold k z $ toBlockMap g
postorderDfs
::
CmmGraph
->
[
CmmBlock
]
postorderDfs
g
=
postorder_dfs_from
(
toBlockMap
g
)
(
g_entry
g
)
-------------------------------------------------
-- Manipulating CmmBlocks
lastNode
::
CmmBlock
->
CmmNode
O
C
lastNode
block
=
foldBlockNodesF3
(
nothing
,
nothing
,
const
)
block
()
where
nothing
::
a
->
b
->
()
nothing
_
_
=
()
replaceLastNode
::
Block
CmmNode
e
C
->
CmmNode
O
C
->
Block
CmmNode
e
C
replaceLastNode
block
last
=
blockOfNodeList
(
first
,
middle
,
JustC
last
)
where
(
first
,
middle
,
_
)
=
blockToNodeList
block
----------------------------------------------------------------------
----- Splicing between blocks
-- Given a middle node, a block, and a successor BlockId,
...
...
@@ -499,26 +487,56 @@ insertBetween b ms succId = insert $ lastNode b
-- Running dataflow analysis and/or rewrites
-- Constructing forward and backward analysis-only pass
analFwd
::
Monad
m
=>
DataflowLattice
f
->
FwdTransfer
n
f
->
FwdPass
m
n
f
analBwd
::
Monad
m
=>
DataflowLattice
f
->
BwdTransfer
n
f
->
BwdPass
m
n
f
analFwd
::
DataflowLattice
f
->
FwdTransfer
n
f
->
FwdPass
FuelUniqSM
n
f
analBwd
::
DataflowLattice
f
->
BwdTransfer
n
f
->
BwdPass
FuelUniqSM
n
f
analFwd
lat
xfer
=
analRewFwd
lat
xfer
noFwdRewrite
analBwd
lat
xfer
=
analRewBwd
lat
xfer
noBwdRewrite
-- Constructing forward and backward analysis + rewrite pass
analRewFwd
::
Monad
m
=>
DataflowLattice
f
->
FwdTransfer
n
f
->
FwdRewrite
m
n
f
->
FwdPass
m
n
f
analRewBwd
::
Monad
m
=>
DataflowLattice
f
->
BwdTransfer
n
f
->
BwdRewrite
m
n
f
->
BwdPass
m
n
f
analRewFwd
::
DataflowLattice
f
->
FwdTransfer
n
f
->
FwdRewrite
FuelUniqSM
n
f
->
FwdPass
FuelUniqSM
n
f
analRewBwd
::
DataflowLattice
f
->
BwdTransfer
n
f
->
BwdRewrite
FuelUniqSM
n
f
->
BwdPass
FuelUniqSM
n
f
analRewFwd
lat
xfer
rew
=
FwdPass
{
fp_lattice
=
lat
,
fp_transfer
=
xfer
,
fp_rewrite
=
rew
}
analRewBwd
lat
xfer
rew
=
BwdPass
{
bp_lattice
=
lat
,
bp_transfer
=
xfer
,
bp_rewrite
=
rew
}
-- Running forward and backward dataflow analysis + optional rewrite
dataflowPassFwd
::
NonLocal
n
=>
GenCmmGraph
n
->
[(
BlockId
,
f
)]
->
FwdPass
FuelUniqSM
n
f
->
FuelUniqSM
(
GenCmmGraph
n
,
BlockEnv
f
)
dataflowPassFwd
::
NonLocal
n
=>
GenCmmGraph
n
->
[(
BlockId
,
f
)]
->
FwdPass
FuelUniqSM
n
f
->
FuelUniqSM
(
GenCmmGraph
n
,
BlockEnv
f
)
dataflowPassFwd
(
CmmGraph
{
g_entry
=
entry
,
g_graph
=
graph
})
facts
fwd
=
do
(
graph
,
facts
,
NothingO
)
<-
analyzeAndRewriteFwd
fwd
(
JustC
[
entry
])
graph
(
mkFactBase
(
fp_lattice
fwd
)
facts
)
return
(
CmmGraph
{
g_entry
=
entry
,
g_graph
=
graph
},
facts
)
dataflowPassBwd
::
NonLocal
n
=>
GenCmmGraph
n
->
[(
BlockId
,
f
)]
->
BwdPass
FuelUniqSM
n
f
->
FuelUniqSM
(
GenCmmGraph
n
,
BlockEnv
f
)
dataflowAnalFwd
::
NonLocal
n
=>
GenCmmGraph
n
->
[(
BlockId
,
f
)]
->
FwdPass
FuelUniqSM
n
f
->
FuelUniqSM
(
BlockEnv
f
)
dataflowAnalFwd
(
CmmGraph
{
g_entry
=
entry
,
g_graph
=
graph
})
facts
fwd
=
do
-- (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
-- return facts
return
(
analyzeFwd
fwd
(
JustC
[
entry
])
graph
(
mkFactBase
(
fp_lattice
fwd
)
facts
))
dataflowAnalBwd
::
NonLocal
n
=>
GenCmmGraph
n
->
[(
BlockId
,
f
)]
->
BwdPass
FuelUniqSM
n
f
->
FuelUniqSM
(
BlockEnv
f
)
dataflowAnalBwd
(
CmmGraph
{
g_entry
=
entry
,
g_graph
=
graph
})
facts
bwd
=
do
-- (graph, facts, NothingO) <- analyzeAndRewriteBwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
-- return facts
return
(
analyzeBwd
bwd
(
JustC
[
entry
])
graph
(
mkFactBase
(
bp_lattice
bwd
)
facts
))
dataflowPassBwd
::
NonLocal
n
=>
GenCmmGraph
n
->
[(
BlockId
,
f
)]
->
BwdPass
FuelUniqSM
n
f
->
FuelUniqSM
(
GenCmmGraph
n
,
BlockEnv
f