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
5b167f5e
Commit
5b167f5e
authored
Aug 22, 2011
by
Simon Marlow
Browse files
Snapshot of codegen refactoring to share with simonpj
parent
3108accd
Changes
60
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CLabel.hs
View file @
5b167f5e
...
...
@@ -22,7 +22,7 @@ module CLabel (
mkSRTLabel
,
mkInfoTableLabel
,
mkEntryLabel
,
mkSlowEntryLabel
,
mkSlowEntryLabel
,
slowEntryFromInfoLabel
,
mkConEntryLabel
,
mkStaticConEntryLabel
,
mkRednCountsLabel
,
...
...
@@ -354,8 +354,10 @@ data DynamicLinkerLabelInfo
-- Constructing IdLabels
-- These are always local:
mkSlowEntryLabel
name
c
=
IdLabel
name
c
Slow
slowEntryFromInfoLabel
(
IdLabel
n
c
_
)
=
IdLabel
n
c
Slow
mkSRTLabel
name
c
=
IdLabel
name
c
SRT
mkSlowEntryLabel
name
c
=
IdLabel
name
c
Slow
mkRednCountsLabel
name
c
=
IdLabel
name
c
RednCounts
-- These have local & (possibly) external variants:
...
...
@@ -372,8 +374,8 @@ mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable
mkLocalConEntryLabel
c
con
=
IdLabel
con
c
ConEntry
mkLocalStaticInfoTableLabel
c
con
=
IdLabel
con
c
StaticInfoTable
mkLocalStaticConEntryLabel
c
con
=
IdLabel
con
c
StaticConEntry
mkConInfoTableLabel
name
c
=
IdLabel
name
c
ConInfoTable
mkStaticInfoTableLabel
name
c
=
IdLabel
name
c
StaticInfoTable
mkConInfoTableLabel
name
c
=
IdLabel
name
c
ConInfoTable
mkStaticInfoTableLabel
name
c
=
IdLabel
name
c
StaticInfoTable
mkConEntryLabel
name
c
=
IdLabel
name
c
ConEntry
mkStaticConEntryLabel
name
c
=
IdLabel
name
c
StaticConEntry
...
...
compiler/cmm/Cmm.hs
View file @
5b167f5e
...
...
@@ -8,39 +8,84 @@
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
#
endif
module
Cmm
(
CmmGraph
,
GenCmmGraph
(
..
),
CmmBlock
,
CmmStackInfo
(
..
),
CmmTopInfo
(
..
),
Cmm
,
CmmTop
,
CmmReplGraph
,
GenCmmReplGraph
,
CmmFwdRewrite
,
CmmBwdRewrite
,
modifyGraph
,
lastNode
,
replaceLastNode
,
insertBetween
,
ofBlockMap
,
toBlockMap
,
insertBlock
,
ofBlockList
,
toBlockList
,
bodyToBlockList
,
foldGraphBlocks
,
mapGraphNodes
,
postorderDfs
,
analFwd
,
analBwd
,
analRewFwd
,
analRewBwd
,
dataflowPassFwd
,
dataflowPassBwd
,
module
CmmNode
)
where
module
Cmm
(
-- * Cmm top-level datatypes
CmmPgm
,
GenCmmPgm
,
CmmTop
,
GenCmmTop
(
..
),
CmmGraph
,
GenCmmGraph
(
..
),
CmmBlock
,
Section
(
..
),
CmmStatics
(
..
),
CmmStatic
(
..
),
-- * Cmm graphs
CmmReplGraph
,
GenCmmReplGraph
,
CmmFwdRewrite
,
CmmBwdRewrite
,
-- * Info Tables
CmmTopInfo
(
..
),
CmmStackInfo
(
..
),
CmmInfoTable
(
..
),
ClosureTypeInfo
(
..
),
C_SRT
(
..
),
needsSRT
,
ProfilingInfo
(
..
),
ConstrDescription
,
-- * Statements, expressions and types
module
CmmNode
,
module
CmmExpr
,
)
where
import
CLabel
import
BlockId
import
CmmDecl
import
CmmNode
import
OptimizationFuel
as
F
import
SMRep
import
UniqSupply
import
CmmExpr
import
Compiler.Hoopl
import
Control.Monad
import
Data.Maybe
import
Panic
import
Data.Word
(
Word8
)
#
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
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))
type
CmmFwdRewrite
f
=
FwdRewrite
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
}
type
Cmm
=
GenCmm
CmmStatics
CmmTopInfo
CmmGraph
type
CmmTop
=
GenCmmTop
CmmStatics
CmmTopInfo
CmmGraph
-------------------------------------------------
-- Manipulating CmmGraphs
modifyGraph
::
(
Graph
n
C
C
->
Graph
n'
C
C
)
->
GenCmmGraph
n
->
GenCmmGraph
n'
modifyGraph
f
g
=
CmmGraph
{
g_entry
=
g_entry
g
,
g_graph
=
f
(
g_graph
g
)}
toBlockMap
::
CmmGraph
->
LabelMap
CmmBlock
toBlockMap
(
CmmGraph
{
g_graph
=
GMany
NothingO
body
NothingO
})
=
body
ofBlockMap
::
BlockId
->
LabelMap
CmmBlock
->
CmmGraph
ofBlockMap
entry
bodyMap
=
CmmGraph
{
g_entry
=
entry
,
g_graph
=
GMany
NothingO
bodyMap
NothingO
}
insertBlock
::
CmmBlock
->
LabelMap
CmmBlock
->
LabelMap
CmmBlock
insertBlock
block
map
=
ASSERT
(
isNothing
$
mapLookup
id
map
)
mapInsert
id
block
map
where
id
=
entryLabel
block
toBlockList
::
CmmGraph
->
[
CmmBlock
]
toBlockList
g
=
mapElems
$
toBlockMap
g
ofBlockList
::
BlockId
->
[
CmmBlock
]
->
CmmGraph
ofBlockList
entry
blocks
=
CmmGraph
{
g_entry
=
entry
,
g_graph
=
GMany
NothingO
body
NothingO
}
where
body
=
foldr
addBlock
emptyBody
blocks
bodyToBlockList
::
Body
CmmNode
->
[
CmmBlock
]
bodyToBlockList
body
=
mapElems
body
mapGraphNodes
::
(
CmmNode
C
O
->
CmmNode
C
O
,
CmmNode
O
O
->
CmmNode
O
O
,
CmmNode
O
C
->
CmmNode
O
C
)
->
CmmGraph
->
CmmGraph
mapGraphNodes
funs
@
(
mf
,
_
,
_
)
g
=
ofBlockMap
(
entryLabel
$
mf
$
CmmEntry
$
g_entry
g
)
$
mapMap
(
blockMapNodes3
funs
)
$
toBlockMap
g
foldGraphBlocks
::
(
CmmBlock
->
a
->
a
)
->
a
->
CmmGraph
->
a
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,
-- 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
)
data
CmmStackInfo
=
StackInfo
{
arg_space
::
ByteOff
,
-- XXX: comment?
updfr_space
::
Maybe
ByteOff
-- XXX: comment?
}
-- | Info table as a haskell data type
data
CmmInfoTable
=
CmmInfoTable
{
cit_lbl
::
CLabel
,
-- Info table label
cit_rep
::
SMRep
,
cit_prof
::
ProfilingInfo
,
cit_srt
::
C_SRT
}
|
CmmNonInfoTable
-- Procedure doesn't need an info table
data
ProfilingInfo
=
NoProfilingInfo
|
ProfilingInfo
[
Word8
]
[
Word8
]
-- closure_type, closure_desc
-- C_SRT is what StgSyn.SRT gets translated to...
-- we add a label for the table, and expect only the 'offset/length' form
data
C_SRT
=
NoC_SRT
|
C_SRT
!
CLabel
!
WordOff
!
StgHalfWord
{-bitmap or escape-}
deriving
(
Eq
)
needsSRT
::
C_SRT
->
Bool
needsSRT
NoC_SRT
=
False
needsSRT
(
C_SRT
_
_
_
)
=
True
-----------------------------------------------------------------------------
-- Static Data
-----------------------------------------------------------------------------
data
Section
=
Text
|
Data
|
ReadOnlyData
|
RelocatableReadOnlyData
|
UninitialisedData
|
ReadOnlyData16
-- .rodata.cst16 on x86_64, 16-byte aligned
|
OtherSection
String
data
CmmStatic
=
CmmStaticLit
CmmLit
-- a literal value, size given by cmmLitRep of the literal.
|
CmmUninitialised
Int
-- uninitialised data, N bytes long
|
CmmString
[
Word8
]
-- string of 8-bit values only, not zero terminated.
data
CmmStatics
=
Statics
CLabel
-- Label of statics
[
CmmStatic
]
-- The static data itself
compiler/cmm/CmmBuildInfoTables.hs
View file @
5b167f5e
...
...
@@ -11,11 +11,16 @@ module CmmBuildInfoTables
,
TopSRT
,
emptySRT
,
srtToData
,
bundleCAFs
,
lowerSafeForeignCalls
,
cafTransfers
,
liveSlotTransfers
)
,
cafTransfers
,
liveSlotTransfers
,
mkLiveness
)
where
#
include
"HsVersions.h"
-- These should not be imported here!
import
StgCmmForeign
import
StgCmmUtils
import
Constants
import
Digraph
import
qualified
Prelude
as
P
...
...
@@ -26,8 +31,7 @@ import BlockId
import
Bitmap
import
CLabel
import
Cmm
import
CmmDecl
import
CmmExpr
import
CmmUtils
import
CmmStackLayout
import
Module
import
FastString
...
...
@@ -41,9 +45,6 @@ import Name
import
OptimizationFuel
import
Outputable
import
SMRep
import
StgCmmClosure
import
StgCmmForeign
import
StgCmmUtils
import
UniqSupply
import
Compiler.Hoopl
...
...
@@ -87,13 +88,14 @@ type RegSlotInfo
,
LocalReg
-- 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
=
-- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
-- ppr liveSlots) $
-- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
res
where
res
=
reverse
$
slotsToList
youngByte
liveSlots
[]
where
res
=
mkLiveness
(
reverse
$
slotsToList
youngByte
liveSlots
[]
)
slotsToList
::
Int
->
[
RegSlotInfo
]
->
[
Maybe
LocalReg
]
->
[
Maybe
LocalReg
]
-- n starts at youngByte and is decremented down to oldByte
...
...
@@ -160,8 +162,9 @@ live_ptrs oldByte slotEnv areaMap bid =
-- is not the successor of a call.
setInfoTableStackMap
::
SlotEnv
->
AreaMap
->
CmmTop
->
CmmTop
setInfoTableStackMap
slotEnv
areaMap
t
@
(
CmmProc
(
TopInfo
{
stack_info
=
StackInfo
{
updfr_space
=
Just
updfr_off
}})
_
(
CmmGraph
{
g_entry
=
eid
}))
=
updInfo
(
const
(
live_ptrs
updfr_off
slotEnv
areaMap
eid
))
id
t
t
@
(
CmmProc
(
TopInfo
{
stack_info
=
StackInfo
{
updfr_space
=
Just
updfr_off
}})
_
(
CmmGraph
{
g_entry
=
eid
}))
=
updInfo
(
const
(
live_ptrs
updfr_off
slotEnv
areaMap
eid
))
id
t
setInfoTableStackMap
_
_
t
=
t
...
...
@@ -237,8 +240,8 @@ addCAF caf srt =
,
elt_map
=
Map
.
insert
caf
last
(
elt_map
srt
)
}
where
last
=
next_elt
srt
srtToData
::
TopSRT
->
Cmm
srtToData
srt
=
Cmm
[
CmmData
RelocatableReadOnlyData
(
Statics
(
lbl
srt
)
tbl
)]
srtToData
::
TopSRT
->
Cmm
Pgm
srtToData
srt
=
[
CmmData
RelocatableReadOnlyData
(
Statics
(
lbl
srt
)
tbl
)]
where
tbl
=
map
(
CmmStaticLit
.
CmmLabel
)
(
reverse
(
rev_elts
srt
))
-- Once we have found the CAFs, we need to do two things:
...
...
@@ -336,9 +339,10 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
localCAFInfo
_
(
CmmData
_
_
)
=
Nothing
localCAFInfo
cafEnv
(
CmmProc
top_info
top_l
(
CmmGraph
{
g_entry
=
entry
}))
=
case
info_tbl
top_info
of
CmmInfoTable
_
False
_
_
_
->
Just
(
cvtToClosureLbl
top_l
,
expectJust
"maybeBindCAFs"
$
mapLookup
entry
cafEnv
)
CmmInfoTable
{
cit_rep
=
rep
}
|
not
(
isStaticRep
rep
)
->
Just
(
cvtToClosureLbl
top_l
,
expectJust
"maybeBindCAFs"
$
mapLookup
entry
cafEnv
)
_
->
Nothing
-- Once we have the local CAF sets for some (possibly) mutually
...
...
@@ -368,8 +372,6 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
g
=
stronglyConnCompFromEdgedVertices
(
map
(
\
n
@
(
l
,
cafs
)
->
(
n
,
l
,
Map
.
keys
cafs
))
localCAFs
)
type
StackLayout
=
[
Maybe
LocalReg
]
-- Bundle the CAFs used at a procpoint.
bundleCAFs
::
CAFEnv
->
CmmTop
->
(
CAFSet
,
CmmTop
)
bundleCAFs
cafEnv
t
@
(
CmmProc
_
_
(
CmmGraph
{
g_entry
=
entry
}))
=
...
...
@@ -391,20 +393,19 @@ setSRT cafs topCAFMap topSRT t =
Just
tbl
->
return
(
topSRT
,
[
t'
,
tbl
])
Nothing
->
return
(
topSRT
,
[
t'
])
type
StackLayout
=
Liveness
updInfo
::
(
StackLayout
->
StackLayout
)
->
(
C_SRT
->
C_SRT
)
->
CmmTop
->
CmmTop
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
(
CmmInfoTable
l
s
p
t
typeinfo
)
=
CmmInfoTable
l
s
p
t
typeinfo'
where
typeinfo'
=
case
typeinfo
of
t
@
(
ConstrInfo
_
_
_
)
->
t
(
FunInfo
c
s
a
d
e
)
->
FunInfo
c
(
toSrt
s
)
a
d
e
(
ThunkInfo
c
s
)
->
ThunkInfo
c
(
toSrt
s
)
(
ThunkSelectorInfo
x
s
)
->
ThunkSelectorInfo
x
(
toSrt
s
)
(
ContInfo
v
s
)
->
ContInfo
(
toVars
v
)
(
toSrt
s
)
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
----------------------------------------------------------------
...
...
@@ -493,3 +494,4 @@ lowerSafeForeignCall entry areaMap blocks bid m
resume
<**>
saveRetVals
<**>
M
.
mkLast
jump
return
$
blocks
`
mapUnion
`
toBlockMap
graph'
lowerSafeForeignCall
_
_
_
_
_
_
=
panic
"lowerSafeForeignCall was passed something else"
compiler/cmm/CmmCommonBlockElim.hs
View file @
5b167f5e
...
...
@@ -11,7 +11,7 @@ where
import
BlockId
import
Cmm
import
Cmm
Expr
import
Cmm
Utils
import
Prelude
hiding
(
iterate
,
succ
,
unzip
,
zip
)
import
Compiler.Hoopl
...
...
compiler/cmm/CmmContFlowOpt.hs
View file @
5b167f5e
...
...
@@ -10,8 +10,7 @@ where
import
BlockId
import
Cmm
import
CmmDecl
import
CmmExpr
import
CmmUtils
import
qualified
OldCmm
as
Old
import
Maybes
...
...
@@ -22,7 +21,7 @@ import Prelude hiding (succ, unzip, zip)
import
Util
------------------------------------
runCmmContFlowOpts
::
Cmm
->
Cmm
runCmmContFlowOpts
::
Cmm
Pgm
->
Cmm
Pgm
runCmmContFlowOpts
prog
=
runCmmOpts
cmmCfgOpts
prog
oldCmmCfgOpts
::
Old
.
ListGraph
Old
.
CmmStmt
->
Old
.
ListGraph
Old
.
CmmStmt
...
...
@@ -34,18 +33,14 @@ cmmCfgOpts =
-- Here branchChainElim can ultimately be replaced
-- 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
runCmmOpts
opt
=
map
Procs
(
optProc
opt
)
runCmmOpts
opt
=
map
(
optProc
opt
)
optProc
::
(
g
->
g
)
->
GenCmmTop
d
h
g
->
GenCmmTop
d
h
g
optProc
_
top
@
(
CmmData
{})
=
top
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
-- If L is not captured in an instruction, we can remove any
...
...
compiler/cmm/CmmCvt.hs
View file @
5b167f5e
...
...
@@ -3,91 +3,25 @@
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module
CmmCvt
(
cmmToZgraph
,
cmmOfZgraph
)
(
cmmOfZgraph
)
where
import
BlockId
import
Cmm
import
CmmDecl
import
CmmExpr
import
MkGraph
import
CmmUtils
import
qualified
OldCmm
as
Old
import
OldPprCmm
()
import
Platform
import
Compiler.Hoopl
hiding
((
<*>
),
mkLabel
,
mkBranch
)
import
Control.Monad
import
Data.Maybe
import
Maybes
import
Outputable
import
UniqSupply
cmmToZgraph
::
Platform
->
Old
.
Cmm
->
UniqSM
Cmm
cmmOfZgraph
::
Cmm
->
Old
.
Cmm
cmmToZgraph
platform
(
Cmm
tops
)
=
liftM
Cmm
$
mapM
mapTop
tops
where
mapTop
(
CmmProc
(
Old
.
CmmInfo
_
_
info_tbl
)
l
g
)
=
do
(
stack_info
,
g
)
<-
toZgraph
platform
(
showSDoc
$
ppr
l
)
g
return
$
CmmProc
(
TopInfo
{
info_tbl
=
info_tbl
,
stack_info
=
stack_info
})
l
g
mapTop
(
CmmData
s
ds
)
=
return
$
CmmData
s
ds
cmmOfZgraph
(
Cmm
tops
)
=
Cmm
$
map
mapTop
tops
cmmOfZgraph
::
CmmPgm
->
Old
.
CmmPgm
cmmOfZgraph
tops
=
map
mapTop
tops
where
mapTop
(
CmmProc
h
l
g
)
=
CmmProc
(
Old
.
CmmInfo
Nothing
Nothing
(
info_tbl
h
))
l
(
ofZgraph
g
)
mapTop
(
CmmData
s
ds
)
=
CmmData
s
ds
toZgraph
::
Platform
->
String
->
Old
.
ListGraph
Old
.
CmmStmt
->
UniqSM
(
CmmStackInfo
,
CmmGraph
)
toZgraph
_
_
(
Old
.
ListGraph
[]
)
=
do
g
<-
lgraphOfAGraph
emptyAGraph
return
(
StackInfo
{
arg_space
=
0
,
updfr_space
=
Nothing
},
g
)
toZgraph
platform
fun_name
g
@
(
Old
.
ListGraph
(
Old
.
BasicBlock
id
ss
:
other_blocks
))
=
let
(
offset
,
entry
)
=
mkCallEntry
NativeNodeCall
[]
in
do
g
<-
labelAGraph
id
$
entry
<*>
mkStmts
ss
<*>
foldr
addBlock
emptyAGraph
other_blocks
return
(
StackInfo
{
arg_space
=
offset
,
updfr_space
=
Nothing
},
g
)
where
addBlock
(
Old
.
BasicBlock
id
ss
)
g
=
mkLabel
id
<*>
mkStmts
ss
<*>
g
updfr_sz
=
0
-- panic "upd frame size lost in cmm conversion"
mkStmts
(
Old
.
CmmNop
:
ss
)
=
mkNop
<*>
mkStmts
ss
mkStmts
(
Old
.
CmmComment
s
:
ss
)
=
mkComment
s
<*>
mkStmts
ss
mkStmts
(
Old
.
CmmAssign
l
r
:
ss
)
=
mkAssign
l
r
<*>
mkStmts
ss
mkStmts
(
Old
.
CmmStore
l
r
:
ss
)
=
mkStore
l
r
<*>
mkStmts
ss
mkStmts
(
Old
.
CmmCall
(
Old
.
CmmCallee
f
conv
)
res
args
(
Old
.
CmmSafe
_
)
Old
.
CmmMayReturn
:
ss
)
=
mkCall
f
(
conv'
,
conv'
)
(
map
Old
.
hintlessCmm
res
)
(
map
Old
.
hintlessCmm
args
)
updfr_sz
<*>
mkStmts
ss
where
conv'
=
Foreign
(
ForeignConvention
conv
[]
[]
)
-- JD: DUBIOUS
mkStmts
(
Old
.
CmmCall
(
Old
.
CmmPrim
{})
_
_
(
Old
.
CmmSafe
_
)
_
:
_
)
=
panic
"safe call to a primitive CmmPrim CallishMachOp"
mkStmts
(
Old
.
CmmCall
f
res
args
Old
.
CmmUnsafe
Old
.
CmmMayReturn
:
ss
)
=
mkUnsafeCall
(
convert_target
f
res
args
)
(
strip_hints
res
)
(
strip_hints
args
)
<*>
mkStmts
ss
mkStmts
(
Old
.
CmmCondBranch
e
l
:
fbranch
)
=
mkCmmIfThenElse
e
(
mkBranch
l
)
(
mkStmts
fbranch
)
mkStmts
(
last
:
[]
)
=
mkLast
last
mkStmts
[]
=
bad
"fell off end"
mkStmts
(
_
:
_
:
_
)
=
bad
"last node not at end"
bad
msg
=
pprPanic
(
msg
++
" in function "
++
fun_name
)
(
pprPlatform
platform
g
)
mkLast
(
Old
.
CmmCall
(
Old
.
CmmCallee
f
conv
)
[]
args
_
Old
.
CmmNeverReturns
)
=
mkFinalCall
f
conv
(
map
Old
.
hintlessCmm
args
)
updfr_sz
mkLast
(
Old
.
CmmCall
(
Old
.
CmmPrim
{})
_
_
_
Old
.
CmmNeverReturns
)
=
panic
"Call to CmmPrim never returns?!"
mkLast
(
Old
.
CmmSwitch
scrutinee
table
)
=
mkSwitch
scrutinee
table
-- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
-- CONVENTIONS ARE HONORED?
mkLast
(
Old
.
CmmJump
tgt
args
)
=
mkJump
tgt
(
map
Old
.
hintlessCmm
args
)
updfr_sz
mkLast
(
Old
.
CmmReturn
ress
)
=
mkReturnSimple
(
map
Old
.
hintlessCmm
ress
)
updfr_sz
mkLast
(
Old
.
CmmBranch
tgt
)
=
mkBranch
tgt
mkLast
(
Old
.
CmmCall
_f
(
_
:
_
)
_args
_
Old
.
CmmNeverReturns
)
=
panic
"Call never returns but has results?!"
mkLast
_
=
panic
"fell off end of block"
strip_hints
::
[
Old
.
CmmHinted
a
]
->
[
a
]
strip_hints
=
map
Old
.
hintlessCmm