diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | av.c | 4 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 33 | ||||
| -rw-r--r-- | ext/XS-APItest/t/extend.t | 68 | ||||
| -rw-r--r-- | pp.h | 47 | ||||
| -rw-r--r-- | pp_hot.c | 4 | ||||
| -rw-r--r-- | scope.c | 4 |
7 files changed, 151 insertions, 10 deletions
@@ -3933,6 +3933,7 @@ ext/XS-APItest/t/customop.t XS::APItest: tests for custom ops ext/XS-APItest/t/cv_name.t test cv_name ext/XS-APItest/t/eval-filter.t Simple source filter/eval test ext/XS-APItest/t/exception.t XS::APItest extension +ext/XS-APItest/t/extend.t test EXTEND() macro ext/XS-APItest/t/fetch_pad_names.t Tests for UTF8 names in pad ext/XS-APItest/t/gotosub.t XS::APItest: tests goto &xsub and hints ext/XS-APItest/t/grok.t XS::APItest: tests for grok* functions @@ -87,6 +87,10 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, { PERL_ARGS_ASSERT_AV_EXTEND_GUTS; + if (key < -1) /* -1 is legal */ + Perl_croak(aTHX_ + "panic: av_extend_guts() negative count (%"IVdf")", (IV)key); + if (key > *maxp) { SV** ary; SSize_t tmp; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4002fc07f1..7bb7cebf33 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -2137,6 +2137,39 @@ mxpushu() mXPUSHu(3); XSRETURN(3); + + # test_EXTEND(): excerise the EXTEND() macro. + # After calling EXTEND(), it also does *(p+n) = NULL and + # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't + # actually been extended properly. + # + # max_offset specifies the SP to use. It is treated as a signed offset + # from PL_stack_max. + # nsv is the SV holding the value of n indicating how many slots + # to extend the stack by. + # use_ss is a boolean indicating that n should be cast to a SSize_t + +void +test_EXTEND(max_offset, nsv, use_ss) + IV max_offset; + SV *nsv; + bool use_ss; +PREINIT: + SV **sp = PL_stack_max + max_offset; +PPCODE: + if (use_ss) { + SSize_t n = (SSize_t)SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + else { + IV n = SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + *PL_stack_max = NULL; + + void call_sv_C() PREINIT: diff --git a/ext/XS-APItest/t/extend.t b/ext/XS-APItest/t/extend.t new file mode 100644 index 0000000000..b3834b4cd7 --- /dev/null +++ b/ext/XS-APItest/t/extend.t @@ -0,0 +1,68 @@ +#!perl +# +# Test stack expansion macros: EXTEND() etc, especially for edge cases +# where the count wraps to a native value or gets truncated. +# +# Some of these tests aren't really testing; they are however exercising +# edge cases, which other tools like ASAN may then detect problems with. +# In particular, test_EXTEND() does *(p+n) = NULL and *PL_stack_max = NULL +# before returning, to help such tools spot errors. +# +# Also, it doesn't test large but legal grow requests; only ridiculously +# large requests that are guaranteed to wrap. + +use Test::More; +use Config; +use XS::APItest qw(test_EXTEND); + +plan tests => 48; + +my $uvsize = $Config::Config{uvsize}; # sizeof(UV) +my $sizesize = $Config::Config{sizesize}; # sizeof(Size_t) + +# The first arg to test_EXTEND() is the SP to use in EXTEND(), treated +# as an offset from PL_stack_max. So extend(-1, 1, $use_ss) shouldn't +# call Perl_stack_grow(), while extend(-1, 2, $use_ss) should. +# Exercise offsets near to PL_stack_max to detect edge cases. +# Note that having the SP pointer beyond PL_stack_max is legal. + +for my $offset (-1, 0, 1) { + + # treat N as either an IV or a SSize_t + for my $use_ss (0, 1) { + + # test with N in range -1 .. 3; only the -1 should panic + + eval { test_EXTEND($offset, -1, $use_ss) }; + like $@, qr/panic: .*negative count/, "test_EXTEND($offset, -1, $use_ss)"; + + for my $n (0,1,2,3) { + eval { test_EXTEND($offset, $n, $use_ss) }; + is $@, "", "test_EXTEND($offset, $n, $use_ss)"; + } + + # some things can wrap if the int size is greater than the ptr size + + SKIP: { + skip "Not small ptrs", 3 if $use_ss || $uvsize <= $sizesize; + + # 0xffff... wraps to -1 + eval { test_EXTEND($offset, (1 << 8*$sizesize)-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX, $use_ss)"; + + # 0x10000... truncates to zero; + # but the wrap-detection code converts it to -1 to force a panic + eval { test_EXTEND($offset, 1 << 8*$sizesize, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX+1, $use_ss)"; + + # 0x1ffff... truncates and then wraps to -1 + eval { test_EXTEND($offset, (1 << (8*$sizesize+1))-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, 2*SIZE_MAX-1, $use_ss)"; + + + } + } +} @@ -283,29 +283,58 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. =cut */ +/* _EXTEND_SAFE_N(n): private helper macro for EXTEND(). + * Tests whether the value of n would be truncated when implicitly cast to + * SSize_t as an arg to stack_grow(). If so, sets it to -1 instead to + * trigger a panic. It will be constant folded on platforms where this + * can't happen. + */ + +#define _EXTEND_SAFE_N(n) \ + (sizeof(n) > sizeof(SSize_t) && ((SSize_t)(n) != (n)) ? -1 : (n)) + #ifdef STRESS_REALLOC # define EXTEND(p,n) STMT_START { \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ PERL_UNUSED_VAR(sp); \ } STMT_END /* Same thing, but update mark register too. */ # define MEXTEND(p,n) STMT_START { \ const SSize_t markoff = mark - PL_stack_base; \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ mark = PL_stack_base + markoff; \ PERL_UNUSED_VAR(sp); \ } STMT_END #else -# define EXTEND(p,n) STMT_START { \ - if (UNLIKELY(PL_stack_max - p < (SSize_t)(n))) { \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + +/* _EXTEND_NEEDS_GROW(p,n): private helper macro for EXTEND(). + * Tests to see whether n is too big and we need to grow the stack. Be + * very careful if modifying this. There are many ways to get things wrong + * (wrapping, truncating etc) that could cause a false negative and cause + * the call to stack_grow() to be skipped. On the other hand, false + * positives are safe. + * Bear in mind that sizeof(p) may be less than, equal to, or greater + * than sizeof(n), and while n is documented to be signed, someone might + * pass an unsigned value or expression. In general don't use casts to + * avoid warnings; instead expect the caller to fix their code. + * It is legal for p to be greater than PL_stack_max. + * If the allocated stack is already very large but current usage is + * small, then PL_stack_max - p might wrap round to a negative value, but + * this just gives a safe false positive + */ + +# define _EXTEND_NEEDS_GROW(p,n) ( (n) < 0 || PL_stack_max - p < (n)) + +# define EXTEND(p,n) STMT_START { \ + if (UNLIKELY(_EXTEND_NEEDS_GROW(p,n))) { \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ PERL_UNUSED_VAR(sp); \ } } STMT_END /* Same thing, but update mark register too. */ -# define MEXTEND(p,n) STMT_START { \ - if (UNLIKELY(PL_stack_max - p < (SSize_t)(n))) { \ - const SSize_t markoff = mark - PL_stack_base; \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ +# define MEXTEND(p,n) STMT_START { \ + if (UNLIKELY(_EXTEND_NEEDS_GROW(p,n))) { \ + const SSize_t markoff = mark - PL_stack_base;\ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ mark = PL_stack_base + markoff; \ PERL_UNUSED_VAR(sp); \ } } STMT_END @@ -1275,7 +1275,9 @@ PP(pp_aassign) } av_clear(ary); - av_extend(ary, lastrelem - relem); + if (relem <= lastrelem) + av_extend(ary, lastrelem - relem); + i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; @@ -31,6 +31,10 @@ Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) { PERL_ARGS_ASSERT_STACK_GROW; + if (n < 0) + Perl_croak(aTHX_ + "panic: stack_grow() negative count (%"IVdf")", (IV)n); + PL_stack_sp = sp; #ifndef STRESS_REALLOC av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128); |