Commit fc0ed8a7 authored by Simon Marlow's avatar Simon Marlow
Browse files

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