Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
b44b0bef
Commit
b44b0bef
authored
Jul 05, 2007
by
Michael D. Adams
Browse files
Added support for GC block declaration to the Cmm syntax
parent
5f00461a
Changes
5
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/Cmm.hs
View file @
b44b0bef
...
...
@@ -113,7 +113,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
data
CmmInfo
=
CmmInfo
(
Maybe
BlockId
)
-- GC target
(
Maybe
BlockId
)
-- GC target
. Nothing <=> CPS won't do stack check
(
Maybe
UpdateFrame
)
-- Update frame
CmmInfoTable
-- Info table
...
...
compiler/cmm/CmmCPS.hs
View file @
b44b0bef
...
...
@@ -15,7 +15,6 @@ import CmmBrokenBlock
import
CmmProcPoint
import
CmmCallConv
import
CmmCPSGen
import
CmmInfo
import
CmmUtils
import
ClosureInfo
...
...
@@ -69,37 +68,23 @@ cmmCPS dflags abstractC = do
return
continuationC
stg_gc_gen
=
mkRtsApFastLabel
SLIT
(
"gen_cg_TODO"
)
--panic "Need the label for gc"
make_gc_block
block_id
fun_label
formals
safety
=
BasicBlock
block_id
stmts
make_stack_check
stack_check_block_id
info
stack_use
next_block_id
=
BasicBlock
stack_check_block_id
$
check_stmts
++
[
CmmBranch
next_block_id
]
where
stmts
=
[
CmmCall
stg_gc_gen_target
[]
[]
safety
,
CmmJump
fun_expr
actuals
]
stg_gc_gen_target
=
CmmForeignCall
(
CmmLit
(
CmmLabel
stg_gc_gen
))
CmmCallConv
actuals
=
map
(
\
x
->
(
CmmReg
(
CmmLocal
x
),
NoHint
))
formals
fun_expr
=
CmmLit
(
CmmLabel
fun_label
)
make_gc_check
stack_use
gc_block
=
[
CmmCondBranch
(
CmmMachOp
(
MO_U_Lt
$
cmmRegRep
spReg
)
[
CmmReg
stack_use
,
CmmReg
spLimReg
])
gc_block
]
force_gc_block
old_info
stack_use
block_id
fun_label
formals
=
case
old_info
of
CmmInfo
(
Just
existing
)
_
_
->
(
old_info
,
[]
,
make_gc_check
stack_use
existing
)
CmmInfo
Nothing
update_frame
info_table
->
(
CmmInfo
(
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
)
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
check_stmts
=
case
info
of
-- If we are given a stack check handler,
-- then great, well check the stack.
CmmInfo
(
Just
gc_block
)
_
_
->
[
CmmCondBranch
(
CmmMachOp
(
MO_U_Lt
$
cmmRegRep
spReg
)
[
CmmReg
stack_use
,
CmmReg
spLimReg
])
gc_block
]
-- If we aren't given a stack check handler,
-- then humph! we just won't check the stack for them.
CmmInfo
Nothing
_
_
->
[]
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
...
...
@@ -120,39 +105,35 @@ cpsProc uniqSupply proc@(CmmProc _ _ _ []) = [proc]
-- CPS transform for those procs that actually need it
cpsProc
uniqSupply
(
CmmProc
info
ident
params
blocks
)
=
cps_procs
where
-- We need to be generating uniques for several things.
-- We could make this function monadic to handle that
-- but since there is no other reason to make it monadic,
-- we instead will just split them all up right here.
(
uniqSupply1
,
uniqSupply2
)
=
splitUniqSupply
uniqSupply
uniques
::
[[
Unique
]]
uniques
=
map
uniqsFromSupply
$
listSplitUniqSupply
uniqSupply1
(
gc_unique
:
gc_block_unique
:
stack_use_unique
:
info_uniques
)
:
adaptor_uniques
:
block_uniques
=
uniques
(
stack_check_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
)
stack_check_block_id
=
BlockId
stack_check_block_unique
stack_check_block
=
make_stack_check
stack_check_block_id
info
stack_use
(
blockId
$
head
blocks
)
-- TODO: doc
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
=
stack_check_block
:
blocks
forced_blocks
=
BasicBlock
gc_block_id
(
check_stmts
++
[
CmmBranch
$
blockId
$
head
blocks
])
:
blocks
++
gc_blocks
forced_gc_id
=
case
forced_info
of
CmmInfo
(
Just
x
)
_
_
->
x
update_frame
=
case
info
of
CmmInfo
_
u
_
->
u
CmmInfo
maybe_gc_block_id
update_frame
_
=
info
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
broken_blocks
::
([(
BlockId
,
ContFormat
)],
[
BrokenBlock
])
broken_blocks
=
(
\
x
->
(
concatMap
fst
x
,
concatMap
snd
x
))
$
zipWith3
(
breakBlock
[
forced_gc
_id
]
)
zipWith3
(
breakBlock
(
maybeToList
maybe_gc_block
_id
)
)
block_uniques
forced_blocks
(
FunctionEntry
forced_
info
ident
params
:
(
FunctionEntry
info
ident
params
:
repeat
ControlEntry
)
f'
=
selectContinuations
(
fst
broken_blocks
)
...
...
@@ -243,9 +224,9 @@ gatherBlocksIntoContinuation live proc_points blocks start =
Continuation
info_table
clabel
params
is_gc_cont
body
where
children
=
(
collectNonProcPointTargets
proc_points
blocks
(
unitUniqSet
start
)
[
start
])
`
minusUniqSet
`
(
unitUniqSet
start
)
start_block
=
lookupWithDefaultUFM
blocks
(
panic
"TODO"
)
start
start_block
=
lookupWithDefaultUFM
blocks
unknown_block
start
children_blocks
=
map
(
lookupWithDefaultUFM
blocks
unknown_block
)
(
uniqSetToList
children
)
unknown_block
=
panic
"unknown block in gatherBlocksIntoContinuation"
children_blocks
=
map
(
lookupWithDefaultUFM
blocks
(
panic
"TODO"
))
(
uniqSetToList
children
)
body
=
start_block
:
children_blocks
-- We can't properly annotate the continuation's stack parameters
...
...
compiler/cmm/CmmCPSGen.hs
View file @
b44b0bef
...
...
@@ -97,11 +97,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
gc_stmts
::
[
CmmStmt
]
gc_stmts
=
case
info
of
CmmInfo
(
Just
gc_block
)
_
_
->
gc_stack_check'
stack_use
arg_stack
(
max_stack
-
curr_stack
)
CmmInfo
Nothing
_
_
->
panic
"continuationToProc: missing GC block"
assign_gc_stack_use
stack_use
arg_stack
(
max_stack
-
curr_stack
)
update_stmts
::
[
CmmStmt
]
update_stmts
=
...
...
@@ -124,10 +120,11 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
prefix_blocks
++
[
main_block
]
where
prefix_blocks
=
case
gc_prefix
++
param_prefix
of
[]
->
[]
entry_stmts
->
[
BasicBlock
prefix_id
(
entry_stmts
++
[
CmmBranch
ident
])]
if
is_entry
then
[
BasicBlock
(
BlockId
prefix_unique
)
(
param_stmts
++
[
CmmBranch
ident
])]
else
[]
prefix_unique
:
call_uniques
=
uniques
toCLabel
=
mkReturnPtLabel
.
getUnique
...
...
@@ -161,17 +158,9 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
-- 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
)
BasicBlock
ident
(
gc_stmts
++
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
ControlEntry
->
[]
ContinuationEntry
_
_
_
->
[]
param_prefix
=
if
is_entry
then
param_stmts
else
[]
postfix_stmts
=
case
exit
of
FinalBranch
next
->
if
(
mkReturnPtLabel
$
getUnique
next
)
==
label
...
...
@@ -366,7 +355,7 @@ adjust_sp_reg spRel =
then
[]
else
[
CmmAssign
spReg
(
CmmRegOff
spReg
(
spRel
*
wORD_SIZE
))]
gc_stack_
check'
stack_use
arg_stack
max_frame_size
=
assign_
gc_stack_
use
stack_use
arg_stack
max_frame_size
=
if
max_frame_size
>
arg_stack
then
[
CmmAssign
stack_use
(
CmmRegOff
spReg
(
-
max_frame_size
*
wORD_SIZE
))]
else
[
CmmAssign
stack_use
(
CmmReg
spLimReg
)]
...
...
compiler/cmm/CmmParse.y
View file @
b44b0bef
...
...
@@ -200,14 +200,15 @@ lits :: { [ExtFCode CmmExpr] }
cmmproc :: { ExtCode }
-- TODO: add real SRT/info tables to parsed Cmm
: info maybe_formals maybe_frame '{' body '}'
{ do ((info_lbl, info, live, formals, frame), stmts) <-
: info maybe_formals maybe_frame
maybe_gc_block
'{' body '}'
{ do ((info_lbl, info, live, formals, frame
, gc_block
), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
(info_lbl, info, live) <- $1;
formals <- sequence $2;
frame <- $3;
$5;
return (info_lbl, info, live, formals, frame) }
gc_block <- $4;
$6;
return (info_lbl, info, live, formals, frame, gc_block) }
blks <- code (cgStmtsToBlocks stmts)
code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) }
...
...
@@ -216,15 +217,16 @@ cmmproc :: { ExtCode }
formals <- sequence $2;
code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
| NAME maybe_formals maybe_frame '{' body '}'
{ do ((formals, frame), stmts) <-
| NAME maybe_formals maybe_frame
maybe_gc_block
'{' body '}'
{ do ((formals, frame
, gc_block
), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
formals <- sequence $2;
frame <- $3;
$5;
return (formals, frame) }
gc_block <- $4;
$6;
return (formals, frame, gc_block) }
blks <- code (cgStmtsToBlocks stmts)
code (emitProc (CmmInfo
Nothing
frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
code (emitProc (CmmInfo
gc_block
frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
...
...
@@ -511,6 +513,11 @@ maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
args <- sequence $4;
return $ Just (UpdateFrame target args) } }
maybe_gc_block :: { ExtFCode (Maybe BlockId) }
: {- empty -} { return Nothing }
| 'goto' NAME
{ do l <- lookupLabel $2; return (Just l) }
type :: { MachRep }
: 'bits8' { I8 }
| typenot8 { $1 }
...
...
compiler/cmm/PprCmm.hs
View file @
b44b0bef
...
...
@@ -156,7 +156,7 @@ pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
ptext
SLIT
(
"srt: "
)
<>
ppr
srt
,
ptext
SLIT
(
"fun_type: "
)
<>
integer
(
toInteger
fun_type
),
ptext
SLIT
(
"arity: "
)
<>
integer
(
toInteger
arity
),
--ppr args, -- TODO: needs to be printed
--
ptext SLIT("args: ") <>
ppr args, -- TODO: needs to be printed
ptext
SLIT
(
"slow: "
)
<>
pprLit
slow_entry
]
pprTypeInfo
(
ThunkInfo
layout
srt
)
=
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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