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
8b7eaa40
Commit
8b7eaa40
authored
Sep 07, 2007
by
nr@eecs.harvard.edu
Browse files
adding new files to do with new cmm functionality
parent
bd50bd07
Changes
18
Expand all
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmCPSZ.hs
0 → 100644
View file @
8b7eaa40
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module
CmmCPSZ
(
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
-- Well, sort of.
protoCmmCPSZ
)
where
import
Cmm
import
CmmContFlowOpt
import
CmmProcPointZ
import
CmmSpillReload
import
CmmTx
import
DFMonad
import
DynFlags
import
ErrUtils
import
Outputable
import
PprCmmZ
()
import
UniqSupply
import
ZipCfg
hiding
(
zip
,
unzip
)
import
ZipCfgCmm
import
ZipDataflow
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
protoCmmCPSZ
::
DynFlags
-- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
->
CmmZ
-- ^ Input C-- with Proceedures
->
IO
CmmZ
-- ^ Output CPS transformed C--
protoCmmCPSZ
dflags
(
Cmm
tops
)
=
do
{
showPass
dflags
"CPSZ"
;
u
<-
mkSplitUniqSupply
'p'
;
let
txtops
=
initUs_
u
$
mapM
cpsTop
tops
;
let
pgm
=
Cmm
$
runDFTx
maxBound
$
sequence
txtops
--- XXX calling runDFTx is totally bogus
;
dumpIfSet_dyn
dflags
Opt_D_dump_cps_cmm
"CPS Cmm"
(
ppr
pgm
)
;
return
pgm
}
cpsTop
::
CmmTopZ
->
UniqSM
(
DFTx
CmmTopZ
)
cpsTop
p
@
(
CmmData
{})
=
return
$
return
p
cpsTop
(
CmmProc
h
l
args
g
)
=
let
procPoints
=
minimalProcPointSet
(
runTx
cmmCfgOptsZ
g
)
g'
=
addProcPointProtocols
procPoints
args
g
g''
=
map_nodes
id
NotSpillOrReload
id
g'
in
do
us
<-
getUs
let
g
=
runDFM
us
dualLiveLattice
$
b_rewrite
dualLivenessWithInsertion
g''
-- let igraph = buildIGraph
return
$
do
g'
<-
g
>>=
return
.
map_nodes
id
spillAndReloadComments
id
return
$
CmmProc
h
l
args
g'
compiler/cmm/CmmContFlowOpt.hs
0 → 100644
View file @
8b7eaa40
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module
CmmContFlowOpt
(
runCmmOpts
,
cmmCfgOpts
,
cmmCfgOptsZ
,
branchChainElimZ
,
removeUnreachableBlocksZ
)
where
import
Cmm
import
CmmTx
import
qualified
ZipCfg
as
G
import
ZipCfgCmm
import
Maybes
import
Util
import
UniqFM
------------------------------------
mapProcs
::
Tx
(
GenCmmTop
d
h
s
)
->
Tx
(
GenCmm
d
h
s
)
mapProcs
f
(
Cmm
tops
)
=
fmap
Cmm
(
mapTx
f
tops
)
------------------------------------
cmmCfgOpts
::
Tx
(
ListGraph
CmmStmt
)
cmmCfgOptsZ
::
Tx
CmmGraph
cmmCfgOpts
=
branchChainElim
-- boring, but will get more exciting later
cmmCfgOptsZ
=
branchChainElimZ
`
seqTx
`
removeUnreachableBlocksZ
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
runCmmOpts
::
Tx
g
->
Tx
(
GenCmm
d
h
g
)
runCmmOpts
opt
=
mapProcs
(
optGraph
opt
)
optGraph
::
Tx
g
->
Tx
(
GenCmmTop
d
h
g
)
optGraph
_
top
@
(
CmmData
{})
=
noTx
top
optGraph
opt
(
CmmProc
info
lbl
formals
g
)
=
fmap
(
CmmProc
info
lbl
formals
)
(
opt
g
)
----------------------------------------------------------------
branchChainElim
::
Tx
(
ListGraph
CmmStmt
)
-- Remove any basic block of the form L: goto L',
-- and replace L with L' everywhere else
branchChainElim
(
ListGraph
blocks
)
|
null
lone_branch_blocks
-- No blocks to remove
=
noTx
(
ListGraph
blocks
)
|
otherwise
=
aTx
(
ListGraph
new_blocks
)
where
(
lone_branch_blocks
,
others
)
=
partitionWith
isLoneBranch
blocks
new_blocks
=
map
(
replaceLabels
env
)
others
env
=
mkClosureBlockEnv
lone_branch_blocks
isLoneBranch
::
CmmBasicBlock
->
Either
(
BlockId
,
BlockId
)
CmmBasicBlock
isLoneBranch
(
BasicBlock
id
[
CmmBranch
target
])
|
id
/=
target
=
Left
(
id
,
target
)
isLoneBranch
other_block
=
Right
other_block
-- ^ An infinite loop is not a link in a branch chain!
replaceLabels
::
BlockEnv
BlockId
->
CmmBasicBlock
->
CmmBasicBlock
replaceLabels
env
(
BasicBlock
id
stmts
)
=
BasicBlock
id
(
map
replace
stmts
)
where
replace
(
CmmBranch
id
)
=
CmmBranch
(
lookup
id
)
replace
(
CmmCondBranch
e
id
)
=
CmmCondBranch
e
(
lookup
id
)
replace
(
CmmSwitch
e
tbl
)
=
CmmSwitch
e
(
map
(
fmap
lookup
)
tbl
)
replace
other_stmt
=
other_stmt
lookup
id
=
lookupBlockEnv
env
id
`
orElse
`
id
----------------------------------------------------------------
branchChainElimZ
::
Tx
CmmGraph
-- Remove any basic block of the form L: goto L',
-- and replace L with L' everywhere else
branchChainElimZ
g
@
(
G
.
LGraph
eid
_
)
|
null
lone_branch_blocks
-- No blocks to remove
=
noTx
g
|
otherwise
=
aTx
$
replaceLabelsZ
env
$
G
.
of_block_list
eid
(
self_branches
++
others
)
where
(
lone_branch_blocks
,
others
)
=
partitionWith
isLoneBranchZ
(
G
.
to_block_list
g
)
env
=
mkClosureBlockEnv
lone_branch_blocks
self_branches
=
let
loop_to
(
id
,
_
)
=
if
lookup
id
==
id
then
Just
(
G
.
Block
id
(
G
.
ZLast
(
G
.
mkBranchNode
id
)))
else
Nothing
in
mapMaybe
loop_to
lone_branch_blocks
lookup
id
=
G
.
lookupBlockEnv
env
id
`
orElse
`
id
isLoneBranchZ
::
CmmBlock
->
Either
(
G
.
BlockId
,
G
.
BlockId
)
CmmBlock
isLoneBranchZ
(
G
.
Block
id
(
G
.
ZLast
(
G
.
LastOther
(
LastBranch
target
[]
))))
|
id
/=
target
=
Left
(
id
,
target
)
isLoneBranchZ
other
=
Right
other
-- ^ An infinite loop is not a link in a branch chain!
replaceLabelsZ
::
BlockEnv
G
.
BlockId
->
CmmGraph
->
CmmGraph
replaceLabelsZ
env
=
replace_eid
.
G
.
map_nodes
id
id
last
where
replace_eid
(
G
.
LGraph
eid
blocks
)
=
G
.
LGraph
(
lookup
eid
)
blocks
last
(
LastBranch
id
args
)
=
LastBranch
(
lookup
id
)
args
last
(
LastCondBranch
e
ti
fi
)
=
LastCondBranch
e
(
lookup
ti
)
(
lookup
fi
)
last
(
LastSwitch
e
tbl
)
=
LastSwitch
e
(
map
(
fmap
lookup
)
tbl
)
last
(
LastCall
tgt
args
(
Just
id
))
=
LastCall
tgt
args
(
Just
$
lookup
id
)
last
exit_jump_return
=
exit_jump_return
lookup
id
=
G
.
lookupBlockEnv
env
id
`
orElse
`
id
----------------------------------------------------------------
mkClosureBlockEnv
::
[(
BlockId
,
BlockId
)]
->
BlockEnv
BlockId
mkClosureBlockEnv
blocks
=
mkBlockEnv
$
map
follow
blocks
where
singleEnv
=
mkBlockEnv
blocks
follow
(
id
,
next
)
=
(
id
,
endChain
id
next
)
endChain
orig
id
=
case
lookupBlockEnv
singleEnv
id
of
Just
id'
|
id
/=
orig
->
endChain
orig
id'
_
->
id
----------------------------------------------------------------
removeUnreachableBlocksZ
::
Tx
CmmGraph
removeUnreachableBlocksZ
g
@
(
G
.
LGraph
id
blocks
)
=
if
length
blocks'
<
sizeUFM
blocks
then
aTx
$
G
.
of_block_list
id
blocks'
else
noTx
g
where
blocks'
=
G
.
postorder_dfs
g
compiler/cmm/CmmCvt.hs
0 → 100644
View file @
8b7eaa40
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module
CmmCvt
(
cmmToZgraph
,
cmmOfZgraph
)
where
import
Cmm
import
CmmExpr
import
ZipCfgCmm
import
MkZipCfg
import
CmmZipUtil
import
FastString
import
Outputable
import
Panic
import
PprCmm
()
import
PprCmmZ
()
import
UniqSet
import
UniqSupply
import
qualified
ZipCfg
as
G
cmmToZgraph
::
GenCmm
d
h
(
ListGraph
CmmStmt
)
->
UniqSM
(
GenCmm
d
h
CmmGraph
)
cmmOfZgraph
::
GenCmm
d
h
(
CmmGraph
)
->
GenCmm
d
h
(
ListGraph
CmmStmt
)
cmmToZgraph
=
cmmMapGraphM
toZgraph
cmmOfZgraph
=
cmmMapGraph
ofZgraph
toZgraph
::
String
->
ListGraph
CmmStmt
->
UniqSM
CmmGraph
toZgraph
_
(
ListGraph
[]
)
=
lgraphOfAGraph
emptyAGraph
toZgraph
fun_name
(
ListGraph
(
BasicBlock
id
ss
:
other_blocks
))
=
labelAGraph
id
$
mkStmts
ss
<*>
foldr
addBlock
emptyAGraph
other_blocks
where
addBlock
(
BasicBlock
id
ss
)
g
=
mkLabel
id
<*>
mkStmts
ss
<*>
g
mkStmts
(
CmmNop
:
ss
)
=
mkNop
<*>
mkStmts
ss
mkStmts
(
CmmComment
s
:
ss
)
=
mkComment
s
<*>
mkStmts
ss
mkStmts
(
CmmAssign
l
r
:
ss
)
=
mkAssign
l
r
<*>
mkStmts
ss
mkStmts
(
CmmStore
l
r
:
ss
)
=
mkStore
l
r
<*>
mkStmts
ss
mkStmts
(
CmmCall
f
res
args
(
CmmSafe
srt
)
CmmMayReturn
:
ss
)
=
mkCall
f
res
args
srt
<*>
mkStmts
ss
mkStmts
(
CmmCall
f
res
args
CmmUnsafe
CmmMayReturn
:
ss
)
=
mkUnsafeCall
f
res
args
<*>
mkStmts
ss
mkStmts
(
CmmCondBranch
e
l
:
fbranch
)
=
mkIfThenElse
(
mkCbranch
e
)
(
mkBranch
l
)
(
mkStmts
fbranch
)
mkStmts
(
last
:
[]
)
=
mkLast
last
mkStmts
[]
=
bad
"fell off end"
mkStmts
(
_
:
_
:
_
)
=
bad
"last node not at end"
bad
msg
=
panic
(
msg
{- ++ " in block " ++ showSDoc (ppr b) -}
++
" in function "
++
fun_name
)
mkLast
(
CmmCall
f
[]
args
_
CmmNeverReturns
)
=
mkFinalCall
f
args
mkLast
(
CmmSwitch
scrutinee
table
)
=
mkSwitch
scrutinee
table
mkLast
(
CmmJump
tgt
args
)
=
mkJump
tgt
args
mkLast
(
CmmReturn
ress
)
=
mkReturn
ress
mkLast
(
CmmBranch
tgt
)
=
mkBranch
tgt
mkLast
(
CmmCall
_f
(
_
:
_
)
_args
_
CmmNeverReturns
)
=
panic
"Call never returns but has results?!"
mkLast
_
=
panic
"fell off end of block"
ofZgraph
::
CmmGraph
->
ListGraph
CmmStmt
ofZgraph
g
=
ListGraph
$
swallow
blocks
where
blocks
=
G
.
postorder_dfs
g
-- | the next two functions are hooks on which to hang debugging info
extend_entry
stmts
=
stmts
extend_block
_id
stmts
=
stmts
_extend_entry
stmts
=
scomment
showblocks
:
scomment
cscomm
:
stmts
showblocks
=
"LGraph has "
++
show
(
length
blocks
)
++
" blocks:"
++
concat
(
map
(
\
(
G
.
Block
id
_
)
->
" "
++
show
id
)
blocks
)
cscomm
=
"Call successors are"
++
(
concat
$
map
(
\
id
->
" "
++
show
id
)
$
uniqSetToList
call_succs
)
swallow
[]
=
[]
swallow
(
G
.
Block
id
t
:
rest
)
=
tail
id
[]
t
rest
tail
id
prev'
(
G
.
ZTail
m
t
)
rest
=
tail
id
(
mid
m
:
prev'
)
t
rest
tail
id
prev'
(
G
.
ZLast
G
.
LastExit
)
rest
=
exit
id
prev'
rest
tail
id
prev'
(
G
.
ZLast
(
G
.
LastOther
l
))
rest
=
last
id
prev'
l
rest
mid
(
MidNop
)
=
CmmNop
mid
(
MidComment
s
)
=
CmmComment
s
mid
(
MidAssign
l
r
)
=
CmmAssign
l
r
mid
(
MidStore
l
r
)
=
CmmStore
l
r
mid
(
MidUnsafeCall
f
ress
args
)
=
CmmCall
f
ress
args
CmmUnsafe
CmmMayReturn
mid
m
@
(
CopyOut
{})
=
pcomment
(
ppr
m
)
mid
m
@
(
CopyIn
{})
=
pcomment
(
ppr
m
<+>
text
"(proc point)"
)
pcomment
p
=
scomment
$
showSDoc
p
block'
id
prev'
|
id
==
G
.
gr_entry
g
=
BasicBlock
id
$
extend_entry
(
reverse
prev'
)
|
otherwise
=
BasicBlock
id
$
extend_block
id
(
reverse
prev'
)
last
id
prev'
l
n
=
let
endblock
stmt
=
block'
id
(
stmt
:
prev'
)
:
swallow
n
in
case
l
of
LastBranch
_
(
_
:
_
)
->
panic
"unrepresentable branch"
LastBranch
tgt
[]
->
case
n
of
G
.
Block
id'
t
:
bs
|
tgt
==
id'
,
unique_pred
id'
->
tail
id
prev'
t
bs
-- optimize out redundant labels
_
->
endblock
(
CmmBranch
tgt
)
LastCondBranch
expr
tid
fid
->
case
n
of
G
.
Block
id'
t
:
bs
|
id'
==
fid
,
unique_pred
id'
->
tail
id
(
CmmCondBranch
expr
tid
:
prev'
)
t
bs
|
id'
==
tid
,
unique_pred
id'
,
Just
e'
<-
maybeInvertCmmExpr
expr
->
tail
id
(
CmmCondBranch
e'
fid
:
prev'
)
t
bs
_
->
let
instrs'
=
CmmBranch
fid
:
CmmCondBranch
expr
tid
:
prev'
in
block'
id
instrs'
:
swallow
n
LastJump
expr
params
->
endblock
$
CmmJump
expr
params
LastReturn
params
->
endblock
$
CmmReturn
params
LastSwitch
arg
ids
->
endblock
$
CmmSwitch
arg
$
ids
LastCall
tgt
args
Nothing
->
endblock
$
CmmCall
tgt
[]
args
CmmUnsafe
CmmNeverReturns
LastCall
tgt
args
(
Just
k
)
|
G
.
Block
id'
(
G
.
ZTail
(
CopyIn
_
ress
srt
)
t
)
:
bs
<-
n
,
id'
==
k
,
unique_pred
k
->
let
call
=
CmmCall
tgt
ress
args
(
CmmSafe
srt
)
CmmMayReturn
in
tail
id
(
call
:
prev'
)
t
bs
|
G
.
Block
id'
t
:
bs
<-
n
,
id'
==
k
,
unique_pred
k
->
let
(
ress
,
srt
)
=
findCopyIn
t
call
=
CmmCall
tgt
ress
args
(
CmmSafe
srt
)
CmmMayReturn
delayed
=
scomment
"delayed CopyIn follows previous call"
in
tail
id
(
delayed
:
call
:
prev'
)
t
bs
|
otherwise
->
panic
"unrepairable call"
findCopyIn
(
G
.
ZTail
(
CopyIn
_
ress
srt
)
_
)
=
(
ress
,
srt
)
findCopyIn
(
G
.
ZTail
_
t
)
=
findCopyIn
t
findCopyIn
(
G
.
ZLast
_
)
=
panic
"missing CopyIn after call"
exit
id
prev'
n
=
-- highly irregular (assertion violation?)
let
endblock
stmt
=
block'
id
(
stmt
:
prev'
)
:
swallow
n
in
case
n
of
[]
->
endblock
(
scomment
"procedure falls off end"
)
G
.
Block
id'
t
:
bs
->
if
unique_pred
id'
then
tail
id
(
scomment
"went thru exit"
:
prev'
)
t
bs
else
endblock
(
CmmBranch
id'
)
preds
=
zipPreds
g
single_preds
=
let
add
b
single
=
let
id
=
G
.
blockId
b
in
case
G
.
lookupBlockEnv
preds
id
of
Nothing
->
single
Just
s
->
if
sizeUniqSet
s
==
1
then
G
.
extendBlockSet
single
id
else
single
in
G
.
fold_blocks
add
G
.
emptyBlockSet
g
unique_pred
id
=
G
.
elemBlockSet
id
single_preds
call_succs
=
let
add
b
succs
=
case
G
.
last
(
G
.
unzip
b
)
of
G
.
LastOther
(
LastCall
_
_
(
Just
id
))
->
extendBlockSet
succs
id
_
->
succs
in
G
.
fold_blocks
add
emptyBlockSet
g
_is_call_succ
id
=
elemBlockSet
id
call_succs
scomment
::
String
->
CmmStmt
scomment
s
=
CmmComment
$
mkFastString
s
compiler/cmm/CmmExpr.hs
0 → 100644
View file @
8b7eaa40
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module
CmmExpr
(
CmmExpr
(
..
),
cmmExprRep
,
maybeInvertCmmExpr
,
CmmReg
(
..
),
cmmRegRep
,
CmmLit
(
..
),
cmmLitRep
,
LocalReg
(
..
),
localRegRep
,
localRegGCFollow
,
Kind
(
..
)
,
GlobalReg
(
..
),
globalRegRep
,
spReg
,
hpReg
,
spLimReg
,
nodeReg
,
node
,
UserOfLocalRegs
,
foldRegsUsed
,
RegSet
,
emptyRegSet
,
elemRegSet
,
extendRegSet
,
deleteFromRegSet
,
mkRegSet
,
plusRegSet
,
minusRegSet
)
where
import
CLabel
import
MachOp
import
Unique
import
UniqSet
-----------------------------------------------------------------------------
-- CmmExpr
-- An expression. Expressions have no side effects.
-----------------------------------------------------------------------------
data
CmmExpr
=
CmmLit
CmmLit
-- Literal
|
CmmLoad
CmmExpr
MachRep
-- Read memory location
|
CmmReg
CmmReg
-- Contents of register
|
CmmMachOp
MachOp
[
CmmExpr
]
-- Machine operation (+, -, *, etc.)
|
CmmRegOff
CmmReg
Int
-- CmmRegOff reg i
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
-- where rep = cmmRegRep reg
deriving
Eq
data
CmmReg
=
CmmLocal
LocalReg
|
CmmGlobal
GlobalReg
deriving
(
Eq
)
data
CmmLit
=
CmmInt
Integer
MachRep
-- Interpretation: the 2's complement representation of the value
-- is truncated to the specified size. This is easier than trying
-- to keep the value within range, because we don't know whether
-- it will be used as a signed or unsigned value (the MachRep doesn't
-- distinguish between signed & unsigned).
|
CmmFloat
Rational
MachRep
|
CmmLabel
CLabel
-- Address of label
|
CmmLabelOff
CLabel
Int
-- Address of label + byte offset
-- Due to limitations in the C backend, the following
-- MUST ONLY be used inside the info table indicated by label2
-- (label2 must be the info label), and label1 must be an
-- SRT, a slow entrypoint or a large bitmap (see the Mangler)
-- Don't use it at all unless tablesNextToCode.
-- It is also used inside the NCG during when generating
-- position-independent code.
|
CmmLabelDiffOff
CLabel
CLabel
Int
-- label1 - label2 + offset
deriving
Eq
instance
Eq
LocalReg
where
(
LocalReg
u1
_
_
)
==
(
LocalReg
u2
_
_
)
=
u1
==
u2
instance
Uniquable
LocalReg
where
getUnique
(
LocalReg
uniq
_
_
)
=
uniq
--------
--- Negation for conditional branches
maybeInvertCmmExpr
::
CmmExpr
->
Maybe
CmmExpr
maybeInvertCmmExpr
(
CmmMachOp
op
args
)
=
do
op'
<-
maybeInvertComparison
op
return
(
CmmMachOp
op'
args
)
maybeInvertCmmExpr
_
=
Nothing
-----------------------------------------------------------------------------
-- Local registers
-----------------------------------------------------------------------------
-- | Whether a 'LocalReg' is a GC followable pointer
data
Kind
=
KindPtr
|
KindNonPtr
deriving
(
Eq
)
data
LocalReg
=
LocalReg
!
Unique
-- ^ Identifier
MachRep
-- ^ Type
Kind
-- ^ Should the GC follow as a pointer
-- | Sets of local registers
type
RegSet
=
UniqSet
LocalReg
emptyRegSet
::
RegSet
elemRegSet
::
LocalReg
->
RegSet
->
Bool
extendRegSet
::
RegSet
->
LocalReg
->
RegSet
deleteFromRegSet
::
RegSet
->
LocalReg
->
RegSet
mkRegSet
::
[
LocalReg
]
->
RegSet
minusRegSet
,
plusRegSet
::
RegSet
->
RegSet
->
RegSet
emptyRegSet
=
emptyUniqSet
elemRegSet
=
elementOfUniqSet
extendRegSet
=
addOneToUniqSet
deleteFromRegSet
=
delOneFromUniqSet
mkRegSet
=
mkUniqSet
minusRegSet
=
minusUniqSet
plusRegSet
=
unionUniqSets
-----------------------------------------------------------------------------
-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
class
UserOfLocalRegs
a
where
foldRegsUsed
::
(
b
->
LocalReg
->
b
)
->
b
->
a
->
b
instance
UserOfLocalRegs
CmmReg
where
foldRegsUsed
f
z
(
CmmLocal
reg
)
=
f
z
reg
foldRegsUsed
_
z
(
CmmGlobal
_
)
=
z
instance
UserOfLocalRegs
LocalReg
where
foldRegsUsed
f
z
r
=
f
z
r
instance
UserOfLocalRegs
CmmExpr
where
foldRegsUsed
f
z
e
=
expr
z
e
where
expr
z
(
CmmLit
_
)
=
z
expr
z
(
CmmLoad
addr
_
)
=
foldRegsUsed
f
z
addr
expr
z
(
CmmReg
r
)
=
foldRegsUsed
f
z
r
expr
z
(
CmmMachOp
_
exprs
)
=
foldRegsUsed
f
z
exprs
expr
z
(
CmmRegOff
r
_
)
=
foldRegsUsed
f
z
r
instance
UserOfLocalRegs
a
=>
UserOfLocalRegs
[
a
]
where
foldRegsUsed
_
set
[]
=
set
foldRegsUsed
f
set
(
x
:
xs
)
=
foldRegsUsed
f
(
foldRegsUsed
f
set
x
)
xs
-----------------------------------------------------------------------------
-- MachRep
-----------------------------------------------------------------------------
cmmExprRep
::
CmmExpr
->
MachRep
cmmExprRep
(
CmmLit
lit
)
=
cmmLitRep
lit
cmmExprRep
(
CmmLoad
_
rep
)
=
rep
cmmExprRep
(
CmmReg
reg
)
=
cmmRegRep
reg
cmmExprRep
(
CmmMachOp
op
_
)
=
resultRepOfMachOp
op
cmmExprRep
(
CmmRegOff
reg
_
)
=
cmmRegRep
reg
cmmRegRep
::
CmmReg
->
MachRep
cmmRegRep
(
CmmLocal
reg
)
=
localRegRep
reg
cmmRegRep
(
CmmGlobal
reg
)
=
globalRegRep
reg
localRegRep
::
LocalReg
->
MachRep
localRegRep
(
LocalReg
_
rep
_
)
=
rep
localRegGCFollow
::
LocalReg
->
Kind
localRegGCFollow
(
LocalReg
_
_
p
)
=
p
cmmLitRep
::
CmmLit
->
MachRep
cmmLitRep
(
CmmInt
_
rep
)
=
rep
cmmLitRep
(
CmmFloat
_
rep
)
=
rep
cmmLitRep
(
CmmLabel
_
)
=
wordRep
cmmLitRep
(
CmmLabelOff
_
_
)
=
wordRep
cmmLitRep
(
CmmLabelDiffOff
_
_
_
)
=
wordRep
-----------------------------------------------------------------------------
-- Global STG registers
-----------------------------------------------------------------------------
data
GlobalReg
-- Argument and return registers
=
VanillaReg
-- pointers, unboxed ints and chars
{-# UNPACK #-}
!
Int
-- its number
|
FloatReg
-- single-precision floating-point registers
{-# UNPACK #-}
!
Int
-- its number
|
DoubleReg
-- double-precision floating-point registers
{-# UNPACK #-}
!
Int
-- its number
|
LongReg
-- long int registers (64-bit, really)
{-# UNPACK #-}
!
Int
-- its number
-- STG registers
|
Sp
-- Stack ptr; points to last occupied stack location.
|
SpLim
-- Stack limit
|
Hp
-- Heap ptr; points to last occupied heap location.
|
HpLim
-- Heap limit register
|
CurrentTSO
-- pointer to current thread's TSO
|
CurrentNursery
-- pointer to allocation area
|
HpAlloc
-- allocation count for heap check failure
-- We keep the address of some commonly-called
-- functions in the register table, to keep code
-- size down:
|
GCEnter1
-- stg_gc_enter_1
|
GCFun
-- stg_gc_fun
-- Base offset for the register table, used for accessing registers
-- which do not have real registers assigned to them. This register
-- will only appear after we have expanded GlobalReg into memory accesses
-- (where necessary) in the native code generator.
|
BaseReg
-- Base Register for PIC (position-independent code) calculations
-- Only used inside the native code generator. It's exact meaning differs
-- from platform to platform (see module PositionIndependentCode).
|
PicBaseReg
deriving
(
Eq
#
ifdef
DEBUG
,
Show
#
endif
)
-- convenient aliases
spReg
,
hpReg
,
spLimReg
,
nodeReg
::
CmmReg
spReg
=
CmmGlobal
Sp
hpReg
=
CmmGlobal
Hp
spLimReg
=
CmmGlobal
SpLim
nodeReg
=
CmmGlobal
node
node
::
GlobalReg
node
=
VanillaReg
1
globalRegRep
::
GlobalReg
->
MachRep
globalRegRep
(
VanillaReg
_
)
=
wordRep
globalRegRep
(
FloatReg
_
)
=
F32
globalRegRep
(
DoubleReg
_
)
=
F64
globalRegRep
(
LongReg
_
)
=
I64
globalRegRep
_
=
wordRep
compiler/cmm/CmmLiveZ.hs
0 → 100644
View file @
8b7eaa40
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module
CmmLiveZ
(
CmmLive
,
cmmLivenessZ
,
liveLattice
,
middleLiveness
,
lastLiveness
)
where
import
Cmm
import
CmmExpr
import
CmmTx
import
DFMonad
import
Maybes
import
PprCmm
()
import
PprCmmZ
()
import
UniqSet
import
ZipDataflow
import
ZipCfgCmm
-----------------------------------------------------------------------------
-- Calculating what variables are live on entry to a basic block
-----------------------------------------------------------------------------
-- | The variables live on entry to a block
type
CmmLive
=
RegSet
-- | The dataflow lattice
liveLattice
::
DataflowLattice
CmmLive
liveLattice
=
DataflowLattice
"live LocalReg's"
emptyUniqSet
add
False
where
add
new
old
=
let
join
=
unionUniqSets
new
old
in
(
if
sizeUniqSet
join
>
sizeUniqSet
old
then
aTx
else
noTx
)
join
-- | A mapping from block labels to the variables live on entry
type
BlockEntryLiveness
=
BlockEnv
CmmLive
-----------------------------------------------------------------------------
-- | Calculated liveness info for a list of 'CmmBasicBlock'
-----------------------------------------------------------------------------
cmmLivenessZ
::
CmmGraph
->
BlockEntryLiveness
cmmLivenessZ
g
=
env
where
env
=
runDFA
liveLattice
$
do
run_b_anal
transfer
g
allFacts
transfer
=
BComp
"liveness analysis"
exit
last
middle
first
exit
=
emptyUniqSet
first
live
_
=
live
middle
=
flip
middleLiveness
last
=
flip
lastLiveness