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
Glasgow Haskell Compiler
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
.
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