Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
322044b2
Commit
322044b2
authored
Jul 19, 2012
by
Ian Lynagh
Browse files
Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
parents
fb0769b6
0f693381
Changes
50
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmBuildInfoTables.hs
View file @
322044b2
...
...
@@ -13,17 +13,15 @@
-- Todo: remove -fno-warn-warnings-deprecations
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module
CmmBuildInfoTables
(
CAFSet
,
CAFEnv
,
cafAnal
,
localCAFInfo
,
mkTopCAFInfo
,
setInfoTableSRT
,
TopSRT
,
emptySRT
,
srtToData
,
bundleCAFs
,
cafTransfers
)
(
CAFSet
,
CAFEnv
,
cafAnal
,
doSRTs
,
TopSRT
,
emptySRT
,
srtToData
)
where
#
include
"HsVersions.h"
-- These should not be imported here!
import
StgCmmUtils
import
Hoopl
import
Digraph
import
qualified
Prelude
as
P
...
...
@@ -41,13 +39,13 @@ import Name
import
Outputable
import
SMRep
import
UniqSupply
import
Hoopl
import
Util
import
Data.Map
(
Map
)
import
qualified
Data.Map
as
Map
import
Data.Set
(
Set
)
import
qualified
Data.Set
as
Set
import
Control.Monad
foldSet
::
(
a
->
b
->
b
)
->
b
->
Set
a
->
b
#
if
__GLASGOW_HASKELL__
<
704
...
...
@@ -71,6 +69,44 @@ foldSet = Set.foldr
-- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
-- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
{- EXAMPLE
f = \x. ... g ...
where
g = \y. ... h ... c1 ...
h = \z. ... c2 ...
c1 & c2 are CAFs
g and h are local functions, but they have no static closures. When
we generate code for f, we start with a CmmGroup of four CmmDecls:
[ f_closure, f_entry, g_entry, h_entry ]
we process each CmmDecl separately in cpsTop, giving us a list of
CmmDecls. e.g. for f_entry, we might end up with
[ f_entry, f1_ret, f2_proc ]
where f1_ret is a return point, and f2_proc is a proc-point. We have
a CAFSet for each of these CmmDecls, let's suppose they are
[ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
[ g_entry{h_closure, c1_closure} ]
[ h_entry{c2_closure} ]
Now, note that we cannot use g_closure and h_closure in an SRT,
because there are no static closures corresponding to these functions.
So we have to flatten out the structure, replacing g_closure and
h_closure with their contents:
[ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
[ g_entry{c2_closure, c1_closure} ]
[ h_entry{c2_closure} ]
This is what mkTopCAFInfo is doing.
-}
-----------------------------------------------------------------------
-- Finding the CAFs used by a procedure
...
...
@@ -147,16 +183,13 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRTs
::
TopSRT
->
Map
CLabel
CAFSet
->
CAFSet
->
UniqSM
(
TopSRT
,
Maybe
CmmDecl
,
C_SRT
)
buildSRTs
topSRT
topCAFMap
cafs
=
do
let
liftCAF
lbl
z
=
-- get CAFs for functions without static closures
case
Map
.
lookup
lbl
topCAFMap
of
Just
cafs
->
z
`
Set
.
union
`
cafs
Nothing
->
Set
.
insert
lbl
z
buildSRTs
::
TopSRT
->
CAFSet
->
UniqSM
(
TopSRT
,
Maybe
CmmDecl
,
C_SRT
)
buildSRTs
topSRT
cafs
=
do
let
-- For each label referring to a function f without a static closure,
-- replace it with the CAFs that are reachable from f.
sub_srt
topSRT
localCafs
=
let
cafs
=
Set
.
elems
(
foldSet
liftCAF
Set
.
empty
localCafs
)
let
cafs
=
Set
.
elems
localCafs
mkSRT
topSRT
=
do
localSRTs
<-
procpointSRT
(
lbl
topSRT
)
(
elt_map
topSRT
)
cafs
return
(
topSRT
,
localSRTs
)
...
...
@@ -230,15 +263,15 @@ to_SRT top_srt off len bmp
-- keep its CAFs live.)
-- Any procedure referring to a non-static CAF c must keep live
-- any CAF that is reachable from c.
localCAFInfo
::
CAFEnv
->
CmmDecl
->
Maybe
(
CLabel
,
CAFSet
)
localCAFInfo
_
(
CmmData
_
_
)
=
Nothing
localCAFInfo
::
CAFEnv
->
CmmDecl
->
(
CAFSet
,
Maybe
CLabel
)
localCAFInfo
_
(
CmmData
_
_
)
=
(
Set
.
empty
,
Nothing
)
localCAFInfo
cafEnv
(
CmmProc
top_info
top_l
(
CmmGraph
{
g_entry
=
entry
}))
=
case
info_tbl
top_info
of
CmmInfoTable
{
cit_rep
=
rep
}
|
not
(
isStaticRep
rep
)
->
Just
(
toClosureLbl
top_l
,
expectJust
"maybeBindCAFs"
$
mapLookup
entry
cafEnv
)
_
->
Nothing
CmmInfoTable
{
cit_rep
=
rep
}
|
not
(
isStaticRep
rep
)
->
(
cafs
,
Just
(
toClosureLbl
top_l
))
_other
->
(
cafs
,
Nothing
)
where
cafs
=
expectJust
"maybeBindCAFs"
$
mapLookup
entry
cafEnv
-- Once we have the local CAF sets for some (possibly) mutually
-- recursive functions, we can create an environment mapping
...
...
@@ -251,54 +284,77 @@ localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
-- the environment with every reference to f replaced by its set of CAFs.
-- To do this replacement efficiently, we gather strongly connected
-- components, then we sort the components in topological order.
mkTopCAFInfo
::
[(
C
Label
,
CAFSet
)]
->
Map
CLabel
CAFSet
mkTopCAFInfo
::
[(
C
AFSet
,
Maybe
CLabel
)]
->
Map
CLabel
CAFSet
mkTopCAFInfo
localCAFs
=
foldl
addToTop
Map
.
empty
g
where
addToTop
env
(
AcyclicSCC
(
l
,
cafset
))
=
where
addToTop
env
(
AcyclicSCC
(
l
,
cafset
))
=
Map
.
insert
l
(
flatten
env
cafset
)
env
addToTop
env
(
CyclicSCC
nodes
)
=
let
(
lbls
,
cafsets
)
=
unzip
nodes
cafset
=
foldr
Set
.
delete
(
foldl
Set
.
union
Set
.
empty
cafsets
)
lbls
in
foldl
(
\
env
l
->
Map
.
insert
l
(
flatten
env
cafset
)
env
)
env
lbls
flatten
env
cafset
=
foldSet
(
lookup
env
)
Set
.
empty
cafset
lookup
env
caf
cafset'
=
case
Map
.
lookup
caf
env
of
Just
cafs
->
foldSet
add
cafset'
cafs
Nothing
->
add
caf
cafset'
add
caf
cafset'
=
Set
.
insert
caf
cafset'
g
=
stronglyConnCompFromEdgedVertices
(
map
(
\
n
@
(
l
,
cafs
)
->
(
n
,
l
,
Set
.
elems
cafs
))
localCAFs
)
-- Bundle the CAFs used at a procpoint.
bundleCAFs
::
CAFEnv
->
CmmDecl
->
(
CAFSet
,
CmmDecl
)
bundleCAFs
cafEnv
t
@
(
CmmProc
_
_
(
CmmGraph
{
g_entry
=
entry
}))
=
(
expectJust
"bundleCAFs"
(
mapLookup
entry
cafEnv
),
t
)
bundleCAFs
_
t
=
(
Set
.
empty
,
t
)
-- Construct the SRTs for the given procedure.
setInfoTableSRT
::
Map
CLabel
CAFSet
->
TopSRT
->
(
CAFSet
,
CmmDecl
)
->
UniqSM
(
TopSRT
,
[
CmmDecl
])
setInfoTableSRT
topCAFMap
topSRT
(
cafs
,
t
)
=
setSRT
cafs
topCAFMap
topSRT
t
setSRT
::
CAFSet
->
Map
CLabel
CAFSet
->
TopSRT
->
CmmDecl
->
UniqSM
(
TopSRT
,
[
CmmDecl
])
setSRT
cafs
topCAFMap
topSRT
t
=
do
(
topSRT
,
cafTable
,
srt
)
<-
buildSRTs
topSRT
topCAFMap
cafs
let
t'
=
updInfo
id
(
const
srt
)
t
case
cafTable
of
Just
tbl
->
return
(
topSRT
,
[
t'
,
tbl
])
Nothing
->
return
(
topSRT
,
[
t'
])
type
StackLayout
=
Liveness
updInfo
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
CmmDecl
->
CmmDecl
updInfo
toVars
toSrt
(
CmmProc
top_info
top_l
g
)
=
CmmProc
(
top_info
{
info_tbl
=
updInfoTbl
toVars
toSrt
(
info_tbl
top_info
)})
top_l
g
updInfo
_
_
t
=
t
updInfoTbl
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
CmmInfoTable
->
CmmInfoTable
updInfoTbl
toVars
toSrt
info_tbl
@
(
CmmInfoTable
{})
=
info_tbl
{
cit_srt
=
toSrt
(
cit_srt
info_tbl
)
,
cit_rep
=
case
cit_rep
info_tbl
of
StackRep
ls
->
StackRep
(
toVars
ls
)
other
->
other
}
updInfoTbl
_
_
t
@
CmmNonInfoTable
=
t
[
((
l
,
cafs
),
l
,
Set
.
elems
cafs
)
|
(
cafs
,
Just
l
)
<-
localCAFs
]
flatten
::
Map
CLabel
CAFSet
->
CAFSet
->
CAFSet
flatten
env
cafset
=
foldSet
(
lookup
env
)
Set
.
empty
cafset
where
lookup
env
caf
cafset'
=
case
Map
.
lookup
caf
env
of
Just
cafs
->
foldSet
Set
.
insert
cafset'
cafs
Nothing
->
Set
.
insert
caf
cafset'
bundle
::
Map
CLabel
CAFSet
->
(
CAFEnv
,
CmmDecl
)
->
(
CAFSet
,
Maybe
CLabel
)
->
(
CAFSet
,
CmmDecl
)
bundle
flatmap
(
_
,
decl
)
(
cafs
,
Nothing
)
=
(
flatten
flatmap
cafs
,
decl
)
bundle
flatmap
(
_
,
decl
)
(
_
,
Just
l
)
=
(
expectJust
"bundle"
$
Map
.
lookup
l
flatmap
,
decl
)
flattenCAFSets
::
[(
CAFEnv
,
[
CmmDecl
])]
->
[(
CAFSet
,
CmmDecl
)]
flattenCAFSets
cpsdecls
=
zipWith
(
bundle
flatmap
)
zipped
localCAFs
where
zipped
=
[(
e
,
d
)
|
(
e
,
ds
)
<-
cpsdecls
,
d
<-
ds
]
localCAFs
=
unzipWith
localCAFInfo
zipped
flatmap
=
mkTopCAFInfo
localCAFs
-- transitive closure of localCAFs
doSRTs
::
TopSRT
->
[(
CAFEnv
,
[
CmmDecl
])]
->
IO
(
TopSRT
,
[
CmmDecl
])
doSRTs
topSRT
tops
=
do
let
caf_decls
=
flattenCAFSets
tops
us
<-
mkSplitUniqSupply
'u'
let
(
topSRT'
,
gs'
)
=
initUs_
us
$
foldM
setSRT
(
topSRT
,
[]
)
caf_decls
return
(
topSRT'
,
reverse
gs'
{- Note [reverse gs] -}
)
where
setSRT
(
topSRT
,
rst
)
(
cafs
,
decl
@
(
CmmProc
{}))
=
do
(
topSRT
,
cafTable
,
srt
)
<-
buildSRTs
topSRT
cafs
let
decl'
=
updInfo
(
const
srt
)
decl
case
cafTable
of
Just
tbl
->
return
(
topSRT
,
decl'
:
tbl
:
rst
)
Nothing
->
return
(
topSRT
,
decl'
:
rst
)
setSRT
(
topSRT
,
rst
)
(
_
,
decl
)
=
return
(
topSRT
,
decl
:
rst
)
{- Note [reverse gs]
It is important to keep the code blocks in the same order,
otherwise binary sizes get slightly bigger. I'm not completely
sure why this is, perhaps the assembler generates bigger jump
instructions for forward refs. --SDM
-}
updInfo
::
(
C_SRT
->
C_SRT
)
->
CmmDecl
->
CmmDecl
updInfo
toSrt
(
CmmProc
top_info
top_l
g
)
=
CmmProc
(
top_info
{
info_tbl
=
updInfoTbl
toSrt
(
info_tbl
top_info
)})
top_l
g
updInfo
_
t
=
t
updInfoTbl
::
(
C_SRT
->
C_SRT
)
->
CmmInfoTable
->
CmmInfoTable
updInfoTbl
toSrt
info_tbl
@
(
CmmInfoTable
{})
=
info_tbl
{
cit_srt
=
toSrt
(
cit_srt
info_tbl
)
}
updInfoTbl
_
t
@
CmmNonInfoTable
=
t
compiler/cmm/CmmLayoutStack.hs
View file @
322044b2
...
...
@@ -3,7 +3,7 @@
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#
endif
module
CmmLayoutStack
(
cmmLayoutStack
,
setInfoTableStackMap
,
cmmSink
cmmLayoutStack
,
setInfoTableStackMap
)
where
import
StgCmmUtils
(
callerSaveVolatileRegs
)
-- XXX
...
...
@@ -34,7 +34,7 @@ import qualified Data.Set as Set
import
Control.Monad.Fix
import
Data.Array
as
Array
import
Data.Bits
import
Data.List
(
nub
,
partition
)
import
Data.List
(
nub
)
import
Control.Monad
(
liftM
)
#
include
"HsVersions.h"
...
...
@@ -111,20 +111,20 @@ cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
cmmLayoutStack
procpoints
entry_args
graph0
@
(
CmmGraph
{
g_entry
=
entry
})
=
do
pprTrace
"cmmLayoutStack"
(
ppr
entry_args
)
$
return
()
--
pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
(
graph
,
liveness
)
<-
removeDeadAssignments
graph0
pprTrace
"liveness"
(
ppr
liveness
)
$
return
()
--
pprTrace "liveness" (ppr liveness) $ return ()
let
blocks
=
postorderDfs
graph
(
final_stackmaps
,
final_high_sp
,
new_blocks
)
<-
(
final_stackmaps
,
_
final_high_sp
,
new_blocks
)
<-
mfix
$
\
~
(
rec_stackmaps
,
rec_high_sp
,
_new_blocks
)
->
layout
procpoints
liveness
entry
entry_args
rec_stackmaps
rec_high_sp
blocks
new_blocks'
<-
mapM
lowerSafeForeignCall
new_blocks
pprTrace
(
"Sp HWM"
)
(
ppr
final_high_sp
)
$
return
(
ofBlockList
entry
new_blocks'
,
final_stackmaps
)
--
pprTrace ("Sp HWM") (ppr
_
final_high_sp) $
return ()
return
(
ofBlockList
entry
new_blocks'
,
final_stackmaps
)
...
...
@@ -167,7 +167,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
(
pprPanic
"no stack map for"
(
ppr
entry_lbl
))
entry_lbl
acc_stackmaps
pprTrace
"layout"
(
ppr
entry_lbl
<+>
ppr
stack0
)
$
return
()
--
pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return ()
-- (a) Update the stack map to include the effects of
-- assignments in this block
...
...
@@ -188,7 +188,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
<-
handleLastNode
procpoints
liveness
cont_info
acc_stackmaps
stack1
middle0
last0
pprTrace
"layout(out)"
(
ppr
out
)
$
return
()
--
pprTrace "layout(out)" (ppr out) $ return ()
-- (d) Manifest Sp: run over the nodes in the block and replace
-- CmmStackSlot with CmmLoad from Sp with a concrete offset.
...
...
@@ -416,8 +416,8 @@ handleLastNode procpoints liveness cont_info stackmaps
case
mapLookup
l
stackmaps
of
Just
pp_sm
->
(
pp_sm
,
fixupStack
stack0
pp_sm
)
Nothing
->
pprTrace
"first visit to proc point"
(
ppr
l
<+>
ppr
stack1
)
$
--
pprTrace "first visit to proc point"
--
(ppr l <+> ppr stack1) $
(
stack1
,
assigs
)
where
cont_args
=
mapFindWithDefault
0
l
cont_info
...
...
@@ -570,7 +570,7 @@ allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O])
allocate
ret_off
live
stackmap
@
StackMap
{
sm_sp
=
sp0
,
sm_regs
=
regs0
}
=
pprTrace
"allocate"
(
ppr
live
$$
ppr
stackmap
)
$
--
pprTrace "allocate" (ppr live $$ ppr stackmap) $
-- we only have to save regs that are not already in a slot
let
to_save
=
filter
(
not
.
(`
elemUFM
`
regs0
))
(
Set
.
elems
live
)
...
...
@@ -798,7 +798,8 @@ elimStackStores stackmap stackmaps area_off nodes
CmmStore
(
CmmStackSlot
area
m
)
(
CmmReg
(
CmmLocal
r
))
|
Just
(
_
,
off
)
<-
lookupUFM
(
sm_regs
stackmap
)
r
,
area_off
area
+
m
==
off
->
pprTrace
"eliminated a node!"
(
ppr
r
)
$
go
stackmap
ns
->
-- pprTrace "eliminated a node!" (ppr r) $
go
stackmap
ns
_otherwise
->
n
:
go
(
procMiddle
stackmaps
n
stackmap
)
ns
...
...
@@ -978,75 +979,3 @@ insertReloads stackmap =
stackSlotRegs
::
StackMap
->
[(
LocalReg
,
StackLoc
)]
stackSlotRegs
sm
=
eltsUFM
(
sm_regs
sm
)
-- -----------------------------------------------------------------------------
-- If we do this *before* stack layout, we might be able to avoid
-- saving some things across calls/procpoints.
--
-- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it.
cmmSink
::
CmmGraph
->
UniqSM
CmmGraph
cmmSink
graph
=
do
let
liveness
=
cmmLiveness
graph
return
$
cmmSink'
liveness
graph
cmmSink'
::
BlockEnv
CmmLive
->
CmmGraph
->
CmmGraph
cmmSink'
liveness
graph
=
ofBlockList
(
g_entry
graph
)
$
sink
mapEmpty
$
postorderDfs
graph
where
sink
::
BlockEnv
[(
LocalReg
,
CmmExpr
)]
->
[
CmmBlock
]
->
[
CmmBlock
]
sink
_
[]
=
[]
sink
sunk
(
b
:
bs
)
=
pprTrace
"sink"
(
ppr
l
)
$
blockJoin
first
final_middle
last
:
sink
sunk'
bs
where
l
=
entryLabel
b
(
first
,
middle
,
last
)
=
blockSplit
b
(
middle'
,
assigs
)
=
walk
(
blockToList
middle
)
emptyBlock
(
mapFindWithDefault
[]
l
sunk
)
(
dropped_last
,
assigs'
)
=
partition
(`
conflictsWithLast
`
last
)
assigs
final_middle
=
foldl
blockSnoc
middle'
(
toNodes
dropped_last
)
sunk'
=
mapUnion
sunk
$
mapFromList
[
(
l
,
filt
assigs'
(
getLive
l
))
|
l
<-
successors
last
]
where
getLive
l
=
mapFindWithDefault
Set
.
empty
l
liveness
filt
as
live
=
[
(
r
,
e
)
|
(
r
,
e
)
<-
as
,
r
`
Set
.
member
`
live
]
walk
::
[
CmmNode
O
O
]
->
Block
CmmNode
O
O
->
[(
LocalReg
,
CmmExpr
)]
->
(
Block
CmmNode
O
O
,
[(
LocalReg
,
CmmExpr
)])
walk
[]
acc
as
=
(
acc
,
as
)
walk
(
n
:
ns
)
acc
as
|
Just
a
<-
collect_it
=
walk
ns
acc
(
a
:
as
)
|
otherwise
=
walk
ns
(
foldr
(
flip
blockSnoc
)
acc
(
n
:
drop_nodes
))
as'
where
collect_it
=
case
n
of
CmmAssign
(
CmmLocal
r
)
e
@
(
CmmReg
(
CmmGlobal
_
))
->
Just
(
r
,
e
)
-- CmmAssign (CmmLocal r) e@(CmmLoad addr _) |
-- foldRegsUsed (\b r -> False) True addr -> Just (r,e)
_
->
Nothing
drop_nodes
=
toNodes
dropped
(
dropped
,
as'
)
=
partition
should_drop
as
where
should_drop
a
=
a
`
conflicts
`
n
toNodes
::
[(
LocalReg
,
CmmExpr
)]
->
[
CmmNode
O
O
]
toNodes
as
=
[
CmmAssign
(
CmmLocal
r
)
rhs
|
(
r
,
rhs
)
<-
as
]
-- We only sink "r = G" assignments right now, so conflicts is very simple:
conflicts
::
(
LocalReg
,
CmmExpr
)
->
CmmNode
O
O
->
Bool
(
_
,
rhs
)
`
conflicts
`
CmmAssign
reg
_
|
reg
`
regUsedIn
`
rhs
=
True
--(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True
(
r
,
_
)
`
conflicts
`
node
=
foldRegsUsed
(
\
b
r'
->
r
==
r'
||
b
)
False
node
conflictsWithLast
::
(
LocalReg
,
CmmExpr
)
->
CmmNode
O
C
->
Bool
(
r
,
_
)
`
conflictsWithLast
`
node
=
foldRegsUsed
(
\
b
r'
->
r
==
r'
||
b
)
False
node
compiler/cmm/CmmPipeline.hs
View file @
322044b2
...
...
@@ -9,7 +9,6 @@ module CmmPipeline (
cmmPipeline
)
where
import
CLabel
import
Cmm
import
CmmLint
import
CmmBuildInfoTables
...
...
@@ -17,76 +16,42 @@ import CmmCommonBlockElim
import
CmmProcPoint
import
CmmContFlowOpt
import
CmmLayoutStack
import
CmmSink
import
Hoopl
import
UniqSupply
import
DynFlags
import
ErrUtils
import
HscTypes
import
Data.Maybe
import
Control.Monad
import
Outputable
import
qualified
Data.Set
as
Set
import
Data.Map
(
Map
)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
-----------------------------------------------------------------------------
-- There are two complications here:
-- 1. We need to compile the procedures in two stages because we need
-- an analysis of the procedures to tell us what CAFs they use.
-- The first stage returns a map from procedure labels to CAFs,
-- along with a closure that will compute SRTs and attach them to
-- the compiled procedures.
-- The second stage is to combine the CAF information into a top-level
-- CAF environment mapping non-static closures to the CAFs they keep live,
-- then pass that environment to the closures returned in the first
-- stage of compilation.
-- 2. We need to thread the module's SRT around when the SRT tables
-- are computed for each procedure.
-- The SRT needs to be threaded because it is grown lazily.
-- 3. We run control flow optimizations twice, once before any pipeline
-- work is done, and once again at the very end on all of the
-- resulting C-- blocks. EZY: It's unclear whether or not whether
-- we actually need to do the initial pass.
cmmPipeline
::
HscEnv
-- Compilation env including
-- dynamic flags: -dcmm-lint -ddump-cps-cmm
->
TopSRT
-- SRT table and accumulating list of compiled procs
->
CmmGroup
-- Input C-- with Procedures
->
IO
(
TopSRT
,
CmmGroup
)
-- Output CPS transformed C--
cmmPipeline
hsc_env
topSRT
prog
=
do
let
dflags
=
hsc_dflags
hsc_env
--
showPass
dflags
"CPSZ"
(
cafEnvs
,
tops
)
<-
{-# SCC "tops" #-}
liftM
unzip
$
mapM
(
cpsTop
hsc_env
)
prog
-- tops :: [[(CmmDecl,CAFSet]] (one list per group)
let
topCAFEnv
=
{-# SCC "topCAFEnv" #-}
mkTopCAFInfo
(
concat
cafEnvs
)
-- folding over the groups
(
topSRT
,
tops
)
<-
{-# SCC "toTops" #-}
foldM
(
toTops
topCAFEnv
)
(
topSRT
,
[]
)
tops
showPass
dflags
"CPSZ"
let
cmms
::
CmmGroup
cmms
=
reverse
(
concat
tops
)
tops
<-
{-# SCC "tops" #-}
mapM
(
cpsTop
hsc_env
)
prog
(
topSRT
,
cmms
)
<-
{-# SCC "toTops" #-}
doSRTs
topSRT
tops
dumpIfSet_dyn
dflags
Opt_D_dump_cps_cmm
"Post CPS Cmm"
(
ppr
cmms
)
return
(
topSRT
,
cmms
)
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
The identity and the last pass are stored in
mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}
-- EZY: It might be helpful to have an easy way of dumping the "pre"
-- input for any given phase, besides just turning it all on with
-- -ddump-cmmz
cpsTop
::
HscEnv
->
CmmDecl
->
IO
(
[(
CLabel
,
CAFSet
)],
[(
CAFSet
,
CmmDecl
)
])
cpsTop
_
p
@
(
CmmData
{})
=
return
(
[]
,
[(
Set
.
e
mpty
,
p
)
])
cpsTop
::
HscEnv
->
CmmDecl
->
IO
(
CAFEnv
,
[
CmmDecl
])
cpsTop
_
p
@
(
CmmData
{})
=
return
(
mapE
mpty
,
[
p
])
cpsTop
hsc_env
(
CmmProc
h
@
(
TopInfo
{
stack_info
=
StackInfo
{
arg_space
=
entry_off
}})
l
g
)
=
do
----------- Control-flow optimisations ---------------
...
...
@@ -110,8 +75,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
runUniqSM
$
cmmLayoutStack
procPoints
entry_off
g
dump
Opt_D_dump_cmmz_sp
"Layout Stack"
g
-- g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g
-- dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
g
<-
if
optLevel
dflags
>=
99
then
do
g
<-
{-# SCC "sink" #-}
return
(
cmmSink
g
)
dump
Opt_D_dump_cmmz_rewrite
"Sink assignments"
g
g
<-
{-# SCC "inline" #-}
return
(
cmmPeepholeInline
g
)
dump
Opt_D_dump_cmmz_rewrite
"Peephole inline"
g
return
g
else
return
g
-- ----------- Sink and inline assignments -------------------
-- g <- {-# SCC "rewriteAssignments" #-} runOptimization $
...
...
@@ -126,31 +96,21 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
splitAtProcPoints
l
callPPs
procPoints
procPointMap
(
CmmProc
h
l
g
)
dumps
Opt_D_dump_cmmz_split
"Post splitting"
gs
-------------
More CAF
s ------------------------------
-------------
CAF analysi
s ------------------------------
let
cafEnv
=
{-# SCC "cafAnal" #-}
cafAnal
g
let
localCAFs
=
{-# SCC "localCAFs" #-}
catMaybes
$
map
(
localCAFInfo
cafEnv
)
gs
mbpprTrace
"localCAFs"
(
ppr
localCAFs
)
$
return
()
--
NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
--
----------- Populate info tables with stack info ------
gs
<-
{-# SCC "setInfoTableStackMap" #-}
return
$
map
(
setInfoTableStackMap
stackmaps
)
gs
dumps
Opt_D_dump_cmmz_info
"after setInfoTableStackMap"
gs
----------- Control-flow optimisations ---------------
----------- Control-flow optimisations ---------------
--
gs
<-
{-# SCC "cmmCfgOpts(2)" #-}
return
$
map
cmmCfgOptsProc
gs
dumps
Opt_D_dump_cmmz_cfg
"Post control-flow optimsations"
gs
gs
<-
{-# SCC "bundleCAFs" #-}
return
$
map
(
bundleCAFs
cafEnv
)
gs
dumps
Opt_D_dump_cmmz_cafs
"after bundleCAFs"
gs
return
(
localCAFs
,
gs
)
-- gs :: [ (CAFSet, CmmDecl) ]
-- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
return
(
cafEnv
,
gs
)
where
dflags
=
hsc_dflags
hsc_env
mbpprTrace
x
y
z
|
dopt
Opt_D_dump_cmmz
dflags
=
pprTrace
x
y
z
|
otherwise
=
z
dump
=
dumpGraph
dflags
dumps
flag
name
...
...
@@ -182,14 +142,3 @@ dumpWith dflags flag txt g = do
when
(
not
(
dopt
flag
dflags
))
$
dumpIfSet_dyn
dflags
Opt_D_dump_cmmz
txt
(
ppr
g
)
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
toTops
::
Map
CLabel
CAFSet
->
(
TopSRT
,
[[
CmmDecl
]])
->
[(
CAFSet
,
CmmDecl
)]
->
IO
(
TopSRT
,
[[
CmmDecl
]])
toTops
topCAFEnv
(
topSRT
,
tops
)
gs
=
do
let
setSRT
(
topSRT
,
rst
)
g
=
do
(
topSRT
,
gs
)
<-
setInfoTableSRT
topCAFEnv
topSRT
g
return
(
topSRT
,
gs
:
rst
)
(
topSRT
,
gs'
)
<-
runUniqSM
$
foldM
setSRT
(
topSRT
,
[]
)
gs
return
(
topSRT
,
concat
gs'
:
tops
)
compiler/cmm/CmmSink.hs
0 → 100644
View file @
322044b2
{-# LANGUAGE GADTs #-}
module
CmmSink
(
cmmSink
,
cmmPeepholeInline
)
where
import
Cmm
import
BlockId
import
CmmLive
import
CmmUtils
import
Hoopl
import
UniqFM
import
Unique
import
Outputable
import
qualified
Data.Set
as
Set
-- -----------------------------------------------------------------------------
-- Sinking
-- This is an optimisation pass that
-- (a) moves assignments closer to their uses, to reduce register pressure
-- (b) pushes assignments into a single branch of a conditional if possible
-- It is particularly helpful in the Cmm generated by the Stg->Cmm
-- code generator, in which every function starts with a copyIn
-- sequence like:
--
-- x1 = R1
-- x2 = Sp[8]