Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Glasgow Haskell Compiler
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
21bc3ec7
Commit
21bc3ec7
authored
May 25, 2007
by
Michael D. Adams
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Formatting changes for CPS code.
parent
dd1dfdbf
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
138 additions
and
194 deletions
+138
-194
compiler/cmm/CmmCPS.hs
compiler/cmm/CmmCPS.hs
+91
-143
compiler/cmm/CmmLive.hs
compiler/cmm/CmmLive.hs
+47
-51
No files found.
compiler/cmm/CmmCPS.hs
View file @
21bc3ec7
...
...
@@ -34,6 +34,90 @@ import Monad
import
IO
import
Data.List
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
cmmCPS
::
DynFlags
-- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
->
[
Cmm
]
-- ^ Input C-- with Proceedures
->
IO
[
Cmm
]
-- ^ Output CPS transformed C--
cmmCPS
dflags
abstractC
=
do
when
(
dopt
Opt_DoCmmLinting
dflags
)
$
do
showPass
dflags
"CmmLint"
case
firstJust
$
map
cmmLint
abstractC
of
Just
err
->
do
printDump
err
ghcExit
dflags
1
Nothing
->
return
()
showPass
dflags
"CPS"
-- TODO: more lint checking
-- check for use of branches to non-existant blocks
-- check for use of Sp, SpLim, R1, R2, etc.
uniqSupply
<-
mkSplitUniqSupply
'p'
let
supplies
=
listSplitUniqSupply
uniqSupply
let
doCpsProc
s
(
Cmm
c
)
=
Cmm
$
concat
$
zipWith
cpsProc
(
listSplitUniqSupply
s
)
c
let
continuationC
=
zipWith
doCpsProc
supplies
abstractC
dumpIfSet_dyn
dflags
Opt_D_dump_cps_cmm
"CPS Cmm"
(
pprCmms
continuationC
)
-- TODO: add option to dump Cmm to file
return
continuationC
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
-- Only 'CmmProc' are transformed 'CmmData' will be left alone.
-----------------------------------------------------------------------------
cpsProc
::
UniqSupply
->
CmmTop
-- ^Input proceedure
->
[
CmmTop
]
-- ^Output proceedure and continuations
cpsProc
uniqSupply
x
@
(
CmmData
_
_
)
=
[
x
]
cpsProc
uniqSupply
x
@
(
CmmProc
info_table
ident
params
blocks
)
=
cps_procs
where
uniqes
::
[[
Unique
]]
uniqes
=
map
uniqsFromSupply
$
listSplitUniqSupply
uniqSupply
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
broken_blocks
::
[
BrokenBlock
]
broken_blocks
=
concat
$
zipWith3
breakBlock
uniqes
blocks
(
FunctionEntry
ident
params
:
repeat
ControlEntry
)
-- Calculate live variables for each broken block.
--
-- Nothing can be live on entry to the first block
-- so we could take the tail, but for now we wont
-- to help future proof the code.
live
::
BlockEntryLiveness
live
=
cmmLiveness
$
map
cmmBlockFromBrokenBlock
broken_blocks
-- Calculate which blocks must be made into full fledged procedures.
proc_points
::
UniqSet
BlockId
proc_points
=
calculateProcPoints
broken_blocks
-- Construct a map so we can lookup a broken block by its 'BlockId'.
block_env
::
BlockEnv
BrokenBlock
block_env
=
blocksToBlockEnv
broken_blocks
-- Group the blocks into continuations based on the set of proc-points.
continuations
::
[
Continuation
]
continuations
=
map
(
gatherBlocksIntoContinuation
proc_points
block_env
)
(
uniqSetToList
proc_points
)
-- Select the stack format on entry to each continuation.
--
-- This is an association list instead of a UniqFM because
-- CLabel's don't have a 'Uniqueable' instance.
formats
::
[(
CLabel
,
StackFormat
)]
formats
=
selectStackFormat
live
continuations
-- Do the actual CPS transform.
cps_procs
::
[
CmmTop
]
cps_procs
=
map
(
continuationToProc
formats
)
continuations
--------------------------------------------------------------------------------
-- The format for the call to a continuation
...
...
@@ -97,10 +181,15 @@ collectNonProcPointTargets proc_points blocks current_targets block =
-- TODO: remove redundant uniqSetToList
new_targets
=
current_targets
`
unionUniqSets
`
(
mkUniqSet
targets
)
procPointToContinuation
::
-- TODO: insert proc point code here
-- * Branches and switches to proc points may cause new blocks to be created
-- (or proc points could leave behind phantom blocks that just jump to them)
-- * Proc points might get some live variables passed as arguments
gatherBlocksIntoContinuation
::
UniqSet
BlockId
->
BlockEnv
BrokenBlock
->
BlockId
->
Continuation
procPointT
oContinuation
proc_points
blocks
start
=
gatherBlocksInt
oContinuation
proc_points
blocks
start
=
Continuation
is_entry
info_table
clabel
params
body
where
children
=
(
collectNonProcPointTargets
proc_points
blocks
(
unitUniqSet
start
)
start
)
`
delOneFromUniqSet
`
start
...
...
@@ -251,144 +340,3 @@ unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
(
CmmLoad
(
CmmRegOff
spReg
(
wORD_SIZE
*
offset
))
(
cmmRegRep
reg
))
|
(
reg
,
offset
)
<-
curr_offsets
]
-----------------------------------------------------------------------------
-- Breaking basic blocks on function calls
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- Takes a basic block and breaks it up into a list of broken blocks
--
-- Takes a basic block and returns a list of basic blocks that
-- each have at most 1 CmmCall in them which must occur at the end.
-- Also returns with each basic block, the variables that will
-- be arguments to the continuation of the block once the call (if any)
-- returns.
breakBlock
::
[
Unique
]
->
CmmBasicBlock
->
BlockEntryInfo
->
[
BrokenBlock
]
breakBlock
uniques
(
BasicBlock
ident
stmts
)
entry
=
breakBlock'
uniques
ident
entry
[]
[]
stmts
where
breakBlock'
uniques
current_id
entry
exits
accum_stmts
stmts
=
case
stmts
of
[]
->
panic
"block doesn't end in jump, goto or return"
[
CmmJump
target
arguments
]
->
[
BrokenBlock
current_id
entry
accum_stmts
exits
(
FinalJump
target
arguments
)]
[
CmmReturn
arguments
]
->
[
BrokenBlock
current_id
entry
accum_stmts
exits
(
FinalReturn
arguments
)]
[
CmmBranch
target
]
->
[
BrokenBlock
current_id
entry
accum_stmts
(
target
:
exits
)
(
FinalBranch
target
)]
[
CmmSwitch
expr
targets
]
->
[
BrokenBlock
current_id
entry
accum_stmts
(
mapMaybe
id
targets
++
exits
)
(
FinalSwitch
expr
targets
)]
(
CmmJump
_
_
:
_
)
->
panic
"jump in middle of block"
(
CmmReturn
_
:
_
)
->
panic
"return in middle of block"
(
CmmBranch
_
:
_
)
->
panic
"branch in middle of block"
(
CmmSwitch
_
_
:
_
)
->
panic
(
"switch in middle of block"
++
(
showSDoc
$
ppr
stmts
))
(
CmmCall
target
results
arguments
saves
:
stmts
)
->
block
:
rest
where
new_id
=
BlockId
$
head
uniques
block
=
BrokenBlock
current_id
entry
accum_stmts
(
new_id
:
exits
)
(
FinalCall
new_id
target
results
arguments
saves
)
rest
=
breakBlock'
(
tail
uniques
)
new_id
(
ContinuationEntry
results
)
[]
[]
stmts
(
s
@
(
CmmCondBranch
test
target
)
:
stmts
)
->
breakBlock'
uniques
current_id
entry
(
target
:
exits
)
(
accum_stmts
++
[
s
])
stmts
(
s
:
stmts
)
->
breakBlock'
uniques
current_id
entry
exits
(
accum_stmts
++
[
s
])
stmts
--------------------------------
-- Convert from a BrokenBlock
-- to a CmmBasicBlock so the
-- liveness analysis can run
-- on it.
--------------------------------
cmmBlockFromBrokenBlock
::
BrokenBlock
->
CmmBasicBlock
cmmBlockFromBrokenBlock
(
BrokenBlock
ident
_
stmts
_
exit
)
=
BasicBlock
ident
(
stmts
++
exit_stmt
)
where
exit_stmt
=
case
exit
of
FinalBranch
target
->
[
CmmBranch
target
]
FinalReturn
arguments
->
[
CmmReturn
arguments
]
FinalJump
target
arguments
->
[
CmmJump
target
arguments
]
FinalSwitch
expr
targets
->
[
CmmSwitch
expr
targets
]
FinalCall
branch_target
call_target
results
arguments
saves
->
[
CmmCall
call_target
results
arguments
saves
,
CmmBranch
branch_target
]
-----------------------------------------------------------------------------
-- CPS a single CmmTop (proceedure)
-----------------------------------------------------------------------------
cpsProc
::
UniqSupply
->
CmmTop
->
[
CmmTop
]
cpsProc
uniqSupply
x
@
(
CmmData
_
_
)
=
[
x
]
cpsProc
uniqSupply
x
@
(
CmmProc
info_table
ident
params
blocks
)
=
cps_procs
where
uniqes
::
[[
Unique
]]
uniqes
=
map
uniqsFromSupply
$
listSplitUniqSupply
uniqSupply
-- Break the block at each function call
broken_blocks
::
[
BrokenBlock
]
broken_blocks
=
concat
$
zipWith3
breakBlock
uniqes
blocks
(
FunctionEntry
ident
params
:
repeat
ControlEntry
)
-- Calculate live variables for each broken block
live
::
BlockEntryLiveness
live
=
cmmLiveness
$
map
cmmBlockFromBrokenBlock
broken_blocks
-- nothing can be live on entry to the first block so we could take the tail
proc_points
::
UniqSet
BlockId
proc_points
=
calculateProcPoints
broken_blocks
-- TODO: insert proc point code here
-- * Branches and switches to proc points may cause new blocks to be created
-- (or proc points could leave behind phantom blocks that just jump to them)
-- * Proc points might get some live variables passed as arguments
continuations
::
[
Continuation
]
continuations
=
map
(
procPointToContinuation
proc_points
(
blocksToBlockEnv
broken_blocks
))
(
uniqSetToList
proc_points
)
-- Select the stack format on entry to each block
formats
::
[(
CLabel
,
StackFormat
)]
formats
=
selectStackFormat
live
continuations
-- Do the actual CPS transform
cps_procs
::
[
CmmTop
]
cps_procs
=
map
(
continuationToProc
formats
)
continuations
--------------------------------------------------------------------------------
cmmCPS
::
DynFlags
->
[
Cmm
]
-- C-- with Proceedures
->
IO
[
Cmm
]
-- Output: CPS transformed C--
cmmCPS
dflags
abstractC
=
do
when
(
dopt
Opt_DoCmmLinting
dflags
)
$
do
showPass
dflags
"CmmLint"
case
firstJust
$
map
cmmLint
abstractC
of
Just
err
->
do
printDump
err
ghcExit
dflags
1
Nothing
->
return
()
showPass
dflags
"CPS"
-- TODO: check for use of branches to non-existant blocks
-- TODO: check for use of Sp, SpLim, R1, R2, etc.
-- TODO: find out if it is valid to create a new unique source like this
uniqSupply
<-
mkSplitUniqSupply
'p'
let
supplies
=
listSplitUniqSupply
uniqSupply
let
continuationC
=
zipWith
(
\
s
(
Cmm
c
)
->
Cmm
$
concat
$
zipWith
(
cpsProc
)
(
listSplitUniqSupply
s
)
c
)
supplies
abstractC
dumpIfSet_dyn
dflags
Opt_D_dump_cps_cmm
"CPS Cmm"
(
pprCmms
continuationC
)
-- TODO: add option to dump Cmm to file
return
continuationC
compiler/cmm/CmmLive.hs
View file @
21bc3ec7
module
CmmLive
(
CmmLive
,
BlockEntryLiveness
,
CmmLive
,
BlockEntryLiveness
,
cmmLiveness
,
cmmFormalsToLiveLocals
cmmFormalsToLiveLocals
,
)
where
#
include
"HsVersions.h"
...
...
@@ -14,20 +15,24 @@ import Panic
import
UniqFM
import
UniqSet
import
Data.List
-----------------------------------------------------------------------------
-- Calculating what variables are live on entry to a basic block
-----------------------------------------------------------------------------
-- The variables live on entry to a block
--
|
The variables live on entry to a block
type
CmmLive
=
UniqSet
LocalReg
-- A mapping from block labels to the variables live on entry
--
|
A mapping from block labels to the variables live on entry
type
BlockEntryLiveness
=
BlockEnv
CmmLive
-- | A mapping from block labels to the blocks that target it
type
BlockSources
=
BlockEnv
(
UniqSet
BlockId
)
-- | A mapping from block labels to the statements in the block
type
BlockStmts
=
BlockEnv
[
CmmStmt
]
-----------------------------------------------------------------------------
--
cmmLiveness and helpers
--
| Calculated liveness info for a list of 'CmmBasicBlock'
-----------------------------------------------------------------------------
cmmLiveness
::
[
CmmBasicBlock
]
->
BlockEntryLiveness
cmmLiveness
blocks
=
...
...
@@ -36,8 +41,14 @@ cmmLiveness blocks =
(
map
blockId
blocks
)
(
listToUFM
[(
blockId
b
,
emptyUniqSet
)
|
b
<-
blocks
])
where
sources
::
BlockSources
sources
=
cmmBlockSources
blocks
blocks'
=
cmmBlockNames
blocks
blocks'
::
BlockStmts
blocks'
=
listToUFM
$
map
block_name
blocks
block_name
::
CmmBasicBlock
->
(
BlockId
,
[
CmmStmt
])
block_name
b
=
(
blockId
b
,
blockStmts
b
)
{-
-- For debugging, annotate each block with a comment indicating
...
...
@@ -51,27 +62,24 @@ cmmLivenessComment live (BasicBlock ident stmts) =
-}
--------------------------------
-- cmmBlockSources
--
-- Calculates a table of blocks
-- that might need updating after
-- a given block is updated
--------------------------------
cmmBlockSources
::
[
CmmBasicBlock
]
->
BlockEnv
(
UniqSet
BlockId
)
-----------------------------------------------------------------------------
-- | Calculates a table of where one can lookup the blocks that might
-- need updating after a given block is updated in the liveness analysis
-----------------------------------------------------------------------------
cmmBlockSources
::
[
CmmBasicBlock
]
->
BlockSources
cmmBlockSources
blocks
=
foldr
aux
emptyUFM
blocks
where
aux
::
CmmBasicBlock
->
Block
Env
(
UniqSet
BlockId
)
->
Block
Env
(
UniqSet
BlockId
)
->
Block
Sources
->
Block
Sources
aux
block
sourcesUFM
=
foldUniqSet
(
add_source_edges
$
blockId
block
)
sourcesUFM
(
branch_targets
$
blockStmts
block
)
add_source_edges
::
BlockId
->
BlockId
->
Block
Env
(
UniqSet
BlockId
)
->
Block
Env
(
UniqSet
BlockId
)
->
Block
Sources
->
Block
Sources
add_source_edges
source
target
ufm
=
addToUFM_Acc
(
flip
addOneToUniqSet
)
unitUniqSet
ufm
target
source
...
...
@@ -83,40 +91,22 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks
target
(
CmmSwitch
_
blocks
)
=
mapMaybe
id
blocks
target
_
=
[]
--------------------------------
-- cmmBlockNames
--
-- Calculates a table that maps
-- block names to the list
-- of statements inside them
--------------------------------
cmmBlockNames
::
[
CmmBasicBlock
]
->
BlockEnv
[
CmmStmt
]
cmmBlockNames
blocks
=
listToUFM
$
map
block_name
blocks
where
block_name
b
=
(
blockId
b
,
blockStmts
b
)
--------------------------------
-- cmmBlockDependants
-----------------------------------------------------------------------------
-- | Given the table calculated by 'cmmBlockSources', list all blocks
-- that depend on the result of a particular block.
--
-- Given the table calculated
-- by cmmBlockSources created,
-- list all blocks that depend
-- on the result of a particular
-- block.
--------------------------------
cmmBlockDependants
::
BlockEnv
(
UniqSet
BlockId
)
->
BlockId
->
[
BlockId
]
-- Used by the call to 'fixedpoint'.
-----------------------------------------------------------------------------
cmmBlockDependants
::
BlockSources
->
BlockId
->
[
BlockId
]
cmmBlockDependants
sources
ident
=
uniqSetToList
$
lookupWithDefaultUFM
sources
emptyUniqSet
ident
--------------------------------
-- cmmBlockUpdate
--
-- Given the table from
-- cmmBlockNames and a block
-- that was updated, calculate
-- an updated BlockEntryLiveness
--------------------------------
-----------------------------------------------------------------------------
-- | Given the table of type 'BlockStmts' and a block that was updated,
-- calculate an updated BlockEntryLiveness
-----------------------------------------------------------------------------
cmmBlockUpdate
::
Block
Env
[
CmmStmt
]
Block
Stmts
->
BlockId
->
Maybe
BlockId
->
BlockEntryLiveness
...
...
@@ -126,12 +116,18 @@ cmmBlockUpdate blocks node _ state =
then
Nothing
else
Just
$
addToUFM
state
node
new_live
where
new_live
=
cmmStmtListLive
state
block
new_live
,
old_live
::
CmmLive
new_live
=
cmmStmtListLive
state
block_stmts
old_live
=
lookupWithDefaultUFM
state
missing_live
node
block
=
lookupWithDefaultUFM
blocks
missing_block
node
block_stmts
::
[
CmmStmt
]
block_stmts
=
lookupWithDefaultUFM
blocks
missing_block
node
missing_live
=
panic
"unknown block id during liveness analysis"
missing_block
=
panic
"unknown block id during liveness analysis"
-----------------------------------------------------------------------------
-- Section:
-----------------------------------------------------------------------------
-- CmmBlockLive, cmmStmtListLive and helpers
-----------------------------------------------------------------------------
...
...
Write
Preview
Markdown
is supported
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