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
fc0ed8a7
Commit
fc0ed8a7
authored
May 14, 2014
by
Simon Marlow
Browse files
Add missing stack checks to stg_ap_* functions (#9001)
parent
88c0870b
Changes
4
Hide whitespace changes
Inline
Side-by-side
testsuite/tests/codeGen/should_run/T9001.hs
0 → 100644
View file @
fc0ed8a7
{-# LANGUAGE RankNTypes #-}
newtype
FMList
=
FM
{
unFM
::
forall
m
.
m
->
m
}
main
=
print
(
delete
2000
(
FM
id
)
::
Int
)
delete
0
_
=
0
delete
n
(
FM
a
)
=
a
$
delete
(
n
-
1
)
$
FM
$
\
g
->
a
(
const
g
)
undefined
testsuite/tests/codeGen/should_run/T9001.stdout
0 → 100644
View file @
fc0ed8a7
0
testsuite/tests/codeGen/should_run/all.T
View file @
fc0ed8a7
...
...
@@ -119,3 +119,4 @@ test('StaticByteArraySize', normal, compile_and_run, ['-O2'])
test
('
CopySmallArray
',
normal
,
compile_and_run
,
[''])
test
('
CopySmallArrayStressTest
',
reqlib
('
random
'),
compile_and_run
,
[''])
test
('
SizeOfSmallArray
',
normal
,
compile_and_run
,
[''])
test
('
T9001
',
normal
,
compile_and_run
,
[''])
utils/genapply/GenApply.hs
View file @
fc0ed8a7
...
...
@@ -21,6 +21,7 @@ import Data.List ( intersperse, nub, sort )
import
System.Exit
import
System.Environment
import
System.IO
import
Control.Arrow
((
***
))
-- -----------------------------------------------------------------------------
-- Argument kinds (rougly equivalent to PrimRep)
...
...
@@ -199,6 +200,45 @@ mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi
mkTagStmt
tag
=
text
(
"R1 = R1 + "
++
show
tag
)
type
StackUsage
=
(
Int
,
Int
)
-- PROFILING, normal
maxStack
::
[
StackUsage
]
->
StackUsage
maxStack
=
(
maximum
***
maximum
)
.
unzip
stackCheck
::
RegStatus
-- Registerised status
->
[
ArgRep
]
->
Bool
-- args in regs?
->
Doc
-- fun_info_label
->
StackUsage
->
Doc
stackCheck
regstatus
args
args_in_regs
fun_info_label
(
prof_sp
,
norm_sp
)
=
let
(
reg_locs
,
leftovers
,
sp_offset
)
=
assignRegs
regstatus
1
args
cmp_sp
n
|
n
>
0
=
text
"if (Sp - WDS("
<>
int
n
<>
text
") < SpLim) {"
$$
nest
4
(
vcat
[
if
args_in_regs
then
text
"Sp_adj"
<>
parens
(
int
(
-
sp_offset
))
<>
semi
$$
saveRegOffs
reg_locs
else
empty
,
text
"Sp(0) = "
<>
fun_info_label
<>
char
';'
,
mkJump
regstatus
(
text
"__stg_gc_enter_1"
)
[
"R1"
]
[]
<>
semi
])
$$
char
'}'
|
otherwise
=
empty
in
vcat
[
text
"#ifdef PROFILING"
,
cmp_sp
prof_sp
,
text
"#else"
,
cmp_sp
norm_sp
,
text
"#endif"
]
genMkPAP
::
RegStatus
-- Register status
->
String
-- Macro
->
String
-- Jump target
...
...
@@ -212,17 +252,19 @@ genMkPAP :: RegStatus -- Register status
->
Int
-- Size of all arguments
->
Doc
-- info label
->
Bool
-- Is a function
->
Doc
->
(
Doc
,
StackUsage
)
genMkPAP
regstatus
macro
jump
live
ticker
disamb
no_load_regs
-- don't load argument regs before jumping
args_in_regs
-- arguments are already in regs
is_pap
args
all_args_size
fun_info_label
is_fun_case
=
smaller_arity_cases
$$
exact_arity_case
$$
larger_arity_case
=
(
doc
,
stack_usage
)
where
doc
=
vcat
smaller_arity_doc
$$
exact_arity_case
$$
larger_arity_doc
stack_usage
=
maxStack
(
larger_arity_stack
:
smaller_arity_stack
)
n_args
=
length
args
-- offset of arguments on the stack at slow apply calls.
...
...
@@ -237,10 +279,17 @@ genMkPAP regstatus macro jump live ticker disamb
-- Sp[0] = Sp[1];
-- Sp[1] = (W_)&stg_ap_1_info;
-- JMP_(GET_ENTRY(R1.cl));
smaller_arity_cases
=
vcat
[
smaller_arity
i
|
i
<-
[
1
..
n_args
-
1
]
]
(
smaller_arity_doc
,
smaller_arity_stack
)
=
unzip
[
smaller_arity
i
|
i
<-
[
1
..
n_args
-
1
]
]
smaller_arity
arity
=
(
doc
,
stack_usage
)
where
(
save_regs
,
stack_usage
)
|
overflow_regs
=
save_extra_regs
|
otherwise
=
shuffle_extra_args
smaller_arity
arity
=
text
"if (arity == "
<>
int
arity
<>
text
") {"
$$
doc
=
text
"if (arity == "
<>
int
arity
<>
text
") {"
$$
nest
4
(
vcat
[
-- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
...
...
@@ -253,9 +302,7 @@ genMkPAP regstatus macro jump live ticker disamb
-- If the extra arguments are on the stack, then we must
-- instead shuffle them down to make room for the info
-- table for the follow-on call.
if
overflow_regs
then
save_extra_regs
else
shuffle_extra_args
,
save_regs
,
-- for a PAP, we have to arrange that the stack contains a
-- return address in the event that stg_PAP_entry fails its
...
...
@@ -271,81 +318,88 @@ genMkPAP regstatus macro jump live ticker disamb
])
$$
text
"}"
where
-- offsets in case we need to save regs:
(
reg_locs
,
_
,
_
)
=
assignRegs
regstatus
stk_args_offset
args
-- register assignment for *this function call*
(
reg_locs'
,
reg_call_leftovers
,
reg_call_sp_stk_args
)
=
assignRegs
regstatus
stk_args_offset
(
take
arity
args
)
load_regs
|
no_load_regs
||
args_in_regs
=
empty
|
otherwise
=
loadRegOffs
reg_locs'
(
this_call_args
,
rest_args
)
=
splitAt
arity
args
-- the offset of the stack args from initial Sp
sp_stk_args
|
args_in_regs
=
stk_args_offset
|
no_load_regs
=
stk_args_offset
|
otherwise
=
reg_call_sp_stk_args
-- the stack args themselves
this_call_stack_args
|
args_in_regs
=
reg_call_leftovers
-- sp offsets are wrong
|
no_load_regs
=
this_call_args
|
otherwise
=
reg_call_leftovers
stack_args_size
=
sum
(
map
argSize
this_call_stack_args
)
overflow_regs
=
args_in_regs
&&
length
reg_locs
>
length
reg_locs'
save_extra_regs
=
-- we have extra arguments in registers to save
let
extra_reg_locs
=
drop
(
length
reg_locs'
)
(
reverse
reg_locs
)
adj_reg_locs
=
[
(
reg
,
off
-
adj
+
1
)
|
(
reg
,
off
)
<-
extra_reg_locs
]
adj
=
case
extra_reg_locs
of
(
reg
,
fst_off
)
:
_
->
fst_off
size
=
snd
(
last
adj_reg_locs
)
in
text
"Sp_adj("
<>
int
(
-
size
-
1
)
<>
text
");"
$$
saveRegOffs
adj_reg_locs
$$
loadSpWordOff
"W_"
0
<>
text
" = "
<>
mkApplyInfoName
rest_args
<>
semi
shuffle_extra_args
=
vcat
[
text
"#ifdef PROFILING"
,
shuffle
True
,
-- offsets in case we need to save regs:
(
reg_locs
,
_
,
_
)
=
assignRegs
regstatus
stk_args_offset
args
-- register assignment for *this function call*
(
reg_locs'
,
reg_call_leftovers
,
reg_call_sp_stk_args
)
=
assignRegs
regstatus
stk_args_offset
(
take
arity
args
)
load_regs
|
no_load_regs
||
args_in_regs
=
empty
|
otherwise
=
loadRegOffs
reg_locs'
(
this_call_args
,
rest_args
)
=
splitAt
arity
args
-- the offset of the stack args from initial Sp
sp_stk_args
|
args_in_regs
=
stk_args_offset
|
no_load_regs
=
stk_args_offset
|
otherwise
=
reg_call_sp_stk_args
-- the stack args themselves
this_call_stack_args
|
args_in_regs
=
reg_call_leftovers
-- sp offsets are wrong
|
no_load_regs
=
this_call_args
|
otherwise
=
reg_call_leftovers
stack_args_size
=
sum
(
map
argSize
this_call_stack_args
)
overflow_regs
=
args_in_regs
&&
length
reg_locs
>
length
reg_locs'
save_extra_regs
=
(
doc
,
(
size
,
size
))
where
-- we have extra arguments in registers to save
extra_reg_locs
=
drop
(
length
reg_locs'
)
(
reverse
reg_locs
)
adj_reg_locs
=
[
(
reg
,
off
-
adj
+
1
)
|
(
reg
,
off
)
<-
extra_reg_locs
]
adj
=
case
extra_reg_locs
of
(
reg
,
fst_off
)
:
_
->
fst_off
size
=
snd
(
last
adj_reg_locs
)
+
1
doc
=
text
"Sp_adj("
<>
int
(
-
size
)
<>
text
");"
$$
saveRegOffs
adj_reg_locs
$$
loadSpWordOff
"W_"
0
<>
text
" = "
<>
mkApplyInfoName
rest_args
<>
semi
shuffle_extra_args
=
(
doc
,
(
shuffle_prof_stack
,
shuffle_norm_stack
))
where
doc
=
vcat
[
text
"#ifdef PROFILING"
,
shuffle_prof_doc
,
text
"#else"
,
shuffle
False
,
shuffle
_norm_doc
,
text
"#endif"
]
where
-- Sadly here we have to insert an stg_restore_cccs frame
-- just underneath the stg_ap_*_info frame if we're
-- profiling; see Note [jump_SAVE_CCCS]
shuffle
prof
=
let
offset
=
if
prof
then
2
else
0
in
vcat
(
map
(
shuffle_down
(
offset
+
1
))
[
sp_stk_args
..
sp_stk_args
+
stack_args_size
-
1
])
$$
(
if
prof
then
loadSpWordOff
"W_"
(
sp_stk_args
+
stack_args_size
-
3
)
<>
text
" = stg_restore_cccs_info;"
$$
loadSpWordOff
"W_"
(
sp_stk_args
+
stack_args_size
-
2
)
<>
text
" = CCCS;"
else
empty
)
$$
loadSpWordOff
"W_"
(
sp_stk_args
+
stack_args_size
-
1
)
<>
text
" = "
<>
mkApplyInfoName
rest_args
<>
semi
$$
text
"Sp_adj("
<>
int
(
sp_stk_args
-
1
-
offset
)
<>
text
");"
shuffle_down
j
i
=
loadSpWordOff
"W_"
(
i
-
j
)
<>
text
" = "
<>
loadSpWordOff
"W_"
i
<>
semi
(
shuffle_prof_doc
,
shuffle_prof_stack
)
=
shuffle
True
(
shuffle_norm_doc
,
shuffle_norm_stack
)
=
shuffle
False
-- Sadly here we have to insert an stg_restore_cccs frame
-- just underneath the stg_ap_*_info frame if we're
-- profiling; see Note [jump_SAVE_CCCS]
shuffle
prof
=
(
doc
,
-
sp_adj
)
where
sp_adj
=
sp_stk_args
-
1
-
offset
offset
=
if
prof
then
2
else
0
doc
=
vcat
(
map
(
shuffle_down
(
offset
+
1
))
[
sp_stk_args
..
sp_stk_args
+
stack_args_size
-
1
])
$$
(
if
prof
then
loadSpWordOff
"W_"
(
sp_stk_args
+
stack_args_size
-
3
)
<>
text
" = stg_restore_cccs_info;"
$$
loadSpWordOff
"W_"
(
sp_stk_args
+
stack_args_size
-
2
)
<>
text
" = CCCS;"
else
empty
)
$$
loadSpWordOff
"W_"
(
sp_stk_args
+
stack_args_size
-
1
)
<>
text
" = "
<>
mkApplyInfoName
rest_args
<>
semi
$$
text
"Sp_adj("
<>
int
sp_adj
<>
text
");"
shuffle_down
j
i
=
loadSpWordOff
"W_"
(
i
-
j
)
<>
text
" = "
<>
loadSpWordOff
"W_"
i
<>
semi
-- The EXACT ARITY case
...
...
@@ -378,7 +432,17 @@ genMkPAP regstatus macro jump live ticker disamb
-- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
-- }
larger_arity_case
=
(
larger_arity_doc
,
larger_arity_stack
)
=
(
doc
,
stack
)
where
-- offsets in case we need to save regs:
(
reg_locs
,
leftovers
,
sp_offset
)
=
assignRegs
regstatus
stk_args_slow_offset
args
-- BUILD_PAP assumes args start at offset 1
stack
|
args_in_regs
=
(
sp_offset
,
sp_offset
)
|
otherwise
=
(
0
,
0
)
doc
=
text
"} else {"
$$
let
save_regs
...
...
@@ -407,11 +471,7 @@ genMkPAP regstatus macro jump live ticker disamb
text
");"
])
$$
char
'}'
where
-- offsets in case we need to save regs:
(
reg_locs
,
leftovers
,
sp_offset
)
=
assignRegs
regstatus
stk_args_slow_offset
args
-- BUILD_PAP assumes args start at offset 1
-- Note [jump_SAVE_CCCS]
...
...
@@ -453,13 +513,14 @@ enterFastPathHelper :: Int
->
[
ArgRep
]
->
Doc
enterFastPathHelper
tag
regstatus
no_load_regs
args_in_regs
args
=
vcat
[
text
"if (GETTAG(R1)=="
<>
int
tag
<>
text
") {"
,
reg_doc
,
text
" Sp_adj("
<>
int
sp'
<>
text
");"
,
-- enter, but adjust offset with tag
text
" "
<>
mkJump
regstatus
(
text
"%GET_ENTRY(R1-"
<>
int
tag
<>
text
")"
)
[
"R1"
]
args
<>
semi
,
text
"}"
]
text
"if (GETTAG(R1)=="
<>
int
tag
<>
text
") {"
$$
nest
4
(
vcat
[
reg_doc
,
text
"Sp_adj("
<>
int
sp'
<>
text
");"
,
-- enter, but adjust offset with tag
mkJump
regstatus
(
text
"%GET_ENTRY(R1-"
<>
int
tag
<>
text
")"
)
[
"R1"
]
args
<>
semi
])
$$
text
"}"
-- I don't totally understand this code, I copied it from
-- exact_arity_case
-- TODO: refactor
...
...
@@ -519,6 +580,23 @@ genApply regstatus args =
fun_ret_label
=
mkApplyRetName
args
fun_info_label
=
mkApplyInfoName
args
all_args_size
=
sum
(
map
argSize
args
)
(
bco_doc
,
bco_stack
)
=
genMkPAP
regstatus
"BUILD_PAP"
"ENTRY_LBL(stg_BCO)"
[
"R1"
]
"FUN"
"BCO"
True
{-stack apply-}
False
{-args on stack-}
False
{-not a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
False
(
fun_doc
,
fun_stack
)
=
genMkPAP
regstatus
"BUILD_PAP"
"%GET_ENTRY(UNTAG(R1))"
[
"R1"
]
"FUN"
"FUN"
False
{-reg apply-}
False
{-args on stack-}
False
{-not a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
True
(
pap_doc
,
pap_stack
)
=
genMkPAP
regstatus
"NEW_PAP"
"stg_PAP_apply"
[
"R1"
,
"R2"
]
"PAP"
"PAP"
True
{-stack apply-}
False
{-args on stack-}
True
{-is a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
False
stack_usage
=
maxStack
[
bco_stack
,
fun_stack
,
pap_stack
]
in
vcat
[
text
"INFO_TABLE_RET("
<>
mkApplyName
args
<>
text
", "
<>
...
...
@@ -579,6 +657,9 @@ genApply regstatus args =
-- if pointer is tagged enter it fast!
enterFastPath
regstatus
False
False
args
,
stackCheck
regstatus
args
False
{-args on stack-}
fun_info_label
stack_usage
,
-- Functions can be tagged, so we untag them!
text
"R1 = UNTAG(R1);"
,
text
"info = %INFO_PTR(R1);"
,
...
...
@@ -596,9 +677,7 @@ genApply regstatus args =
nest
4
(
vcat
[
text
"arity = TO_W_(StgBCO_arity(R1));"
,
text
"ASSERT(arity > 0);"
,
genMkPAP
regstatus
"BUILD_PAP"
"ENTRY_LBL(stg_BCO)"
[
"R1"
]
"FUN"
"BCO"
True
{-stack apply-}
False
{-args on stack-}
False
{-not a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
False
bco_doc
]),
text
"}"
,
...
...
@@ -615,9 +694,7 @@ genApply regstatus args =
nest
4
(
vcat
[
text
"arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));"
,
text
"ASSERT(arity > 0);"
,
genMkPAP
regstatus
"BUILD_PAP"
"%GET_ENTRY(UNTAG(R1))"
[
"R1"
]
"FUN"
"FUN"
False
{-reg apply-}
False
{-args on stack-}
False
{-not a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
True
fun_doc
]),
text
"}"
,
...
...
@@ -629,9 +706,7 @@ genApply regstatus args =
nest
4
(
vcat
[
text
"arity = TO_W_(StgPAP_arity(R1));"
,
text
"ASSERT(arity > 0);"
,
genMkPAP
regstatus
"NEW_PAP"
"stg_PAP_apply"
[
"R1"
,
"R2"
]
"PAP"
"PAP"
True
{-stack apply-}
False
{-args on stack-}
True
{-is a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
False
pap_doc
]),
text
"}"
,
...
...
@@ -690,6 +765,7 @@ genApply regstatus args =
]),
text
"}"
]),
text
"}"
]
...
...
@@ -702,6 +778,15 @@ genApplyFast regstatus args =
fun_ret_label
=
text
"RET_LBL"
<>
parens
(
mkApplyName
args
)
fun_info_label
=
mkApplyInfoName
args
all_args_size
=
sum
(
map
argSize
args
)
(
fun_doc
,
fun_stack
)
=
genMkPAP
regstatus
"BUILD_PAP"
"%GET_ENTRY(UNTAG(R1))"
[
"R1"
]
"FUN"
"FUN"
False
{-reg apply-}
True
{-args in regs-}
False
{-not a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
True
(
reg_locs
,
leftovers
,
sp_offset
)
=
assignRegs
regstatus
1
args
stack_usage
=
maxStack
[
fun_stack
,
(
sp_offset
,
sp_offset
)]
in
vcat
[
fun_fast_label
,
...
...
@@ -715,6 +800,9 @@ genApplyFast regstatus args =
-- if pointer is tagged enter it fast!
enterFastPath
regstatus
False
True
args
,
stackCheck
regstatus
args
True
{-args in regs-}
fun_info_label
stack_usage
,
-- Functions can be tagged, so we untag them!
text
"R1 = UNTAG(R1);"
,
text
"info = %GET_STD_INFO(R1);"
,
...
...
@@ -730,18 +818,11 @@ genApplyFast regstatus args =
nest
4
(
vcat
[
text
"arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));"
,
text
"ASSERT(arity > 0);"
,
genMkPAP
regstatus
"BUILD_PAP"
"%GET_ENTRY(UNTAG(R1))"
[
"R1"
]
"FUN"
"FUN"
False
{-reg apply-}
True
{-args in regs-}
False
{-not a PAP-}
args
all_args_size
fun_info_label
{- tag stmt -}
True
fun_doc
]),
char
'}'
,
text
"default: {"
,
let
(
reg_locs
,
leftovers
,
sp_offset
)
=
assignRegs
regstatus
1
args
-- leave a one-word space on the top of the stack when
-- calling the slow version
in
nest
4
(
vcat
[
text
"Sp_adj"
<>
parens
(
int
(
-
sp_offset
))
<>
semi
,
saveRegOffs
reg_locs
,
...
...
@@ -749,8 +830,9 @@ genApplyFast regstatus args =
]),
char
'}'
]),
char
'}'
]),
char
'}'
]),
char
'}'
]
...
...
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