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
ab67c2a4
Commit
ab67c2a4
authored
Dec 19, 2011
by
Simon Marlow
Browse files
More codegen refactoring with simonpj
parent
b4018aaa
Changes
11
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmCommonBlockElim.hs
View file @
ab67c2a4
...
...
@@ -28,7 +28,9 @@ import Unique
my_trace
::
String
->
SDoc
->
a
->
a
my_trace
=
if
False
then
pprTrace
else
\
_
_
a
->
a
-- Eliminate common blocks:
-- -----------------------------------------------------------------------------
-- Eliminate common blocks
-- If two blocks are identical except for the label on the first node,
-- then we can eliminate one of the blocks. To ensure that the semantics
-- of the program are preserved, we have to rewrite each predecessor of the
...
...
@@ -42,59 +44,49 @@ my_trace = if False then pprTrace else \_ _ a -> a
-- TODO: Use optimization fuel
elimCommonBlocks
::
CmmGraph
->
CmmGraph
elimCommonBlocks
g
=
upd_graph
g
.
snd
$
iterate
common_block
reset
hashed_blocks
(
emptyUFM
,
mapEmpty
)
where
hashed_blocks
=
map
(
\
b
->
(
hash_block
b
,
b
))
(
reverse
(
postorderDfs
g
))
reset
(
_
,
subst
)
=
(
emptyUFM
,
subst
)
elimCommonBlocks
g
=
replaceLabels
env
g
where
env
=
iterate
hashed_blocks
mapEmpty
hashed_blocks
=
map
(
\
b
->
(
hash_block
b
,
b
))
$
postorderDfs
g
-- Iterate over the blocks until convergence
iterate
::
(
t
->
a
->
(
Bool
,
t
))
->
(
t
->
t
)
->
[
a
]
->
t
->
t
iterate
upd
reset
blocks
state
=
case
foldl
upd'
(
False
,
state
)
blocks
of
(
True
,
state'
)
->
iterate
upd
reset
blocks
(
reset
state'
)
(
False
,
state'
)
->
state'
where
upd'
(
b
,
s
)
a
=
let
(
b'
,
s'
)
=
upd
s
a
in
(
b
||
b'
,
s'
)
-- lift to track changes
iterate
::
[(
HashCode
,
CmmBlock
)]
->
BlockEnv
BlockId
->
BlockEnv
BlockId
iterate
blocks
subst
=
case
foldl
common_block
(
False
,
emptyUFM
,
subst
)
blocks
of
(
changed
,
_
,
subst
)
|
changed
->
iterate
blocks
subst
|
otherwise
->
subst
type
State
=
(
ChangeFlag
,
UniqFM
[
CmmBlock
],
BlockEnv
BlockId
)
type
ChangeFlag
=
Bool
type
HashCode
=
Int
-- Try to find a block that is equal (or ``common'') to b.
type
BidMap
=
BlockEnv
BlockId
type
State
=
(
UniqFM
[
CmmBlock
],
BidMap
)
common_block
::
(
Outputable
h
,
Uniquable
h
)
=>
State
->
(
h
,
CmmBlock
)
->
(
Bool
,
State
)
common_block
(
bmap
,
subst
)
(
hash
,
b
)
=
common_block
::
State
->
(
HashCode
,
CmmBlock
)
->
State
common_block
(
old_change
,
bmap
,
subst
)
(
hash
,
b
)
=
case
lookupUFM
bmap
hash
of
Just
bs
->
case
(
List
.
find
(
eqBlockBodyWith
(
eqBid
subst
)
b
)
bs
,
mapLookup
bid
subst
)
of
(
Just
b'
,
Nothing
)
->
addSubst
b'
(
Just
b'
,
Just
b''
)
|
entryLabel
b'
/=
b''
->
addSubst
b'
_
->
(
Fals
e
,
(
addToUFM
bmap
hash
(
b
:
bs
),
subst
)
)
Nothing
->
(
Fals
e
,
(
addToUFM
bmap
hash
[
b
],
subst
))
_
->
(
old_chang
e
,
addToUFM
bmap
hash
(
b
:
bs
),
subst
)
Nothing
->
(
old_chang
e
,
(
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
))
-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
upd_graph
::
CmmGraph
->
BidMap
->
CmmGraph
upd_graph
g
subst
=
mapGraphNodes
(
id
,
middle
,
last
)
g
where
middle
=
mapExpDeep
exp
last
l
=
last'
(
mapExpDeep
exp
l
)
last'
::
CmmNode
O
C
->
CmmNode
O
C
last'
(
CmmBranch
bid
)
=
CmmBranch
$
sub
bid
last'
(
CmmCondBranch
p
t
f
)
=
cond
p
(
sub
t
)
(
sub
f
)
last'
(
CmmCall
t
(
Just
bid
)
a
r
o
)
=
CmmCall
t
(
Just
$
sub
bid
)
a
r
o
last'
l
@
(
CmmCall
_
Nothing
_
_
_
)
=
l
last'
(
CmmForeignCall
t
r
a
bid
u
i
)
=
CmmForeignCall
t
r
a
(
sub
bid
)
u
i
last'
(
CmmSwitch
e
bs
)
=
CmmSwitch
e
$
map
(
liftM
sub
)
bs
cond
p
t
f
=
if
t
==
f
then
CmmBranch
t
else
CmmCondBranch
p
t
f
exp
(
CmmStackSlot
(
CallArea
(
Young
id
))
off
)
=
CmmStackSlot
(
CallArea
(
Young
(
sub
id
)))
off
exp
(
CmmLit
(
CmmBlock
id
))
=
CmmLit
(
CmmBlock
(
sub
id
))
exp
e
=
e
sub
=
lookupBid
subst
(
True
,
bmap
,
mapInsert
bid
(
entryLabel
b'
)
subst
)
-- -----------------------------------------------------------------------------
-- Hashing and equality on blocks
-- Below here is mostly boilerplate: hashing blocks ignoring labels,
-- and comparing blocks modulo a label mapping.
-- To speed up comparisons, we hash each basic block modulo labels.
-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough.
hash_block
::
CmmBlock
->
Int
hash_block
::
CmmBlock
->
HashCode
hash_block
block
=
fromIntegral
(
foldBlockNodesB3
(
hash_fst
,
hash_mid
,
hash_lst
)
block
(
0
::
Word32
)
.&.
(
0x7fffffff
::
Word32
))
-- UniqFM doesn't like negative Ints
...
...
@@ -107,7 +99,7 @@ hash_block block =
hash_node
(
CmmAssign
r
e
)
=
hash_reg
r
+
hash_e
e
hash_node
(
CmmStore
e
e'
)
=
hash_e
e
+
hash_e
e'
hash_node
(
CmmUnsafeForeignCall
t
_
as
)
=
hash_tgt
t
+
hash_list
hash_e
as
hash_node
(
CmmBranch
_
)
=
23
--
would be great to hash these properly
hash_node
(
CmmBranch
_
)
=
23
--
NB. ignore the label
hash_node
(
CmmCondBranch
p
_
_
)
=
hash_e
p
hash_node
(
CmmCall
e
_
_
_
_
)
=
hash_e
e
hash_node
(
CmmForeignCall
t
_
_
_
_
_
)
=
hash_tgt
t
...
...
@@ -143,9 +135,9 @@ hash_block block =
-- Utilities: equality and substitution on the graph.
-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
eqBid
::
B
idMap
->
BlockId
->
BlockId
->
Bool
eqBid
::
B
lockEnv
BlockId
->
BlockId
->
BlockId
->
Bool
eqBid
subst
bid
bid'
=
lookupBid
subst
bid
==
lookupBid
subst
bid'
lookupBid
::
B
idMap
->
BlockId
->
BlockId
lookupBid
::
B
lockEnv
BlockId
->
BlockId
->
BlockId
lookupBid
subst
bid
=
case
mapLookup
bid
subst
of
Just
bid
->
lookupBid
subst
bid
Nothing
->
bid
...
...
compiler/cmm/CmmContFlowOpt.hs
View file @
ab67c2a4
...
...
@@ -2,8 +2,10 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
module
CmmContFlowOpt
(
runCmmContFlowOpts
,
removeUnreachableBlocks
,
replaceBranches
(
cmmCfgOpts
,
runCmmContFlowOpts
,
removeUnreachableBlocks
,
replaceLabels
)
where
...
...
@@ -28,100 +30,140 @@ runCmmContFlowOpts :: CmmGroup -> CmmGroup
runCmmContFlowOpts
=
map
(
optProc
cmmCfgOpts
)
cmmCfgOpts
::
CmmGraph
->
CmmGraph
cmmCfgOpts
=
removeUnreachableBlocks
.
blockConcat
.
branchChainElim
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
cmmCfgOpts
=
removeUnreachableBlocks
.
blockConcat
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
-----------------------------------------------------------------------------
--
-- B
ranch Chain Elimi
nation
-- B
lock concate
nation
--
-----------------------------------------------------------------------------
-- | Remove any basic block of the form L: goto L', and replace L with
-- L' everywhere else, unless L is the successor of a call instruction
-- and L' is the entry block. You don't want to set the successor of a
-- function call to the entry block because there is no good way to
-- store both the infotables for the call and from the callee, while
-- putting the stack pointer in a consistent place.
-- This optimisation does two things:
-- - If a block finishes with an unconditional branch, then we may
-- be able to concatenate the block it points to and remove the
-- branch. We do this either if the destination block is small
-- (e.g. just another branch), or if this is the only jump to
-- this particular destination block.
--
-- - If a block finishes in a call whose continuation block is a
-- goto, then we can shortcut the destination, making the
-- continuation block the destination of the goto.
--
-- Both transformations are improved by working from the end of the
-- graph towards the beginning, because we may be able to perform many
-- shortcuts in one go.
-- We need to walk over the blocks from the end back to the
-- beginning. We are going to maintain the "current" graph
-- (BlockEnv CmmBlock) as we go, and also a mapping from BlockId
-- to BlockId, representing continuation labels that we have
-- renamed. This latter mapping is important because we might
-- shortcut a CmmCall continuation. For example:
--
-- Sp[0] = L
-- call g returns to L
--
-- L: goto M
--
-- JD isn't quite sure when it's safe to share continuations for different
-- function calls -- have to think about where the SP will be,
-- so we'll table that problem for now by leaving all call successors alone.
branchChainElim
::
CmmGraph
->
CmmGraph
branchChainElim
g
|
null
lone_branch_blocks
=
g
-- No blocks to remove
|
otherwise
=
{- pprTrace "branchChainElim" (ppr forest) $ -}
replaceLabels
(
mapFromList
edges
)
g
-- M: ...
--
-- So when we shortcut the L block, we need to replace not only
-- the continuation of the call, but also references to L in the
-- code (e.g. the assignment Sp[0] = L). So we keep track of
-- which labels we have renamed and apply the mapping at the end
-- with replaceLabels.
blockConcat
::
CmmGraph
->
CmmGraph
blockConcat
g
@
CmmGraph
{
g_entry
=
entry_id
}
=
replaceLabels
shortcut_map
$
ofBlockMap
new_entry
new_blocks
where
blocks
=
toBlockList
g
lone_branch_blocks
::
[(
BlockId
,
BlockId
)]
-- each (L,K) is a block of the form
-- L : goto K
lone_branch_blocks
=
mapCatMaybes
isLoneBranch
blocks
call_succs
=
foldl
add
emptyBlockSet
blocks
where
add
::
BlockSet
->
CmmBlock
->
BlockSet
add
succs
b
=
case
lastNode
b
of
(
CmmCall
_
(
Just
k
)
_
_
_
)
->
setInsert
k
succs
(
CmmForeignCall
{
succ
=
k
})
->
setInsert
k
succs
_
->
succs
isLoneBranch
::
CmmBlock
->
Maybe
(
BlockId
,
BlockId
)
isLoneBranch
block
|
(
JustC
(
CmmEntry
id
),
[]
,
JustC
(
CmmBranch
target
))
<-
blockToNodeList
block
,
not
(
setMember
id
call_succs
)
=
Just
(
id
,
target
)
|
otherwise
=
Nothing
-- We build a graph from lone_branch_blocks (every node has only
-- one out edge). Then we
-- - topologically sort the graph: if from A we can reach B,
-- then A occurs before B in the result list.
-- - depth-first search starting from the nodes in this list.
-- This gives us a [[node]], in which each list is a dependency
-- chain.
-- - for each list [a1,a2,...an] replace branches to ai with an.
--
-- This approach nicely deals with cycles by ignoring them.
-- Branches in a cycle will be redirected to somewhere in the
-- cycle, but we don't really care where. A cycle should be dead code,
-- and so will be eliminated by removeUnreachableBlocks.
--
fromNode
(
b
,
_
)
=
b
toNode
a
=
(
a
,
a
)
all_block_ids
::
LabelSet
all_block_ids
=
setFromList
(
map
fst
lone_branch_blocks
)
`
setUnion
`
setFromList
(
map
snd
lone_branch_blocks
)
forest
=
dfsTopSortG
$
graphFromVerticesAndAdjacency
nodes
lone_branch_blocks
where
nodes
=
map
toNode
$
setElems
$
all_block_ids
edges
=
[
(
fromNode
y
,
fromNode
x
)
|
(
x
:
xs
)
<-
map
reverse
forest
,
y
<-
xs
]
-- we might be able to shortcut the entry BlockId itself
new_entry
|
Just
entry_blk
<-
mapLookup
entry_id
new_blocks
,
Just
dest
<-
canShortcut
entry_blk
=
dest
|
otherwise
=
entry_id
----------------------------------------------------------------
blocks
=
postorderDfs
g
(
new_blocks
,
shortcut_map
)
=
foldr
maybe_concat
(
toBlockMap
g
,
mapEmpty
)
blocks
maybe_concat
::
CmmBlock
->
(
BlockEnv
CmmBlock
,
BlockEnv
BlockId
)
->
(
BlockEnv
CmmBlock
,
BlockEnv
BlockId
)
maybe_concat
block
unchanged
@
(
blocks
,
shortcut_map
)
=
|
CmmBranch
b'
<-
last
,
Just
blk'
<-
mapLookup
b'
blocks
,
shouldConcatWith
b'
blocks
->
(
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
)
-- replaceLabels will substitute dest for b' everywhere, later
|
otherwise
=
unchanged
where
(
head
,
last
)
=
blockTail
block
bid
=
entryLabel
b
shouldConcatWith
b
block
|
num_preds
b
==
1
=
True
-- only one predecessor: go for it
|
okToDuplicate
block
=
True
-- short enough to duplicate
|
otherwise
=
False
where
num_preds
bid
=
mapLookup
bid
backEdges
`
orElse
`
0
canShortcut
::
Block
C
C
->
Maybe
BlockId
canShortcut
block
|
(
_
,
middle
,
CmmBranch
dest
)
<-
blockHeadTail
block
,
isEmptyBlock
middle
=
Just
dest
|
otherwise
=
Nothing
backEdges
::
BlockEnv
Int
-- number of predecessors for each block
backEdges
=
mapMap
setSize
$
predMap
blocks
ToDo
:
add
1
for
the
entry
id
splice
::
Block
CmmNode
C
O
->
CmmBlock
->
CmmBlock
splice
head
rest
=
head
`
cat
`
snd
(
blockHead
rest
)
callContinuation_maybe
::
CmmNode
O
C
->
Maybe
BlockId
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
block
=
case
blockToNodeList
block
of
(
_
,
m
,
_
)
->
null
m
-- cheap and cheerful; we might expand this in the future to
-- e.g. spot blocks that represent a single instruction or two
------------------------------------------------------------------------
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
replaceLabels
::
BlockEnv
BlockId
->
CmmGraph
->
CmmGraph
replaceLabels
env
=
replace_eid
.
mapGraphNodes1
txnode
replaceLabels
env
g
|
isEmptyMap
env
=
g
|
otherwise
=
replace_eid
.
mapGraphNodes1
txnode
where
replace_eid
g
=
g
{
g_entry
=
lookup
(
g_entry
g
)}
lookup
id
=
mapLookup
id
env
`
orElse
`
id
txnode
::
CmmNode
e
x
->
CmmNode
e
x
txnode
(
CmmBranch
bid
)
=
CmmBranch
(
lookup
bid
)
txnode
(
CmmCondBranch
p
t
f
)
=
CmmCondBranch
(
exp
p
)
(
lookup
t
)
(
lookup
f
)
txnode
(
CmmCondBranch
p
t
f
)
=
mk
CmmCondBranch
(
exp
p
)
(
lookup
t
)
(
lookup
f
)
txnode
(
CmmSwitch
e
arms
)
=
CmmSwitch
(
exp
e
)
(
map
(
liftM
lookup
)
arms
)
txnode
(
CmmCall
t
k
a
res
r
)
=
CmmCall
(
exp
t
)
(
liftM
lookup
k
)
a
res
r
txnode
fc
@
CmmForeignCall
{}
=
fc
{
args
=
map
exp
(
args
fc
)
...
...
@@ -133,81 +175,18 @@ replaceLabels env =
exp
(
CmmStackSlot
(
CallArea
(
Young
id
))
i
)
=
CmmStackSlot
(
CallArea
(
Young
(
lookup
id
)))
i
exp
e
=
e
replaceBranches
::
BlockEnv
BlockId
->
CmmGraph
->
CmmGraph
replaceBranches
env
g
=
mapGraphNodes
(
id
,
id
,
last
)
g
where
last
::
CmmNode
O
C
->
CmmNode
O
C
last
(
CmmBranch
id
)
=
CmmBranch
(
lookup
id
)
last
(
CmmCondBranch
e
ti
fi
)
=
CmmCondBranch
e
(
lookup
ti
)
(
lookup
fi
)
last
(
CmmSwitch
e
tbl
)
=
CmmSwitch
e
(
map
(
fmap
lookup
)
tbl
)
last
l
@
(
CmmCall
{})
=
l
last
l
@
(
CmmForeignCall
{})
=
l
lookup
id
=
fmap
lookup
(
mapLookup
id
env
)
`
orElse
`
id
-- XXX: this is a recursive lookup, it follows chains until the lookup
-- returns Nothing, at which point we return the last BlockId
mkCmmCondBranch
::
CmmExpr
->
CmmExpr
->
CmmExpr
->
CmmExpr
mkCmmCondBranch
p
t
f
=
if
t
==
f
then
CmmBranch
t
else
CmmCondBranch
p
t
f
----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
predMap
::
[
CmmBlock
]
->
BlockEnv
BlockSet
predMap
blocks
=
foldr
add_preds
mapEmpty
blocks
-- find the back edges
where
add_preds
block
env
=
foldl
(
add
(
entryLabel
block
))
env
(
successors
block
)
add
bid
env
b'
=
mapInsert
b'
(
setInsert
bid
(
mapLookup
b'
env
`
orElse
`
setEmpty
))
env
-----------------------------------------------------------------------------
--
-- Block concatenation
--
-----------------------------------------------------------------------------
-- If a block B branches to a label L, L is not the entry block,
-- and L has no other predecessors,
-- then we can splice the block starting with L onto the end of B.
-- Order matters, so we work bottom up (reverse postorder DFS).
-- This optimization can be inhibited by unreachable blocks, but
-- the reverse postorder DFS returns only reachable blocks.
--
-- To ensure correctness, we have to make sure that the BlockId of the block
-- we are about to eliminate is not named in another instruction.
--
-- Note: This optimization does _not_ subsume branch chain elimination.
blockConcat
::
CmmGraph
->
CmmGraph
blockConcat
g
@
(
CmmGraph
{
g_entry
=
eid
})
=
replaceLabels
concatMap
$
ofBlockMap
(
g_entry
g
)
blocks'
where
blocks
=
postorderDfs
g
(
blocks'
,
concatMap
)
=
foldr
maybe_concat
(
toBlockMap
g
,
mapEmpty
)
$
blocks
maybe_concat
::
CmmBlock
->
(
LabelMap
CmmBlock
,
LabelMap
Label
)
->
(
LabelMap
CmmBlock
,
LabelMap
Label
)
maybe_concat
b
unchanged
@
(
blocks'
,
concatMap
)
=
let
bid
=
entryLabel
b
in
case
blockToNodeList
b
of
(
JustC
h
,
m
,
JustC
(
CmmBranch
b'
))
->
if
canConcatWith
b'
then
(
mapInsert
bid
(
splice
blocks'
h
m
b'
)
blocks'
,
mapInsert
b'
bid
concatMap
)
else
unchanged
_
->
unchanged
num_preds
bid
=
liftM
setSize
(
mapLookup
bid
backEdges
)
`
orElse
`
0
canConcatWith
b'
=
b'
/=
eid
&&
num_preds
b'
==
1
backEdges
=
predMap
blocks
splice
::
forall
map
n
e
x
.
IsMap
map
=>
map
(
Block
n
e
x
)
->
n
C
O
->
[
n
O
O
]
->
KeyOf
map
->
Block
n
C
x
splice
blocks'
h
m
bid'
=
case
mapLookup
bid'
blocks'
of
Nothing
->
panic
"unknown successor block"
Just
block
|
(
_
,
m'
,
l'
)
<-
blockToNodeList
block
->
blockOfNodeList
(
JustC
h
,
(
m
++
m'
),
l'
)
-----------------------------------------------------------------------------
--
...
...
compiler/cmm/CmmExpr.hs
View file @
ab67c2a4
...
...
@@ -75,7 +75,8 @@ data Area
data
AreaId
=
Old
-- See Note [Old Area]
|
Young
BlockId
|
Young
BlockId
-- Invariant: must be a continuation BlockId
-- See Note [Continuation BlockId] in CmmNode.
deriving
(
Eq
,
Ord
)
{- Note [Old Area]
...
...
@@ -120,7 +121,11 @@ data CmmLit
-- It is also used inside the NCG during when generating
-- position-independent code.
|
CmmLabelDiffOff
CLabel
CLabel
Int
-- label1 - label2 + offset
|
CmmBlock
BlockId
-- Code label
|
CmmBlock
BlockId
-- Code label
-- Invariant: must be a continuation BlockId
-- See Note [Continuation BlockId] in CmmNode.
|
CmmHighStackMark
-- stands for the max stack space used during a procedure
deriving
Eq
...
...
compiler/cmm/CmmLint.hs
View file @
ab67c2a4
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 20
04-2006
-- (c) The University of Glasgow 20
11
--
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module
CmmLint
(
cmmLint
,
cmmLint
Top
cmmLint
)
where
import
BlockId
import
OldCmm
import
CLabel
import
Outputable
import
OldPprCmm
()
import
Constants
import
FastString
import
Platform
import
Data.Maybe
-- -----------------------------------------------------------------------------
-- Exported entry points:
cmmLint
::
(
PlatformOutputable
d
,
PlatformOutputable
h
)
=>
Platform
->
GenCmmGroup
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLint
platform
tops
=
runCmmLint
platform
(
mapM_
(
lintCmmDecl
platform
))
tops
cmmLintTop
::
(
PlatformOutputable
d
,
PlatformOutputable
h
)
=>
Platform
->
GenCmmDecl
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
cmmLintTop
platform
top
=
runCmmLint
platform
(
lintCmmDecl
platform
)
top
runCmmLint
::
PlatformOutputable
a
=>
Platform
->
(
a
->
CmmLint
b
)
->
a
->
Maybe
SDoc
runCmmLint
platform
l
p
=
case
unCL
(
l
p
)
of
Left
err
->
Just
(
vcat
[
ptext
$
sLit
(
"Cmm lint error:"
),
nest
2
err
,
ptext
$
sLit
(
"Program was:"
),
nest
2
(
pprPlatform
platform
p
)])
Right
_
->
Nothing
lintCmmDecl
::
Platform
->
(
GenCmmDecl
h
i
(
ListGraph
CmmStmt
))
->
CmmLint
()
lintCmmDecl
platform
(
CmmProc
_
lbl
(
ListGraph
blocks
))
=
addLintInfo
(
text
"in proc "
<>
pprCLabel
platform
lbl
)
$
let
labels
=
foldl
(
\
s
b
->
setInsert
(
blockId
b
)
s
)
setEmpty
blocks
in
mapM_
(
lintCmmBlock
platform
labels
)
blocks
lintCmmDecl
_
(
CmmData
{})
=
return
()
lintCmmBlock
::
Platform
->
BlockSet
->
GenBasicBlock
CmmStmt
->
CmmLint
()
lintCmmBlock
platform
labels
(
BasicBlock
id
stmts
)
=
addLintInfo
(
text
"in basic block "
<>
ppr
id
)
$
mapM_
(
lintCmmStmt
platform
labels
)
stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
-- byte/word mismatches.
lintCmmExpr
::
Platform
->
CmmExpr
->
CmmLint
CmmType
lintCmmExpr
platform
(
CmmLoad
expr
rep
)
=
do
_
<-
lintCmmExpr
platform
expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-- cmmCheckWordAddress expr
return
rep
lintCmmExpr
platform
expr
@
(
CmmMachOp
op
args
)
=
do
tys
<-
mapM
(
lintCmmExpr
platform
)
args
if
map
(
typeWidth
.
cmmExprType
)
args
==
machOpArgReps
op
then
cmmCheckMachOp
op
args
tys
else
cmmLintMachOpErr
platform
expr
(
map
cmmExprType
args
)
(
machOpArgReps
op
)
lintCmmExpr
platform
(
CmmRegOff
reg
offset
)
=
lintCmmExpr
platform
(
CmmMachOp
(
MO_Add
rep
)
[
CmmReg
reg
,
CmmLit
(
CmmInt
(
fromIntegral
offset
)
rep
)])
where
rep
=
typeWidth
(
cmmRegType
reg
)
lintCmmExpr
_
expr
=
return
(
cmmExprType
expr
)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp
::
MachOp
->
[
CmmExpr
]
->
[
CmmType
]
->
CmmLint
CmmType
cmmCheckMachOp
op
[
lit
@
(
CmmLit
(
CmmInt
{
})),
reg
@
(
CmmReg
_
)]
tys
=
cmmCheckMachOp
op
[
reg
,
lit
]
tys
cmmCheckMachOp
op
_
tys
=
return
(
machOpResultType
op
tys
)
isOffsetOp
::
MachOp
->
Bool
isOffsetOp
(
MO_Add
_
)
=
True
isOffsetOp
(
MO_Sub
_
)
=
True
isOffsetOp
_
=
False
-- This expression should be an address from which a word can be loaded:
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress
::
Platform
->
CmmExpr
->
CmmLint
()
_cmmCheckWordAddress
platform
e
@
(
CmmMachOp
op
[
arg
,
CmmLit
(
CmmInt
i
_
)])
|
isOffsetOp
op
&&
notNodeReg
arg
&&
i
`
rem
`
fromIntegral
wORD_SIZE
/=
0
=
cmmLintDubiousWordOffset
platform
e
_cmmCheckWordAddress
platform
e
@
(
CmmMachOp
op
[
CmmLit
(
CmmInt
i
_
),
arg
])
|
isOffsetOp
op
&&
notNodeReg
arg
&&
i
`
rem
`
fromIntegral
wORD_SIZE
/=
0
=
cmmLintDubiousWordOffset
platform
e
_cmmCheckWordAddress
_
_
=
return
()
-- No warnings for unaligned arithmetic with the node register,
-- which is used to extract fields from tagged constructor closures.
notNodeReg
::
CmmExpr
->
Bool
notNodeReg
(
CmmReg
reg
)
|
reg
==
nodeReg
=
False
notNodeReg
_
=
True
lintCmmStmt
::
Platform
->
BlockSet
->
CmmStmt
->
CmmLint
()
lintCmmStmt
platform
labels
=
lint
where
lint
(
CmmNop
)
=
return
()
lint
(
CmmComment
{})
=
return
()
lint
stmt
@
(
CmmAssign
reg
expr
)
=
do
erep
<-
lintCmmExpr
platform
expr
let
reg_ty
=
cmmRegType
reg
if
(
erep
`
cmmEqType_ignoring_ptrhood
`
reg_ty
)
then
return
()
else
cmmLintAssignErr
platform
stmt
erep
reg_ty
lint
(
CmmStore
l
r
)
=
do
_
<-
lintCmmExpr
platform
l
_
<-
lintCmmExpr
platform
r
return
()
lint
(
CmmCall
target
_res
args
_
)
=
lintTarget
platform
target
>>
mapM_
(
lintCmmExpr
platform
.
hintlessCmm
)
args
lint
(
CmmCondBranch
e
id
)
=
checkTarget
id
>>
lintCmmExpr
platform
e
>>
checkCond
platform
e
lint
(
CmmSwitch
e
branches
)
=
do
mapM_
checkTarget
$
catMaybes
branches
erep
<-
lintCmmExpr
platform
e
if
(
erep
`
cmmEqType_ignoring_ptrhood
`
bWord
)
then
return
()
else
cmmLintErr
(
text
"switch scrutinee is not a word: "
<>
pprPlatform
platform
e
<>
text
" :: "
<>
ppr
erep
)