Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,251
Issues
4,251
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
395
Merge Requests
395
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
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
Glasgow Haskell Compiler
GHC
Commits
1f8efd5d
Commit
1f8efd5d
authored
Jul 03, 2007
by
Michael D. Adams
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Added support for update frames to the CPS pass
(This required a bit of refactoring of CmmInfo.)
parent
55f8b001
Changes
8
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
204 additions
and
127 deletions
+204
-127
compiler/cmm/Cmm.hs
compiler/cmm/Cmm.hs
+17
-5
compiler/cmm/CmmCPS.hs
compiler/cmm/CmmCPS.hs
+44
-34
compiler/cmm/CmmCPSGen.hs
compiler/cmm/CmmCPSGen.hs
+63
-34
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmInfo.hs
+13
-12
compiler/cmm/CmmParse.y
compiler/cmm/CmmParse.y
+34
-26
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmm.hs
+25
-10
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/CgInfoTbls.hs
+7
-5
compiler/codeGen/CgMonad.lhs
compiler/codeGen/CgMonad.lhs
+1
-1
No files found.
compiler/cmm/Cmm.hs
View file @
1f8efd5d
...
...
@@ -9,7 +9,8 @@
module
Cmm
(
GenCmm
(
..
),
Cmm
,
RawCmm
,
GenCmmTop
(
..
),
CmmTop
,
RawCmmTop
,
CmmInfo
(
..
),
ClosureTypeInfo
(
..
),
ProfilingInfo
(
..
),
ClosureTypeTag
,
CmmInfo
(
..
),
UpdateFrame
(
..
),
CmmInfoTable
(
..
),
ClosureTypeInfo
(
..
),
ProfilingInfo
(
..
),
ClosureTypeTag
,
GenBasicBlock
(
..
),
CmmBasicBlock
,
blockId
,
blockStmts
,
mapBlockStmts
,
CmmStmt
(
..
),
CmmActuals
,
CmmFormal
,
CmmFormals
,
CmmHintFormals
,
CmmSafety
(
..
),
...
...
@@ -110,15 +111,19 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
-- Info Tables
-----------------------------------------------------------------------------
-- Info table as a haskell data type
data
CmmInfo
=
CmmInfo
ProfilingInfo
(
Maybe
BlockId
)
-- GC target
(
Maybe
UpdateFrame
)
-- Update frame
CmmInfoTable
-- Info table
-- Info table as a haskell data type
data
CmmInfoTable
=
CmmInfoTable
ProfilingInfo
ClosureTypeTag
-- Int
ClosureTypeInfo
|
CmmNonInfo
-- Procedure doesn't need an info table
(
Maybe
BlockId
)
-- But we still need a GC target for it
|
CmmNonInfoTable
-- Procedure doesn't need an info table
-- TODO: The GC target shouldn't really be part of CmmInfo
-- as it doesn't appear in the resulting info table.
...
...
@@ -146,6 +151,13 @@ type SlowEntry = CmmLit
-- for now the parser sets this to zero on an INFO_TABLE_FUN.
type
SelectorOffset
=
StgWord
-- | A frame that is to be pushed before entry to the function.
-- Used to handle 'update' frames.
data
UpdateFrame
=
UpdateFrame
CmmExpr
-- Frame header. Behaves like the target of a 'jump'.
[
CmmExpr
]
-- Frame remainder. Behaves like the arguments of a 'jump'.
-----------------------------------------------------------------------------
-- CmmStmt
-- A "statement". Note that all branches are explicit: there are no
...
...
compiler/cmm/CmmCPS.hs
View file @
1f8efd5d
...
...
@@ -87,23 +87,19 @@ make_gc_check stack_use gc_block =
force_gc_block
old_info
stack_use
block_id
fun_label
formals
=
case
old_info
of
Cmm
NonInfo
(
Just
existing
)
->
(
old_info
,
[]
,
make_gc_check
stack_use
existing
)
CmmInfo
_
(
Just
existing
)
_
_
->
(
old_info
,
[]
,
make_gc_check
stack_use
existing
)
Cmm
NonInfo
Nothing
->
(
Cmm
NonInfo
(
Just
block_id
)
,
[
make_gc_block
block_id
fun_label
formals
(
CmmSafe
NoC_SRT
)],
Cmm
Info
(
Just
existing
)
_
_
->
(
old_info
,
[]
,
make_gc_check
stack_use
existing
)
Cmm
Info
Nothing
update_frame
info_table
->
(
Cmm
Info
(
Just
block_id
)
update_frame
info_table
,
[
make_gc_block
block_id
fun_label
formals
(
CmmSafe
$
cmmInfoTableSRT
info_table
)],
make_gc_check
stack_use
block_id
)
CmmInfo
prof
Nothing
type_tag
type_info
->
(
CmmInfo
prof
(
Just
block_id
)
type_tag
type_info
,
[
make_gc_block
block_id
fun_label
formals
(
CmmSafe
srt
)],
make_gc_check
stack_use
block_id
)
where
srt
=
case
type_info
of
ConstrInfo
_
_
_
->
NoC_SRT
FunInfo
_
srt'
_
_
_
_
->
srt'
ThunkInfo
_
srt'
->
srt'
ThunkSelectorInfo
_
srt'
->
srt'
ContInfo
_
srt'
->
srt'
cmmInfoTableSRT
CmmNonInfoTable
=
NoC_SRT
cmmInfoTableSRT
(
CmmInfoTable
_
_
(
ConstrInfo
_
_
_
))
=
NoC_SRT
cmmInfoTableSRT
(
CmmInfoTable
_
_
(
FunInfo
_
srt
_
_
_
_
))
=
srt
cmmInfoTableSRT
(
CmmInfoTable
_
_
(
ThunkInfo
_
srt
))
=
srt
cmmInfoTableSRT
(
CmmInfoTable
_
_
(
ThunkSelectorInfo
_
srt
))
=
srt
cmmInfoTableSRT
(
CmmInfoTable
_
_
(
ContInfo
_
srt
))
=
srt
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
...
...
@@ -127,7 +123,7 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
(
uniqSupply1
,
uniqSupply2
)
=
splitUniqSupply
uniqSupply
uniques
::
[[
Unique
]]
uniques
=
map
uniqsFromSupply
$
listSplitUniqSupply
uniqSupply1
(
gc_unique
:
stack_use_unique
:
info_uniques
)
:
adaptor_uniques
:
block_uniques
=
uniques
(
gc_unique
:
gc_block_unique
:
stack_use_unique
:
info_uniques
)
:
adaptor_uniques
:
block_uniques
=
uniques
proc_uniques
=
map
(
map
uniqsFromSupply
.
listSplitUniqSupply
)
$
listSplitUniqSupply
uniqSupply2
stack_use
=
CmmLocal
(
LocalReg
stack_use_unique
(
cmmRegRep
spReg
)
KindPtr
)
...
...
@@ -136,16 +132,17 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
forced_gc
::
(
CmmInfo
,
[
CmmBasicBlock
],
[
CmmStmt
])
forced_gc
=
force_gc_block
info
stack_use
(
BlockId
gc_unique
)
ident
params
(
forced_info
,
gc_blocks
,
check_stmts
)
=
forced_gc
gc_block_id
=
BlockId
gc_block_unique
forced_blocks
=
case
blocks
of
(
BasicBlock
id
stmts
)
:
bs
->
(
BasicBlock
id
(
check_stmts
++
stmts
))
:
(
bs
++
gc_blocks
)
[]
->
[]
-- If there is no code then we don't need a stack check
forced_blocks
=
BasicBlock
gc_block_id
(
check_stmts
++
[
CmmBranch
$
blockId
$
head
blocks
])
:
blocks
++
gc_blocks
forced_gc_id
=
case
forced_info
of
CmmNonInfo
(
Just
x
)
->
x
CmmInfo
_
(
Just
x
)
_
_
->
x
CmmInfo
(
Just
x
)
_
_
->
x
update_frame
=
case
info
of
CmmInfo
_
u
_
->
u
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
...
...
@@ -199,13 +196,13 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
-- Do a little meta-processing on the stack formats such as
-- getting the individual frame sizes and the maximum frame size
formats'
::
(
WordOff
,
[(
CLabel
,
ContinuationFormat
)])
formats'
=
processFormats
formats
continuations
formats'
::
(
WordOff
,
WordOff
,
[(
CLabel
,
ContinuationFormat
)])
formats'
@
(
_
,
_
,
format_list
)
=
processFormats
formats
update_frame
continuations
-- Update the info table data on the continuations with
-- the selected stack formats.
continuations'
::
[
Continuation
CmmInfo
]
continuations'
=
map
(
applyContinuationFormat
(
snd
formats'
)
)
continuations
continuations'
=
map
(
applyContinuationFormat
format_list
)
continuations
-- Do the actual CPS transform.
cps_procs
::
[
CmmTop
]
...
...
@@ -257,7 +254,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
info_table
=
case
start_block_entry
of
FunctionEntry
info
_
_
->
Right
info
ContinuationEntry
_
srt
_
->
Left
srt
ControlEntry
->
Right
(
Cmm
NonInfo
Nothing
)
ControlEntry
->
Right
(
Cmm
Info
Nothing
Nothing
CmmNonInfoTable
)
is_gc_cont
=
case
start_block_entry
of
FunctionEntry
_
_
_
->
False
...
...
@@ -287,7 +284,7 @@ selectContinuationFormat live continuations =
where
-- User written continuations
selectContinuationFormat'
(
Continuation
(
Right
(
CmmInfo
_
_
_
(
ContInfo
format
srt
)))
(
Right
(
CmmInfo
_
_
(
CmmInfoTable
_
_
(
ContInfo
format
srt
)
)))
label
formals
_
_
)
=
(
formals
,
Just
label
,
format
)
-- Either user written non-continuation code
...
...
@@ -306,9 +303,11 @@ selectContinuationFormat live continuations =
unknown_block
=
panic
"unknown BlockId in selectContinuationFormat"
processFormats
::
[(
CLabel
,
(
CmmFormals
,
Maybe
CLabel
,
[
Maybe
LocalReg
]))]
->
Maybe
UpdateFrame
->
[
Continuation
(
Either
C_SRT
CmmInfo
)]
->
(
WordOff
,
[(
CLabel
,
ContinuationFormat
)])
processFormats
formats
continuations
=
(
max_size
,
formats'
)
->
(
WordOff
,
WordOff
,
[(
CLabel
,
ContinuationFormat
)])
processFormats
formats
update_frame
continuations
=
(
max_size
+
update_frame_size
,
update_frame_size
,
formats'
)
where
max_size
=
maximum
$
0
:
map
(
continuationMaxStack
formats'
)
continuations
...
...
@@ -324,6 +323,17 @@ processFormats formats continuations = (max_size, formats')
else
0
,
continuation_stack
=
stack
})
update_frame_size
=
case
update_frame
of
Nothing
->
0
(
Just
(
UpdateFrame
_
args
))
->
label_size
+
update_size
args
update_size
[]
=
0
update_size
(
expr
:
exprs
)
=
width
+
update_size
exprs
where
width
=
machRepByteWidth
(
cmmExprRep
expr
)
`
quot
`
wORD_SIZE
-- TODO: it would be better if we had a machRepWordWidth
-- TODO: get rid of "+ 1" etc.
label_size
=
1
::
WordOff
...
...
@@ -381,9 +391,9 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)]
-- User written continuations
applyContinuationFormat
formats
(
Continuation
(
Right
(
CmmInfo
prof
gc
tag
(
ContInfo
_
srt
)))
(
Right
(
CmmInfo
gc
update_frame
(
CmmInfoTable
prof
tag
(
ContInfo
_
srt
)
)))
label
formals
is_gc
blocks
)
=
Continuation
(
CmmInfo
prof
gc
tag
(
ContInfo
format
srt
))
Continuation
(
CmmInfo
gc
update_frame
(
CmmInfoTable
prof
tag
(
ContInfo
format
srt
)
))
label
formals
is_gc
blocks
where
format
=
continuation_stack
$
maybe
unknown_block
id
$
lookup
label
formats
...
...
@@ -397,7 +407,7 @@ applyContinuationFormat formats (Continuation
-- CPS generated continuations
applyContinuationFormat
formats
(
Continuation
(
Left
srt
)
label
formals
is_gc
blocks
)
=
Continuation
(
CmmInfo
prof
gc
tag
(
ContInfo
(
continuation_stack
$
format
)
srt
))
Continuation
(
CmmInfo
gc
Nothing
(
CmmInfoTable
prof
tag
(
ContInfo
(
continuation_stack
$
format
)
srt
)
))
label
formals
is_gc
blocks
where
gc
=
Nothing
-- Generated continuations never need a stack check
...
...
compiler/cmm/CmmCPSGen.hs
View file @
1f8efd5d
...
...
@@ -78,12 +78,12 @@ data ContinuationFormat
-- A block can be an entry to a function
-----------------------------------------------------------------------------
continuationToProc
::
(
WordOff
,
[(
CLabel
,
ContinuationFormat
)])
continuationToProc
::
(
WordOff
,
WordOff
,
[(
CLabel
,
ContinuationFormat
)])
->
CmmReg
->
[[
Unique
]]
->
Continuation
CmmInfo
->
CmmTop
continuationToProc
(
max_stack
,
formats
)
stack_use
uniques
continuationToProc
(
max_stack
,
update_frame_size
,
formats
)
stack_use
uniques
(
Continuation
info
label
formals
_
blocks
)
=
CmmProc
info
label
formals
(
concat
$
zipWith3
continuationToProc'
uniques
blocks
(
True
:
repeat
False
))
where
...
...
@@ -98,14 +98,18 @@ continuationToProc (max_stack, formats) stack_use uniques
gc_stmts
::
[
CmmStmt
]
gc_stmts
=
case
info
of
CmmInfo
_
(
Just
gc_block
)
_
_
->
CmmInfo
(
Just
gc_block
)
_
_
->
gc_stack_check'
stack_use
arg_stack
(
max_stack
-
curr_stack
)
CmmInfo
_
Nothing
_
_
->
CmmInfo
Nothing
_
_
->
panic
"continuationToProc: missing GC block"
CmmNonInfo
(
Just
gc_block
)
->
gc_stack_check'
stack_use
arg_stack
(
max_stack
-
curr_stack
)
CmmNonInfo
Nothing
->
panic
"continuationToProc: missing non-info GC block"
update_stmts
::
[
CmmStmt
]
update_stmts
=
case
info
of
CmmInfo
_
(
Just
(
UpdateFrame
target
args
))
_
->
pack_frame
curr_stack
update_frame_size
(
Just
target
)
(
map
Just
args
)
++
adjust_sp_reg
(
curr_stack
-
update_frame_size
)
CmmInfo
_
Nothing
_
->
[]
-- At present neither the Cmm parser nor the code generator
-- produce code that will allow the target of a CmmCondBranch
...
...
@@ -148,7 +152,18 @@ continuationToProc (max_stack, formats) stack_use uniques
block_for_branch'
unique
(
Just
next
)
=
(
Just
new_next
,
new_blocks
)
where
(
new_next
,
new_blocks
)
=
block_for_branch
unique
next
main_block
=
BasicBlock
ident
(
stmts
++
postfix_stmts
)
main_block
=
case
entry
of
FunctionEntry
_
_
_
->
-- Ugh, the statements for an update frame must come
-- *after* the GC check that was added at the beginning
-- of the CPS pass. So we have do edit the statements
-- a bit. This depends on the knowledge that the
-- statements in the first block are only the GC check.
-- That's fragile but it works for now.
BasicBlock
ident
(
stmts
++
update_stmts
++
postfix_stmts
)
ControlEntry
->
BasicBlock
ident
(
stmts
++
postfix_stmts
)
ContinuationEntry
_
_
_
->
BasicBlock
ident
(
stmts
++
postfix_stmts
)
prefix_id
=
BlockId
prefix_unique
gc_prefix
=
case
entry
of
FunctionEntry
_
_
_
->
gc_stmts
...
...
@@ -336,20 +351,21 @@ currentNursery = CmmGlobal CurrentNursery
tail_call
::
WordOff
->
CmmExpr
->
CmmActuals
->
[
CmmStmt
]
tail_call
spRel
target
arguments
=
store_arguments
++
adjust_sp
Reg
++
jump
where
=
store_arguments
++
adjust_sp
_reg
spRel
++
jump
where
store_arguments
=
[
stack_put
spRel
expr
offset
|
((
expr
,
_
),
StackParam
offset
)
<-
argument_formats
]
++
[
global_put
expr
global
|
((
expr
,
_
),
RegisterParam
global
)
<-
argument_formats
]
adjust_spReg
=
if
spRel
==
0
then
[]
else
[
CmmAssign
spReg
(
CmmRegOff
spReg
(
spRel
*
wORD_SIZE
))]
jump
=
[
CmmJump
target
arguments
]
argument_formats
=
assignArguments
(
cmmExprRep
.
fst
)
arguments
adjust_sp_reg
spRel
=
if
spRel
==
0
then
[]
else
[
CmmAssign
spReg
(
CmmRegOff
spReg
(
spRel
*
wORD_SIZE
))]
gc_stack_check'
stack_use
arg_stack
max_frame_size
=
if
max_frame_size
>
arg_stack
then
[
CmmAssign
stack_use
(
CmmRegOff
spReg
(
-
max_frame_size
*
wORD_SIZE
))]
...
...
@@ -367,10 +383,6 @@ gc_stack_check gc_block max_frame_size
gc_block
]
-- TODO: fix branches to proc point
-- (we have to insert a new block to marshel the continuation)
pack_continuation
::
Bool
-- ^ Whether to set the top/header
-- of the stack. We only need to
-- set it if we are calling down
...
...
@@ -382,35 +394,52 @@ pack_continuation :: Bool -- ^ Whether to set the top/header
pack_continuation
allow_header_set
(
ContinuationFormat
_
curr_id
curr_frame_size
_
)
(
ContinuationFormat
_
cont_id
cont_frame_size
live_regs
)
=
store_live_values
++
set_stack_header
where
=
pack_frame
curr_frame_size
cont_frame_size
maybe_header
continuation_args
where
continuation_function
=
CmmLit
$
CmmLabel
$
fromJust
cont_id
continuation_args
=
map
(
maybe
Nothing
(
Just
.
CmmReg
.
CmmLocal
))
live_regs
needs_header_set
=
case
(
curr_id
,
cont_id
)
of
(
Just
x
,
Just
y
)
->
x
/=
y
_
->
isJust
cont_id
maybe_header
=
if
allow_header_set
&&
needs_header_set
then
Just
continuation_function
else
Nothing
pack_frame
::
WordOff
-- ^ Current frame size
->
WordOff
-- ^ Next frame size
->
Maybe
CmmExpr
-- ^ Next frame header if any
->
[
Maybe
CmmExpr
]
-- ^ Next frame data
->
[
CmmStmt
]
pack_frame
curr_frame_size
next_frame_size
next_frame_header
frame_args
=
store_live_values
++
set_stack_header
where
-- TODO: only save variables when actually needed
-- (may be handled by latter pass)
store_live_values
=
[
stack_put
spRel
(
CmmReg
(
CmmLocal
reg
))
offset
|
(
reg
,
offset
)
<-
cont_offsets
]
[
stack_put
spRel
expr
offset
|
(
expr
,
offset
)
<-
cont_offsets
]
set_stack_header
=
if
needs_header_set
&&
allow_header_set
then
[
stack_put
spRel
continuation_function
0
]
else
[
]
case
next_frame_header
of
Nothing
->
[
]
Just
expr
->
[
stack_put
spRel
expr
0
]
-- TODO: factor with function_entry and CmmInfo.hs(?)
cont_offsets
=
mkOffsets
label_size
live_re
gs
cont_offsets
=
mkOffsets
label_size
frame_ar
gs
label_size
=
1
::
WordOff
mkOffsets
size
[]
=
[]
mkOffsets
size
(
Nothing
:
regs
)
=
mkOffsets
(
size
+
1
)
reg
s
mkOffsets
size
(
Just
reg
:
regs
)
=
(
reg
,
size
)
:
mkOffsets
(
size
+
width
)
reg
s
mkOffsets
size
(
Nothing
:
exprs
)
=
mkOffsets
(
size
+
1
)
expr
s
mkOffsets
size
(
Just
expr
:
exprs
)
=
(
expr
,
size
)
:
mkOffsets
(
size
+
width
)
expr
s
where
width
=
machRepByteWidth
(
localRegRep
reg
)
`
quot
`
wORD_SIZE
width
=
machRepByteWidth
(
cmmExprRep
expr
)
`
quot
`
wORD_SIZE
-- TODO: it would be better if we had a machRepWordWidth
spRel
=
curr_frame_size
-
cont_frame_size
continuation_function
=
CmmLit
$
CmmLabel
$
fromJust
cont_id
needs_header_set
=
case
(
curr_id
,
cont_id
)
of
(
Just
x
,
Just
y
)
->
x
/=
y
_
->
isJust
cont_id
spRel
=
curr_frame_size
-
next_frame_size
-- Lazy adjustment of stack headers assumes all blocks
-- that could branch to eachother (i.e. control blocks)
...
...
compiler/cmm/CmmInfo.hs
View file @
1f8efd5d
...
...
@@ -71,15 +71,15 @@ cmmToRawCmm cmm = do
mkInfoTable
::
Unique
->
CmmTop
->
[
RawCmmTop
]
mkInfoTable
uniq
(
CmmData
sec
dat
)
=
[
CmmData
sec
dat
]
mkInfoTable
uniq
(
CmmProc
info
entry_label
arguments
blocks
)
=
mkInfoTable
uniq
(
CmmProc
(
CmmInfo
_
_
info
)
entry_label
arguments
blocks
)
=
case
info
of
-- | Code without an info table. Easy.
CmmNonInfo
_
->
[
CmmProc
[]
entry_label
arguments
blocks
]
CmmNonInfo
Table
->
[
CmmProc
[]
entry_label
arguments
blocks
]
-- | A function entry point.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
FunInfo
(
ptrs
,
nptrs
)
srt
fun_type
fun_arity
pap_bitmap
slow_entry
)
->
CmmInfo
Table
(
ProfilingInfo
ty_prof
cl_prof
)
type_tag
(
FunInfo
(
ptrs
,
nptrs
)
srt
fun_type
fun_arity
pap_bitmap
slow_entry
)
->
mkInfoTableAndCode
info_label
std_info
fun_extra_bits
entry_label
arguments
blocks
where
...
...
@@ -97,8 +97,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
layout
=
packHalfWordsCLit
ptrs
nptrs
-- | A constructor.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ConstrInfo
(
ptrs
,
nptrs
)
con_tag
descr
)
->
CmmInfo
Table
(
ProfilingInfo
ty_prof
cl_prof
)
type_tag
(
ConstrInfo
(
ptrs
,
nptrs
)
con_tag
descr
)
->
mkInfoTableAndCode
info_label
std_info
[
con_name
]
entry_label
arguments
blocks
where
...
...
@@ -108,8 +108,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
layout
=
packHalfWordsCLit
ptrs
nptrs
-- | A thunk.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ThunkInfo
(
ptrs
,
nptrs
)
srt
)
->
CmmInfo
Table
(
ProfilingInfo
ty_prof
cl_prof
)
type_tag
(
ThunkInfo
(
ptrs
,
nptrs
)
srt
)
->
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
where
...
...
@@ -119,8 +119,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
layout
=
packHalfWordsCLit
ptrs
nptrs
-- | A selector thunk.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ThunkSelectorInfo
offset
srt
)
->
CmmInfo
Table
(
ProfilingInfo
ty_prof
cl_prof
)
type_tag
(
ThunkSelectorInfo
offset
srt
)
->
mkInfoTableAndCode
info_label
std_info
[
{- no SRT -}
]
entry_label
arguments
blocks
where
...
...
@@ -128,7 +128,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
info_label
=
entryLblToInfoLbl
entry_label
-- A continuation/return-point.
CmmInfo
(
ProfilingInfo
ty_prof
cl_prof
)
_
type_tag
(
ContInfo
stack_layout
srt
)
->
CmmInfoTable
(
ProfilingInfo
ty_prof
cl_prof
)
type_tag
(
ContInfo
stack_layout
srt
)
->
liveness_data
++
mkInfoTableAndCode
info_label
std_info
srt_label
entry_label
arguments
blocks
...
...
compiler/cmm/CmmParse.y
View file @
1f8efd5d
...
...
@@ -200,47 +200,49 @@ lits :: { [ExtFCode CmmExpr] }
cmmproc :: { ExtCode }
-- TODO: add real SRT/info tables to parsed Cmm
: info maybe_formals '{' body '}'
{ do ((info_lbl, info, live, formals), stmts) <-
: info maybe_formals
maybe_frame
'{' body '}'
{ do ((info_lbl, info, live, formals
, frame
), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
(info_lbl, info, live) <- $1;
formals <- sequence $2;
$4;
return (info_lbl, info, live, formals) }
frame <- $3;
$5;
return (info_lbl, info, live, formals, frame) }
blks <- code (cgStmtsToBlocks stmts)
code (emitInfoTableAndCode info_lbl
info
formals blks) }
code (emitInfoTableAndCode info_lbl
(CmmInfo Nothing frame info)
formals blks) }
| info maybe_formals ';'
{ do (info_lbl, info, live) <- $1;
formals <- sequence $2;
code (emitInfoTableAndCode info_lbl
info
formals []) }
code (emitInfoTableAndCode info_lbl
(CmmInfo Nothing Nothing info)
formals []) }
| NAME maybe_formals '{' body '}'
{ do (
formals
, stmts) <-
| NAME maybe_formals
maybe_frame
'{' body '}'
{ do (
(formals, frame)
, stmts) <-
getCgStmtsEC' $ loopDecls $ do {
formals <- sequence $2;
$4;
return formals }
frame <- $3;
$5;
return (formals, frame) }
blks <- code (cgStmtsToBlocks stmts)
code (emitProc (Cmm
NonInfo Nothing
) (mkRtsCodeLabelFS $1) formals blks) }
code (emitProc (Cmm
Info Nothing frame CmmNonInfoTable
) (mkRtsCodeLabelFS $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
info :: { ExtFCode (CLabel, CmmInfo
Table
, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo
prof Nothing
(fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
CmmInfo
Table prof
(fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
[]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo
prof Nothing
(fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
(ArgSpec 0)
zeroCLit),
CmmInfo
Table prof
(fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
(ArgSpec 0)
zeroCLit),
[]) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
...
...
@@ -252,31 +254,31 @@ info :: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
-- but that's the way the old code did it we can fix it some other time.
desc_lit <- code $ mkStringCLit $13
return (mkRtsInfoLabelFS $3,
CmmInfo
prof Nothing
(fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
CmmInfo
Table prof
(fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
[]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{ do prof <- profilingInfo $9 $11
return (mkRtsInfoLabelFS $3,
CmmInfo
prof Nothing
(fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
CmmInfo
Table prof
(fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
{ return (mkRtsInfoLabelFS $3,
CmmInfo
(ProfilingInfo zeroCLit zeroCLit) Nothing
(fromIntegral $5)
(ContInfo [] NoC_SRT),
CmmInfo
Table (ProfilingInfo zeroCLit zeroCLit)
(fromIntegral $5)
(ContInfo [] NoC_SRT),
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
{ do live <- sequence (map (liftM Just) $7)
return (mkRtsInfoLabelFS $3,
CmmInfo
(ProfilingInfo zeroCLit zeroCLit) Nothing
(fromIntegral $5)
(ContInfo live NoC_SRT),
CmmInfo
Table (ProfilingInfo zeroCLit zeroCLit)
(fromIntegral $5)
(ContInfo live NoC_SRT),
live) }
body :: { ExtCode }
...
...
@@ -503,6 +505,12 @@ formal :: { ExtFCode LocalReg }
| STRING type NAME {% do k <- parseKind $1;
return $ newLocal k $2 $3 }
maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
: {- empty -} { return Nothing }
| 'jump' expr '(' exprs0 ')' { do { target <- $2;
args <- sequence $4;
return $ Just (UpdateFrame target args) } }
type :: { MachRep }
: 'bits8' { I8 }
| typenot8 { $1 }
...
...
compiler/cmm/PprCmm.hs
View file @
1f8efd5d
...
...
@@ -129,17 +129,19 @@ instance Outputable CmmSafety where
-- For ideas on how to refine it, they used to be printed in the
-- style of C--'s 'stackdata' declaration, just inside the proc body,
-- and were labelled with the procedure name ++ "_info".
pprInfo
(
CmmNonInfo
gc_target
)
=
ptext
SLIT
(
"gc_target: "
)
<>
ptext
SLIT
(
"TODO"
)
--maybe (ptext SLIT("<none>")) pprBlockId gc_target
-- ^ gc_target is currently unused and wired to a panic
pprInfo
(
CmmInfo
(
ProfilingInfo
closure_type
closure_desc
)
gc_target
tag
info
)
=
vcat
[
ptext
SLIT
(
"type: "
)
<>
pprLit
closure_type
,
pprInfo
(
CmmInfo
gc_target
update_frame
CmmNonInfoTable
)
=
vcat
[
ptext
SLIT
(
"gc_target: "
)
<>
maybe
(
ptext
SLIT
(
"<none>"
))
pprBlockId
gc_target
,
ptext
SLIT
(
"update_frame: "
)
<>
maybe
(
ptext
SLIT
(
"<none>"
))
pprUpdateFrame
update_frame
]
pprInfo
(
CmmInfo
gc_target
update_frame
(
CmmInfoTable
(
ProfilingInfo
closure_type
closure_desc
)
tag
info
))
=
vcat
[
ptext
SLIT
(
"gc_target: "
)
<>
maybe
(
ptext
SLIT
(
"<none>"
))
pprBlockId
gc_target
,
ptext
SLIT
(
"update_frame: "
)
<>
maybe
(
ptext
SLIT
(
"<none>"
))
pprUpdateFrame
update_frame
,
ptext
SLIT
(
"type: "
)
<>
pprLit
closure_type
,
ptext
SLIT
(
"desc: "
)
<>
pprLit
closure_desc
,
ptext
SLIT
(
"gc_target: "
)
<>
ptext
SLIT
(
"TODO"
),
--maybe (ptext SLIT("<none>")) pprBlockId gc_target,
-- ^ gc_target is currently unused and wired to a panic
ptext
SLIT
(
"tag: "
)
<>
integer
(
toInteger
tag
),
pprTypeInfo
info
]
...
...
@@ -168,6 +170,19 @@ pprTypeInfo (ContInfo stack srt) =
vcat
[
ptext
SLIT
(
"stack: "
)
<>
ppr
stack
,
ptext
SLIT
(
"srt: "
)
<>
ppr
srt
]
pprUpdateFrame
::
UpdateFrame
->
SDoc
pprUpdateFrame
(
UpdateFrame
expr
args
)
=
hcat
[
ptext
SLIT
(
"jump"
)
,
space
,
if
isTrivialCmmExpr
expr
then
pprExpr
expr
else
case
expr
of
CmmLoad
(
CmmReg
_
)
_
->
pprExpr
expr
_
->
parens
(
pprExpr
expr
)
,
space
,
parens
(
commafy
$
map
ppr
args
)
]
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
...
...
compiler/codeGen/CgInfoTbls.hs
View file @
1f8efd5d
...
...
@@ -89,12 +89,12 @@ mkCmmInfo cl_info = do
info
=
ConstrInfo
(
ptrs
,
nptrs
)
(
fromIntegral
(
dataConTagZ
con
))
conName
return
$
CmmInfo
prof
gc_target
cl_type
info
return
$
CmmInfo
gc_target
Nothing
(
CmmInfoTable
prof
cl_type
info
)
ClosureInfo
{
closureName
=
name
,
closureLFInfo
=
lf_info
,
closureSRT
=
srt
}
->
return
$
CmmInfo
prof
gc_target
cl_type
info
return
$
CmmInfo
gc_target
Nothing
(
CmmInfoTable
prof
cl_type
info
)
where
info
=
case
lf_info
of
...
...
@@ -145,10 +145,12 @@ emitReturnTarget name stmts
;
blks
<-
cgStmtsToBlocks
stmts
;
frame
<-
mkStackLayout
;
let
info
=
CmmInfo
(
ProfilingInfo
zeroCLit
zeroCLit
)
gc_target
rET_SMALL
-- cmmToRawCmm may convert it to rET_BIG
(
ContInfo
frame
srt_info
)
Nothing
(
CmmInfoTable
(
ProfilingInfo
zeroCLit
zeroCLit
)
rET_SMALL
-- cmmToRawCmm may convert it to rET_BIG
(
ContInfo
frame
srt_info
))
;
emitInfoTableAndCode
info_lbl
info
args
blks
;
return
info_lbl
}
where
...
...
compiler/codeGen/CgMonad.lhs
View file @
1f8efd5d
...
...
@@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code
emitSimpleProc lbl code
= do { stmts <- getCgStmts code