Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
81285ec4
Commit
81285ec4
authored
Jun 28, 2007
by
Michael D. Adams
Browse files
Comment and formatting updates for the CPS pass
parent
61c73ae3
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmBrokenBlock.hs
View file @
81285ec4
...
...
@@ -19,6 +19,11 @@ import Panic
import
Unique
import
UniqFM
-- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
-- statements in it with 'CmmSafe' set and breaks it up at each such call.
-- It also collects information about the block for later use
-- by the CPS algorithm.
-----------------------------------------------------------------------------
-- Data structures
-----------------------------------------------------------------------------
...
...
@@ -110,6 +115,8 @@ breakBlock uniques (BasicBlock ident stmts) entry =
breakBlock'
uniques
current_id
entry
exits
accum_stmts
stmts
=
case
stmts
of
[]
->
panic
"block doesn't end in jump, goto, return or switch"
-- Last statement. Make the 'BrokenBlock'
[
CmmJump
target
arguments
]
->
[
BrokenBlock
current_id
entry
accum_stmts
exits
...
...
@@ -126,6 +133,9 @@ breakBlock uniques (BasicBlock ident stmts) entry =
[
BrokenBlock
current_id
entry
accum_stmts
(
mapMaybe
id
targets
++
exits
)
(
FinalSwitch
expr
targets
)]
-- These shouldn't happen in the middle of a block.
-- They would cause dead code.
(
CmmJump
_
_
:
_
)
->
panic
"jump in middle of block"
(
CmmReturn
_
:
_
)
->
panic
"return in middle of block"
(
CmmBranch
_
:
_
)
->
panic
"branch in middle of block"
...
...
@@ -140,6 +150,8 @@ breakBlock uniques (BasicBlock ident stmts) entry =
block = do_call current_id entry accum_stmts exits next_id
target results arguments
-}
-- Break the block on safe calls (the main job of this function)
(
CmmCall
target
results
arguments
(
CmmSafe
srt
)
:
stmts
)
->
block
:
rest
where
...
...
@@ -149,6 +161,9 @@ breakBlock uniques (BasicBlock ident stmts) entry =
rest
=
breakBlock'
(
tail
uniques
)
next_id
(
ContinuationEntry
(
map
fst
results
)
srt
)
[]
[]
stmts
-- Default case. Just keep accumulating statements
-- and branch targets.
(
s
:
stmts
)
->
breakBlock'
uniques
current_id
entry
(
cond_branch_target
s
++
exits
)
...
...
compiler/cmm/CmmCPS.hs
View file @
81285ec4
...
...
@@ -157,7 +157,9 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
--
-- This is an association list instead of a UniqFM because
-- CLabel's don't have a 'Uniqueable' instance.
formats
::
[(
CLabel
,
(
Maybe
CLabel
,
[
Maybe
LocalReg
]))]
formats
::
[(
CLabel
,
-- key
(
Maybe
CLabel
,
-- label in top slot
[
Maybe
LocalReg
]))]
-- slots
formats
=
selectStackFormat
live
continuations
-- Do a little meta-processing on the stack formats such as
...
...
@@ -203,7 +205,7 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
continuationLabel
(
Continuation
_
l
_
_
)
=
l
data
Continuation
info
=
Continuation
info
--(Either C_SRT CmmInfo)
-- Left <=> Continuation created by the CPS
info
-- Left <=> Continuation created by the CPS
-- Right <=> Function or Proc point
CLabel
-- Used to generate both info & entry labels
CmmFormals
-- Argument locals live on entry (C-- procedure params)
...
...
@@ -361,7 +363,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) =
-- TODO prof: this is the same as the current implementation
-- but I think it could be improved
prof
=
ProfilingInfo
zeroCLit
zeroCLit
tag
=
rET_SMALL
-- cmmToRawCmm
will
convert t
his
to rET_BIG
if needed
tag
=
rET_SMALL
-- cmmToRawCmm
may
convert
i
t to rET_BIG
format
=
maybe
unknown_block
id
$
lookup
label
formats
unknown_block
=
panic
"unknown BlockId in applyStackFormat"
...
...
compiler/cmm/CmmCallConv.hs
View file @
81285ec4
module
CmmCallConv
(
ParamLocation
(
..
),
ArgumentFormat
,
assignRegs
,
assignArguments
,
)
where
...
...
@@ -15,26 +14,35 @@ import Constants
import
StaticFlags
(
opt_Unregisterised
)
import
Panic
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.
data
ParamLocation
=
RegisterParam
GlobalReg
|
StackParam
WordOff
assignRegs
::
[
LocalReg
]
->
ArgumentFormat
LocalReg
assignRegs
regs
=
assignRegs'
regs
0
availRegs
where
assignRegs'
(
r
:
rs
)
offset
availRegs
=
(
r
,
assignment
)
:
assignRegs'
rs
new_offset
remaining
where
(
assignment
,
new_offset
,
remaining
)
=
assign_reg
(
localRegRep
r
)
offset
availRegs
type
ArgumentFormat
a
=
[(
a
,
ParamLocation
)]
assignArguments
::
(
a
->
MachRep
)
->
[
a
]
->
ArgumentFormat
a
assignArguments
f
reps
=
assignArguments'
reps
0
availRegs
where
assignArguments'
[]
offset
availRegs
=
[]
assignArguments'
(
r
:
rs
)
offset
availRegs
=
(
r
,
assignment
)
:
assignArguments'
rs
new_offset
remaining
assignArguments'
(
r
:
rs
)
offset
availRegs
=
(
r
,
assignment
)
:
assignArguments'
rs
new_offset
remaining
where
(
assignment
,
new_offset
,
remaining
)
=
assign_reg
(
f
r
)
offset
availRegs
(
assignment
,
new_offset
,
remaining
)
=
assign_reg
(
f
r
)
offset
availRegs
type
ArgumentFormat
a
=
[(
a
,
ParamLocation
)]
argumentsSize
::
(
a
->
MachRep
)
->
[
a
]
->
WordOff
argumentsSize
f
reps
=
maximum
(
0
:
map
arg_top
args
)
where
args
=
assignArguments
f
reps
arg_top
(
a
,
StackParam
offset
)
=
-
offset
arg_top
(
_
,
RegisterParam
_
)
=
0
-----------------------------------------------------------------------------
-- Local information about the registers available
type
AvailRegs
=
(
[
GlobalReg
]
-- available vanilla regs.
,
[
GlobalReg
]
-- floats
...
...
@@ -65,7 +73,8 @@ availRegs = (regList VanillaReg useVanillaRegs,
regList
f
max
=
map
f
[
1
..
max
]
slot_size
::
LocalReg
->
Int
slot_size
reg
=
((
machRepByteWidth
(
localRegRep
reg
)
-
1
)
`
div
`
wORD_SIZE
)
+
1
slot_size
reg
=
((
machRepByteWidth
(
localRegRep
reg
)
-
1
)
`
div
`
wORD_SIZE
)
+
1
slot_size'
::
MachRep
->
Int
slot_size'
reg
=
((
machRepByteWidth
reg
-
1
)
`
div
`
wORD_SIZE
)
+
1
...
...
compiler/cmm/CmmProcPoint.hs
View file @
81285ec4
...
...
@@ -12,31 +12,29 @@ import UniqSet
import
UniqFM
import
Panic
calculateOwnership
::
BlockEnv
BrokenBlock
->
UniqSet
BlockId
->
[
BrokenBlock
]
->
BlockEnv
(
UniqSet
BlockId
)
calculateOwnership
blocks_ufm
proc_points
blocks
=
fixedpoint
dependants
update
(
map
brokenBlockId
blocks
)
emptyUFM
where
dependants
::
BlockId
->
[
BlockId
]
dependants
ident
=
brokenBlockTargets
$
lookupWithDefaultUFM
blocks_ufm
unknown_block
ident
update
::
BlockId
->
Maybe
BlockId
->
BlockEnv
(
UniqSet
BlockId
)
->
Maybe
(
BlockEnv
(
UniqSet
BlockId
))
update
ident
cause
owners
=
case
(
cause
,
ident
`
elementOfUniqSet
`
proc_points
)
of
(
Nothing
,
True
)
->
Just
$
addToUFM
owners
ident
(
unitUniqSet
ident
)
(
Nothing
,
False
)
->
Nothing
(
Just
cause'
,
True
)
->
Nothing
(
Just
cause'
,
False
)
->
if
(
sizeUniqSet
old
)
==
(
sizeUniqSet
new
)
then
Nothing
else
Just
$
addToUFM
owners
ident
new
where
old
=
lookupWithDefaultUFM
owners
emptyUniqSet
ident
new
=
old
`
unionUniqSets
`
lookupWithDefaultUFM
owners
emptyUniqSet
cause'
unknown_block
=
panic
"unknown BlockId in selectStackFormat"
-- Determine the proc points for a set of basic blocks.
--
-- A proc point is any basic block that must start a new function.
-- The entry block of the original function is a proc point.
-- The continuation of a function call is also a proc point.
-- The third kind of proc point arises when there is a joint point
-- in the control flow. Suppose we have code like the following:
--
-- if (...) { ...; call foo(); ...}
-- else { ...; call bar(); ...}
-- x = y;
--
-- That last statement "x = y" must be a proc point because
-- it can be reached by blocks owned by different proc points
-- (the two branches of the conditional).
--
-- We calculate these proc points by starting with the minimal set
-- and finding blocks that are reachable from more proc points than
-- one of their parents. (This ensures we don't choose a block
-- simply beause it is reachable from another block that is reachable
-- from multiple proc points.) These new blocks are added to the
-- set of proc points and the process is repeated until there
-- are no more proc points to be found.
calculateProcPoints
::
[
BrokenBlock
]
->
UniqSet
BlockId
calculateProcPoints
blocks
=
...
...
@@ -61,20 +59,58 @@ calculateProcPoints' old_proc_points blocks =
blocks_ufm
=
blocksToBlockEnv
blocks
owners
=
calculateOwnership
blocks_ufm
old_proc_points
blocks
new_proc_points
=
unionManyUniqSets
(
old_proc_points
:
(
map
(
calculateProcPoints''
owners
)
blocks
))
new_proc_points
=
unionManyUniqSets
(
old_proc_points
:
map
(
calculateNewProcPoints
owners
)
blocks
)
calculateProcPoints''
::
BlockEnv
(
UniqSet
BlockId
)
->
BrokenBlock
->
UniqSet
BlockId
calculateProcPoints''
owners
block
=
unionManyUniqSets
(
map
(
f
parent_id
)
child_ids
)
calculateNewProcPoints
::
BlockEnv
(
UniqSet
BlockId
)
->
BrokenBlock
->
UniqSet
BlockId
calculateNewProcPoints
owners
block
=
unionManyUniqSets
(
map
(
maybe_proc_point
parent_id
)
child_ids
)
where
parent_id
=
brokenBlockId
block
child_ids
=
brokenBlockTargets
block
-- TODO: name for f
f
parent_id
child_id
=
maybe_proc_point
parent_id
child_id
=
if
needs_proc_point
then
unitUniqSet
child_id
else
emptyUniqSet
where
parent_owners
=
lookupWithDefaultUFM
owners
emptyUniqSet
parent_id
child_owners
=
lookupWithDefaultUFM
owners
emptyUniqSet
child_id
needs_proc_point
=
not
$
isEmptyUniqSet
$
child_owners
`
minusUniqSet
`
parent_owners
needs_proc_point
=
not
$
isEmptyUniqSet
$
child_owners
`
minusUniqSet
`
parent_owners
calculateOwnership
::
BlockEnv
BrokenBlock
->
UniqSet
BlockId
->
[
BrokenBlock
]
->
BlockEnv
(
UniqSet
BlockId
)
calculateOwnership
blocks_ufm
proc_points
blocks
=
fixedpoint
dependants
update
(
map
brokenBlockId
blocks
)
emptyUFM
where
dependants
::
BlockId
->
[
BlockId
]
dependants
ident
=
brokenBlockTargets
$
lookupWithDefaultUFM
blocks_ufm
unknown_block
ident
update
::
BlockId
->
Maybe
BlockId
->
BlockEnv
(
UniqSet
BlockId
)
->
Maybe
(
BlockEnv
(
UniqSet
BlockId
))
update
ident
cause
owners
=
case
(
cause
,
ident
`
elementOfUniqSet
`
proc_points
)
of
(
Nothing
,
True
)
->
Just
$
addToUFM
owners
ident
(
unitUniqSet
ident
)
(
Nothing
,
False
)
->
Nothing
(
Just
cause'
,
True
)
->
Nothing
(
Just
cause'
,
False
)
->
if
(
sizeUniqSet
old
)
==
(
sizeUniqSet
new
)
then
Nothing
else
Just
$
addToUFM
owners
ident
new
where
old
=
lookupWithDefaultUFM
owners
emptyUniqSet
ident
new
=
old
`
unionUniqSets
`
lookupWithDefaultUFM
owners
emptyUniqSet
cause'
unknown_block
=
panic
"unknown BlockId in selectStackFormat"
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment