Commit fc0ed8a7 authored by Simon Marlow's avatar Simon Marlow

Add missing stack checks to stg_ap_* functions (#9001)

parent 88c0870b
{-# 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
......@@ -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, [''])
......@@ -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 '}'
]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment