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
Alex D
GHC
Commits
5b167f5e
Commit
5b167f5e
authored
Aug 22, 2011
by
Simon Marlow
Browse files
Snapshot of codegen refactoring to share with simonpj
parent
3108accd
Changes
60
Show whitespace changes
Inline
Side-by-side
compiler/cmm/CLabel.hs
View file @
5b167f5e
...
@@ -22,7 +22,7 @@ module CLabel (
...
@@ -22,7 +22,7 @@ module CLabel (
mkSRTLabel
,
mkSRTLabel
,
mkInfoTableLabel
,
mkInfoTableLabel
,
mkEntryLabel
,
mkEntryLabel
,
mkSlowEntryLabel
,
mkSlowEntryLabel
,
slowEntryFromInfoLabel
,
mkConEntryLabel
,
mkConEntryLabel
,
mkStaticConEntryLabel
,
mkStaticConEntryLabel
,
mkRednCountsLabel
,
mkRednCountsLabel
,
...
@@ -354,8 +354,10 @@ data DynamicLinkerLabelInfo
...
@@ -354,8 +354,10 @@ data DynamicLinkerLabelInfo
-- Constructing IdLabels
-- Constructing IdLabels
-- These are always local:
-- These are always local:
mkSRTLabel
name
c
=
IdLabel
name
c
SRT
mkSlowEntryLabel
name
c
=
IdLabel
name
c
Slow
mkSlowEntryLabel
name
c
=
IdLabel
name
c
Slow
slowEntryFromInfoLabel
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Slow
mkSRTLabel
name
c
=
IdLabel
name
c
SRT
mkRednCountsLabel
name
c
=
IdLabel
name
c
RednCounts
mkRednCountsLabel
name
c
=
IdLabel
name
c
RednCounts
-- These have local & (possibly) external variants:
-- These have local & (possibly) external variants:
...
...
compiler/cmm/Cmm.hs
View file @
5b167f5e
...
@@ -8,39 +8,84 @@
...
@@ -8,39 +8,84 @@
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
#
endif
#
endif
module
Cmm
module
Cmm
(
(
CmmGraph
,
GenCmmGraph
(
..
),
CmmBlock
-- * Cmm top-level datatypes
,
CmmStackInfo
(
..
),
CmmTopInfo
(
..
),
Cmm
,
CmmTop
CmmPgm
,
GenCmmPgm
,
,
CmmReplGraph
,
GenCmmReplGraph
,
CmmFwdRewrite
,
CmmBwdRewrite
CmmTop
,
GenCmmTop
(
..
),
CmmGraph
,
GenCmmGraph
(
..
),
,
modifyGraph
CmmBlock
,
,
lastNode
,
replaceLastNode
,
insertBetween
Section
(
..
),
CmmStatics
(
..
),
CmmStatic
(
..
),
,
ofBlockMap
,
toBlockMap
,
insertBlock
,
ofBlockList
,
toBlockList
,
bodyToBlockList
-- * Cmm graphs
,
foldGraphBlocks
,
mapGraphNodes
,
postorderDfs
CmmReplGraph
,
GenCmmReplGraph
,
CmmFwdRewrite
,
CmmBwdRewrite
,
,
analFwd
,
analBwd
,
analRewFwd
,
analRewBwd
-- * Info Tables
,
dataflowPassFwd
,
dataflowPassBwd
CmmTopInfo
(
..
),
CmmStackInfo
(
..
),
CmmInfoTable
(
..
),
,
module
CmmNode
ClosureTypeInfo
(
..
),
)
C_SRT
(
..
),
needsSRT
,
where
ProfilingInfo
(
..
),
ConstrDescription
,
-- * Statements, expressions and types
module
CmmNode
,
module
CmmExpr
,
)
where
import
CLabel
import
BlockId
import
BlockId
import
CmmDecl
import
CmmNode
import
CmmNode
import
OptimizationFuel
as
F
import
OptimizationFuel
as
F
import
SMRep
import
SMRep
import
UniqSupply
import
CmmExpr
import
Compiler.Hoopl
import
Compiler.Hoopl
import
Control.Monad
import
Data.Maybe
import
Data.Word
(
Word8
)
import
Panic
#
include
"HsVersions.h"
#
include
"HsVersions.h"
-------------------------------------------------
-----------------------------------------------------------------------------
-- CmmBlock, CmmGraph and Cmm
-- Cmm, GenCmm
-----------------------------------------------------------------------------
-- A file is a list of top-level chunks. These may be arbitrarily
-- re-orderd during code generation.
-- GenCmm is abstracted over
-- d, the type of static data elements in CmmData
-- h, the static info preceding the code of a CmmProc
-- g, the control-flow graph of a CmmProc
--
-- We expect there to be two main instances of this type:
-- (a) C--, i.e. populated with various C-- constructs
-- (Cmm and RawCmm in OldCmm.hs)
-- (b) Native code, populated with data/instructions
--
-- A second family of instances based on Hoopl is in Cmm.hs.
--
type
GenCmmPgm
d
h
g
=
[
GenCmmTop
d
h
g
]
type
CmmPgm
=
GenCmmPgm
CmmStatics
CmmTopInfo
CmmGraph
-----------------------------------------------------------------------------
-- CmmTop, GenCmmTop
-----------------------------------------------------------------------------
-- | A top-level chunk, abstracted over the type of the contents of
-- the basic blocks (Cmm or instructions are the likely instantiations).
data
GenCmmTop
d
h
g
=
CmmProc
-- A procedure
h
-- Extra header such as the info table
CLabel
-- Entry label
g
-- Control-flow graph for the procedure's code
|
CmmData
-- Static data
Section
d
type
CmmTop
=
GenCmmTop
CmmStatics
CmmTopInfo
CmmGraph
-----------------------------------------------------------------------------
-- Graphs
-----------------------------------------------------------------------------
type
CmmGraph
=
GenCmmGraph
CmmNode
type
CmmGraph
=
GenCmmGraph
CmmNode
data
GenCmmGraph
n
=
CmmGraph
{
g_entry
::
BlockId
,
g_graph
::
Graph
n
C
C
}
data
GenCmmGraph
n
=
CmmGraph
{
g_entry
::
BlockId
,
g_graph
::
Graph
n
C
C
}
...
@@ -51,131 +96,66 @@ type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
...
@@ -51,131 +96,66 @@ type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
type
CmmFwdRewrite
f
=
FwdRewrite
FuelUniqSM
CmmNode
f
type
CmmFwdRewrite
f
=
FwdRewrite
FuelUniqSM
CmmNode
f
type
CmmBwdRewrite
f
=
BwdRewrite
FuelUniqSM
CmmNode
f
type
CmmBwdRewrite
f
=
BwdRewrite
FuelUniqSM
CmmNode
f
data
CmmStackInfo
=
StackInfo
{
arg_space
::
ByteOff
,
updfr_space
::
Maybe
ByteOff
}
-----------------------------------------------------------------------------
-- Info Tables
-----------------------------------------------------------------------------
data
CmmTopInfo
=
TopInfo
{
info_tbl
::
CmmInfoTable
,
stack_info
::
CmmStackInfo
}
data
CmmTopInfo
=
TopInfo
{
info_tbl
::
CmmInfoTable
,
stack_info
::
CmmStackInfo
}
type
Cmm
=
GenCmm
CmmStatics
CmmTopInfo
CmmGraph
type
CmmTop
=
GenCmmTop
CmmStatics
CmmTopInfo
CmmGraph
-------------------------------------------------
data
CmmStackInfo
-- Manipulating CmmGraphs
=
StackInfo
{
arg_space
::
ByteOff
,
-- XXX: comment?
modifyGraph
::
(
Graph
n
C
C
->
Graph
n'
C
C
)
->
GenCmmGraph
n
->
GenCmmGraph
n'
updfr_space
::
Maybe
ByteOff
-- XXX: comment?
modifyGraph
f
g
=
CmmGraph
{
g_entry
=
g_entry
g
,
g_graph
=
f
(
g_graph
g
)}
}
toBlockMap
::
CmmGraph
->
LabelMap
CmmBlock
-- | Info table as a haskell data type
toBlockMap
(
CmmGraph
{
g_graph
=
GMany
NothingO
body
NothingO
})
=
body
data
CmmInfoTable
=
CmmInfoTable
{
ofBlockMap
::
BlockId
->
LabelMap
CmmBlock
->
CmmGraph
cit_lbl
::
CLabel
,
-- Info table label
ofBlockMap
entry
bodyMap
=
CmmGraph
{
g_entry
=
entry
,
g_graph
=
GMany
NothingO
bodyMap
NothingO
}
cit_rep
::
SMRep
,
cit_prof
::
ProfilingInfo
,
insertBlock
::
CmmBlock
->
LabelMap
CmmBlock
->
LabelMap
CmmBlock
cit_srt
::
C_SRT
insertBlock
block
map
=
}
ASSERT
(
isNothing
$
mapLookup
id
map
)
|
CmmNonInfoTable
-- Procedure doesn't need an info table
mapInsert
id
block
map
where
id
=
entryLabel
block
data
ProfilingInfo
=
NoProfilingInfo
toBlockList
::
CmmGraph
->
[
CmmBlock
]
|
ProfilingInfo
[
Word8
]
[
Word8
]
-- closure_type, closure_desc
toBlockList
g
=
mapElems
$
toBlockMap
g
-- C_SRT is what StgSyn.SRT gets translated to...
ofBlockList
::
BlockId
->
[
CmmBlock
]
->
CmmGraph
-- we add a label for the table, and expect only the 'offset/length' form
ofBlockList
entry
blocks
=
CmmGraph
{
g_entry
=
entry
,
g_graph
=
GMany
NothingO
body
NothingO
}
where
body
=
foldr
addBlock
emptyBody
blocks
data
C_SRT
=
NoC_SRT
|
C_SRT
!
CLabel
!
WordOff
!
StgHalfWord
{-bitmap or escape-}
bodyToBlockList
::
Body
CmmNode
->
[
CmmBlock
]
deriving
(
Eq
)
bodyToBlockList
body
=
mapElems
body
needsSRT
::
C_SRT
->
Bool
mapGraphNodes
::
(
CmmNode
C
O
->
CmmNode
C
O
needsSRT
NoC_SRT
=
False
,
CmmNode
O
O
->
CmmNode
O
O
needsSRT
(
C_SRT
_
_
_
)
=
True
,
CmmNode
O
C
->
CmmNode
O
C
)
->
CmmGraph
->
CmmGraph
-----------------------------------------------------------------------------
mapGraphNodes
funs
@
(
mf
,
_
,
_
)
g
=
-- Static Data
ofBlockMap
(
entryLabel
$
mf
$
CmmEntry
$
g_entry
g
)
$
mapMap
(
blockMapNodes3
funs
)
$
toBlockMap
g
-----------------------------------------------------------------------------
foldGraphBlocks
::
(
CmmBlock
->
a
->
a
)
->
a
->
CmmGraph
->
a
data
Section
foldGraphBlocks
k
z
g
=
mapFold
k
z
$
toBlockMap
g
=
Text
|
Data
postorderDfs
::
CmmGraph
->
[
CmmBlock
]
|
ReadOnlyData
postorderDfs
g
=
postorder_dfs_from
(
toBlockMap
g
)
(
g_entry
g
)
|
RelocatableReadOnlyData
|
UninitialisedData
-------------------------------------------------
|
ReadOnlyData16
-- .rodata.cst16 on x86_64, 16-byte aligned
-- Manipulating CmmBlocks
|
OtherSection
String
lastNode
::
CmmBlock
->
CmmNode
O
C
data
CmmStatic
lastNode
block
=
foldBlockNodesF3
(
nothing
,
nothing
,
const
)
block
()
=
CmmStaticLit
CmmLit
where
nothing
::
a
->
b
->
()
-- a literal value, size given by cmmLitRep of the literal.
nothing
_
_
=
()
|
CmmUninitialised
Int
-- uninitialised data, N bytes long
replaceLastNode
::
Block
CmmNode
e
C
->
CmmNode
O
C
->
Block
CmmNode
e
C
|
CmmString
[
Word8
]
replaceLastNode
block
last
=
blockOfNodeList
(
first
,
middle
,
JustC
last
)
-- string of 8-bit values only, not zero terminated.
where
(
first
,
middle
,
_
)
=
blockToNodeList
block
data
CmmStatics
----------------------------------------------------------------------
=
Statics
----- Splicing between blocks
CLabel
-- Label of statics
-- Given a middle node, a block, and a successor BlockId,
[
CmmStatic
]
-- The static data itself
-- we can insert the middle node between the block and the successor.
-- We return the updated block and a list of new blocks that must be added
-- to the graph.
-- The semantics is a bit tricky. We consider cases on the last node:
-- o For a branch, we can just insert before the branch,
-- but sometimes the optimizer does better if we actually insert
-- a fresh basic block, enabling some common blockification.
-- o For a conditional branch, switch statement, or call, we must insert
-- a new basic block.
-- o For a jump or return, this operation is impossible.
insertBetween
::
MonadUnique
m
=>
CmmBlock
->
[
CmmNode
O
O
]
->
BlockId
->
m
(
CmmBlock
,
[
CmmBlock
])
insertBetween
b
ms
succId
=
insert
$
lastNode
b
where
insert
::
MonadUnique
m
=>
CmmNode
O
C
->
m
(
CmmBlock
,
[
CmmBlock
])
insert
(
CmmBranch
bid
)
=
if
bid
==
succId
then
do
(
bid'
,
bs
)
<-
newBlocks
return
(
replaceLastNode
b
(
CmmBranch
bid'
),
bs
)
else
panic
"tried invalid block insertBetween"
insert
(
CmmCondBranch
c
t
f
)
=
do
(
t'
,
tbs
)
<-
if
t
==
succId
then
newBlocks
else
return
$
(
t
,
[]
)
(
f'
,
fbs
)
<-
if
f
==
succId
then
newBlocks
else
return
$
(
f
,
[]
)
return
(
replaceLastNode
b
(
CmmCondBranch
c
t'
f'
),
tbs
++
fbs
)
insert
(
CmmSwitch
e
ks
)
=
do
(
ids
,
bs
)
<-
mapAndUnzipM
mbNewBlocks
ks
return
(
replaceLastNode
b
(
CmmSwitch
e
ids
),
join
bs
)
insert
(
CmmCall
{})
=
panic
"unimp: insertBetween after a call -- probably not a good idea"
insert
(
CmmForeignCall
{})
=
panic
"unimp: insertBetween after a foreign call -- probably not a good idea"
newBlocks
::
MonadUnique
m
=>
m
(
BlockId
,
[
CmmBlock
])
newBlocks
=
do
id
<-
liftM
mkBlockId
$
getUniqueM
return
$
(
id
,
[
blockOfNodeList
(
JustC
(
CmmEntry
id
),
ms
,
JustC
(
CmmBranch
succId
))])
mbNewBlocks
::
MonadUnique
m
=>
Maybe
BlockId
->
m
(
Maybe
BlockId
,
[
CmmBlock
])
mbNewBlocks
(
Just
k
)
=
if
k
==
succId
then
liftM
fstJust
newBlocks
else
return
(
Just
k
,
[]
)
mbNewBlocks
Nothing
=
return
(
Nothing
,
[]
)
fstJust
(
id
,
bs
)
=
(
Just
id
,
bs
)
-------------------------------------------------
-- 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
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
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
(
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
)
dataflowPassBwd
(
CmmGraph
{
g_entry
=
entry
,
g_graph
=
graph
})
facts
bwd
=
do
(
graph
,
facts
,
NothingO
)
<-
analyzeAndRewriteBwd
bwd
(
JustC
[
entry
])
graph
(
mkFactBase
(
bp_lattice
bwd
)
facts
)
return
(
CmmGraph
{
g_entry
=
entry
,
g_graph
=
graph
},
facts
)
compiler/cmm/CmmBuildInfoTables.hs
View file @
5b167f5e
...
@@ -11,11 +11,16 @@ module CmmBuildInfoTables
...
@@ -11,11 +11,16 @@ module CmmBuildInfoTables
,
TopSRT
,
emptySRT
,
srtToData
,
TopSRT
,
emptySRT
,
srtToData
,
bundleCAFs
,
bundleCAFs
,
lowerSafeForeignCalls
,
lowerSafeForeignCalls
,
cafTransfers
,
liveSlotTransfers
)
,
cafTransfers
,
liveSlotTransfers
,
mkLiveness
)
where
where
#
include
"HsVersions.h"
#
include
"HsVersions.h"
-- These should not be imported here!
import
StgCmmForeign
import
StgCmmUtils
import
Constants
import
Constants
import
Digraph
import
Digraph
import
qualified
Prelude
as
P
import
qualified
Prelude
as
P
...
@@ -26,8 +31,7 @@ import BlockId
...
@@ -26,8 +31,7 @@ import BlockId
import
Bitmap
import
Bitmap
import
CLabel
import
CLabel
import
Cmm
import
Cmm
import
CmmDecl
import
CmmUtils
import
CmmExpr
import
CmmStackLayout
import
CmmStackLayout
import
Module
import
Module
import
FastString
import
FastString
...
@@ -41,9 +45,6 @@ import Name
...
@@ -41,9 +45,6 @@ import Name
import
OptimizationFuel
import
OptimizationFuel
import
Outputable
import
Outputable
import
SMRep
import
SMRep
import
StgCmmClosure
import
StgCmmForeign
import
StgCmmUtils
import
UniqSupply
import
UniqSupply
import
Compiler.Hoopl
import
Compiler.Hoopl
...
@@ -87,13 +88,14 @@ type RegSlotInfo
...
@@ -87,13 +88,14 @@ type RegSlotInfo
,
LocalReg
-- The register
,
LocalReg
-- The register
,
Int
)
-- Width of the register
,
Int
)
-- Width of the register
live_ptrs
::
ByteOff
->
BlockEnv
SubAreaSet
->
AreaMap
->
BlockId
->
[
Maybe
LocalReg
]
live_ptrs
::
ByteOff
->
BlockEnv
SubAreaSet
->
AreaMap
->
BlockId
->
StackLayout
live_ptrs
oldByte
slotEnv
areaMap
bid
=
live_ptrs
oldByte
slotEnv
areaMap
bid
=
-- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
-- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
-- ppr liveSlots) $
-- ppr liveSlots) $
-- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
-- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
res
res
where
res
=
reverse
$
slotsToList
youngByte
liveSlots
[]
where
res
=
mkLiveness
(
reverse
$
slotsToList
youngByte
liveSlots
[]
)
slotsToList
::
Int
->
[
RegSlotInfo
]
->
[
Maybe
LocalReg
]
->
[
Maybe
LocalReg
]
slotsToList
::
Int
->
[
RegSlotInfo
]
->
[
Maybe
LocalReg
]
->
[
Maybe
LocalReg
]
-- n starts at youngByte and is decremented down to oldByte
-- n starts at youngByte and is decremented down to oldByte
...
@@ -160,8 +162,9 @@ live_ptrs oldByte slotEnv areaMap bid =
...
@@ -160,8 +162,9 @@ live_ptrs oldByte slotEnv areaMap bid =
-- is not the successor of a call.
-- is not the successor of a call.
setInfoTableStackMap
::
SlotEnv
->
AreaMap
->
CmmTop
->
CmmTop
setInfoTableStackMap
::
SlotEnv
->
AreaMap
->
CmmTop
->
CmmTop
setInfoTableStackMap
slotEnv
areaMap
setInfoTableStackMap
slotEnv
areaMap
t
@
(
CmmProc
(
TopInfo
{
stack_info
=
StackInfo
{
updfr_space
=
Just
updfr_off
}})
_
(
CmmGraph
{
g_entry
=
eid
}))
=
t
@
(
CmmProc
(
TopInfo
{
stack_info
=
StackInfo
{
updfr_space
=
Just
updfr_off
}})
_
updInfo
(
const
(
live_ptrs
updfr_off
slotEnv
areaMap
eid
))
id
t
(
CmmGraph
{
g_entry
=
eid
}))
=
updInfo
(
const
(
live_ptrs
updfr_off
slotEnv
areaMap
eid
))
id
t
setInfoTableStackMap
_
_
t
=
t
setInfoTableStackMap
_
_
t
=
t
...
@@ -237,8 +240,8 @@ addCAF caf srt =
...
@@ -237,8 +240,8 @@ addCAF caf srt =
,
elt_map
=
Map
.
insert
caf
last
(
elt_map
srt
)
}
,
elt_map
=
Map
.
insert
caf
last
(
elt_map
srt
)
}
where
last
=
next_elt
srt
where
last
=
next_elt
srt
srtToData
::
TopSRT
->
Cmm
srtToData
::
TopSRT
->
Cmm
Pgm
srtToData
srt
=
Cmm
[
CmmData
RelocatableReadOnlyData
(
Statics
(
lbl
srt
)
tbl
)]
srtToData
srt
=
[
CmmData
RelocatableReadOnlyData
(
Statics
(
lbl
srt
)
tbl
)]
where
tbl
=
map
(
CmmStaticLit
.
CmmLabel
)
(
reverse
(
rev_elts
srt
))
where
tbl
=
map
(
CmmStaticLit
.
CmmLabel
)
(
reverse
(
rev_elts
srt
))
-- Once we have found the CAFs, we need to do two things:
-- Once we have found the CAFs, we need to do two things:
...
@@ -336,8 +339,9 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
...
@@ -336,8 +339,9 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
localCAFInfo
_
(
CmmData
_
_
)
=
Nothing
localCAFInfo
_
(
CmmData
_
_
)
=
Nothing
localCAFInfo
cafEnv
(
CmmProc
top_info
top_l
(
CmmGraph
{
g_entry
=
entry
}))
=
localCAFInfo
cafEnv
(
CmmProc
top_info
top_l
(
CmmGraph
{
g_entry
=
entry
}))
=
case
info_tbl
top_info
of
case
info_tbl
top_info
of
CmmInfoTable
_
False
_
_
_
->
CmmInfoTable
{
cit_rep
=
rep
}
Just
(
cvtToClosureLbl
top_l
,
|
not
(
isStaticRep
rep
)
->
Just
(
cvtToClosureLbl
top_l
,
expectJust
"maybeBindCAFs"
$
mapLookup
entry
cafEnv
)
expectJust
"maybeBindCAFs"
$
mapLookup
entry
cafEnv
)
_
->
Nothing
_
->
Nothing
...
@@ -368,8 +372,6 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
...
@@ -368,8 +372,6 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
g
=
stronglyConnCompFromEdgedVertices
g
=
stronglyConnCompFromEdgedVertices
(
map
(
\
n
@
(
l
,
cafs
)
->
(
n
,
l
,
Map
.
keys
cafs
))
localCAFs
)
(
map
(
\
n
@
(
l
,
cafs
)
->
(
n
,
l
,
Map
.
keys
cafs
))
localCAFs
)
type
StackLayout
=
[
Maybe
LocalReg
]
-- Bundle the CAFs used at a procpoint.
-- Bundle the CAFs used at a procpoint.
bundleCAFs
::
CAFEnv
->
CmmTop
->
(
CAFSet
,
CmmTop
)
bundleCAFs
::
CAFEnv
->
CmmTop
->
(
CAFSet
,
CmmTop
)
bundleCAFs
cafEnv
t
@
(
CmmProc
_
_
(
CmmGraph
{
g_entry
=
entry
}))
=
bundleCAFs
cafEnv
t
@
(
CmmProc
_
_
(
CmmGraph
{
g_entry
=
entry
}))
=
...
@@ -391,20 +393,19 @@ setSRT cafs topCAFMap topSRT t =
...
@@ -391,20 +393,19 @@ setSRT cafs topCAFMap topSRT t =
Just
tbl
->
return
(
topSRT
,
[
t'
,
tbl
])
Just
tbl
->
return
(
topSRT
,
[
t'
,
tbl
])
Nothing
->
return
(
topSRT
,
[
t'
])
Nothing
->
return
(
topSRT
,
[
t'
])
type
StackLayout
=
Liveness
updInfo
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
CmmTop
->
CmmTop
updInfo
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
CmmTop
->
CmmTop
updInfo
toVars
toSrt
(
CmmProc
top_info
top_l
g
)
=
updInfo
toVars
toSrt
(
CmmProc
top_info
top_l
g
)
=
CmmProc
(
top_info
{
info_tbl
=
updInfoTbl
toVars
toSrt
(
info_tbl
top_info
)})
top_l
g
CmmProc
(
top_info
{
info_tbl
=
updInfoTbl
toVars
toSrt
(
info_tbl
top_info
)})
top_l
g
updInfo
_
_
t
=
t
updInfo
_
_
t
=
t
updInfoTbl
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
CmmInfoTable
->
CmmInfoTable
updInfoTbl
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
CmmInfoTable
->
CmmInfoTable
updInfoTbl
toVars
toSrt
(
CmmInfoTable
l
s
p
t
typeinfo
)
updInfoTbl
toVars
toSrt
info_tbl
@
(
CmmInfoTable
{})
=
CmmInfoTable
l
s
p
t
typeinfo'
=
info_tbl
{
cit_srt
=
toSrt
(
cit_srt
info_tbl
)
where
typeinfo'
=
case
typeinfo
of
,
cit_rep
=
case
cit_rep
info_tbl
of
t
@
(
ConstrInfo
_
_
_
)
->
t
StackRep
ls
->
StackRep
(
toVars
ls
)
(
FunInfo
c
s
a
d
e
)
->
FunInfo
c
(
toSrt
s
)
a
d
e
other
->
other
}
(
ThunkInfo
c
s
)
->
ThunkInfo
c
(
toSrt
s
)
(
ThunkSelectorInfo
x
s
)
->
ThunkSelectorInfo
x
(
toSrt
s
)
(
ContInfo
v
s
)
->
ContInfo
(
toVars
v
)
(
toSrt
s
)
updInfoTbl
_
_
t
@
CmmNonInfoTable
=
t
updInfoTbl
_
_
t
@
CmmNonInfoTable
=
t
----------------------------------------------------------------
----------------------------------------------------------------
...
@@ -493,3 +494,4 @@ lowerSafeForeignCall entry areaMap blocks bid m
...
@@ -493,3 +494,4 @@ lowerSafeForeignCall entry areaMap blocks bid m
resume
<**>
saveRetVals
<**>
M
.
mkLast
jump
resume
<**>
saveRetVals
<**>
M
.
mkLast
jump
return
$
blocks
`
mapUnion
`
toBlockMap
graph'
return
$
blocks
`
mapUnion
`
toBlockMap
graph'
lowerSafeForeignCall
_
_
_
_
_
_
=
panic
"lowerSafeForeignCall was passed something else"
lowerSafeForeignCall
_
_
_
_
_
_
=
panic
"lowerSafeForeignCall was passed something else"
compiler/cmm/CmmCommonBlockElim.hs
View file @
5b167f5e
...
@@ -11,7 +11,7 @@ where
...
@@ -11,7 +11,7 @@ where
import
BlockId
import
BlockId
import
Cmm
import
Cmm
import
Cmm
Expr
import
Cmm
Utils
import
Prelude
hiding
(
iterate
,
succ
,
unzip
,
zip
)
import
Prelude
hiding
(
iterate
,
succ
,
unzip
,
zip
)
import
Compiler.Hoopl
import
Compiler.Hoopl
...
...
compiler/cmm/CmmContFlowOpt.hs
View file @
5b167f5e
...
@@ -10,8 +10,7 @@ where
...
@@ -10,8 +10,7 @@ where
import
BlockId
import
BlockId
import
Cmm
import
Cmm
import
CmmDecl
import
CmmUtils
import
CmmExpr
import
qualified
OldCmm
as
Old
import
qualified
OldCmm
as
Old
import
Maybes
import
Maybes
...
@@ -22,7 +21,7 @@ import Prelude hiding (succ, unzip, zip)
...
@@ -22,7 +21,7 @@ import Prelude hiding (succ, unzip, zip)
import
Util
import
Util
------------------------------------
------------------------------------
runCmmContFlowOpts
::
Cmm
->
Cmm
runCmmContFlowOpts
::
Cmm
Pgm
->
Cmm
Pgm
runCmmContFlowOpts
prog
=
runCmmOpts
cmmCfgOpts
prog
runCmmContFlowOpts
prog
=
runCmmOpts
cmmCfgOpts
prog
oldCmmCfgOpts
::
Old
.
ListGraph
Old
.
CmmStmt
->
Old
.
ListGraph
Old
.
CmmStmt
oldCmmCfgOpts
::
Old
.
ListGraph
Old
.
CmmStmt
->
Old
.
ListGraph
Old
.
CmmStmt
...
@@ -34,18 +33,14 @@ cmmCfgOpts =
...
@@ -34,18 +33,14 @@ cmmCfgOpts =
-- Here branchChainElim can ultimately be replaced
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
-- with a more exciting combination of optimisations
runCmmOpts
::
(
g
->
g
)
->
GenCmm
d
h
g
->
GenCmm
d
h
g
runCmmOpts
::
(
g
->
g
)
->
GenCmm
Pgm
d
h
g
->
GenCmm
Pgm
d
h
g
-- Lifts a transformer on a single graph to one on the whole program
-- Lifts a transformer on a single graph to one on the whole program
runCmmOpts
opt
=
map
Procs
(
optProc
opt
)
runCmmOpts
opt
=
map
(
optProc
opt
)
optProc
::
(
g
->
g
)
->
GenCmmTop
d
h
g
->
GenCmmTop
d
h
g
optProc
::
(
g
->
g
)
->
GenCmmTop
d
h
g
->
GenCmmTop
d
h
g
optProc
_
top
@
(
CmmData
{})
=
top
optProc
_
top
@
(
CmmData
{})
=
top
optProc
opt
(
CmmProc
info
lbl
g
)
=
CmmProc
info
lbl
(
opt
g
)
optProc
opt
(
CmmProc
info
lbl
g
)
=
CmmProc
info
lbl
(
opt
g
)
------------------------------------
mapProcs
::
(
GenCmmTop
d
h
s
->
GenCmmTop
d
h
s
)
->
GenCmm
d
h
s
->
GenCmm
d
h
s
mapProcs
f
(
Cmm
tops
)
=
Cmm
(
map
f
tops
)
----------------------------------------------------------------
----------------------------------------------------------------
oldBranchChainElim
::
Old
.
ListGraph
Old
.
CmmStmt
->
Old
.
ListGraph
Old
.
CmmStmt
oldBranchChainElim
::
Old
.
ListGraph
Old
.
CmmStmt
->
Old
.
ListGraph
Old
.
CmmStmt
-- If L is not captured in an instruction, we can remove any
-- If L is not captured in an instruction, we can remove any
...
...
compiler/cmm/CmmCvt.hs
View file @
5b167f5e
...
@@ -3,91 +3,25 @@
...
@@ -3,91 +3,25 @@
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module
CmmCvt
module
CmmCvt
(
cmmToZgraph
,
cmmOfZgraph
)
(
cmmOfZgraph
)
where
where
import
BlockId
import
BlockId
import
Cmm
import
Cmm