diff --git a/cop.h b/cop.h index 10f854ed7280..0de251b6e71a 100644 --- a/cop.h +++ b/cop.h @@ -44,7 +44,7 @@ MSVC_DIAG_RESTORE typedef struct jmpenv JMPENV; -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#if defined PERL_USE_HWM # define JE_OLD_STACK_HWM_zero PL_start_env.je_old_stack_hwm = 0 # define JE_OLD_STACK_HWM_save(je) \ (je).je_old_stack_hwm = PL_curstackinfo->si_stack_hwm @@ -1271,7 +1271,7 @@ struct stackinfo { I32 si_stack_nonrc_base; #endif -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM /* high water mark: for checking if the stack was correctly extended / * tested for extension by each pp function */ SSize_t si_stack_hwm; @@ -1298,7 +1298,7 @@ typedef struct stackinfo PERL_SI; # define SET_MARK_OFFSET NOOP #endif -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM # define PUSHSTACK_INIT_HWM(si) ((si)->si_stack_hwm = 0) #else # define PUSHSTACK_INIT_HWM(si) NOOP diff --git a/dump.c b/dump.c index 969f92534372..f6c0d32f301d 100644 --- a/dump.c +++ b/dump.c @@ -2808,7 +2808,7 @@ Perl_hv_dump(pTHX_ HV *hv) int Perl_runops_debug(pTHX) { -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm; PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; @@ -2829,7 +2829,7 @@ Perl_runops_debug(pTHX) #ifdef PERL_TRACE_OPS ++PL_op_exec_cnt[PL_op->op_type]; #endif -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base) Perl_croak_nocontext( "panic: previous op failed to extend arg stack: " @@ -2867,7 +2867,7 @@ Perl_runops_debug(pTHX) DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); PERL_ASYNC_CHECK(); -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm) PL_curstackinfo->si_stack_hwm = orig_stack_hwm; #endif diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 3e7ed04772e3..763b20731696 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp; -our $VERSION = '1.35'; +our $VERSION = '1.36'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index eb9f5e819912..4034312c8dd1 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1601,6 +1601,12 @@ destruct_test(pTHX_ void *p) { warn("In destruct_test: %" SVf "\n", (SV*)p); } +#ifdef PERL_USE_HWM +# define hwm_checks_enabled() true +#else +# define hwm_checks_enabled() false +#endif + MODULE = XS::APItest PACKAGE = XS::APItest INCLUDE: const-xs.inc @@ -2670,6 +2676,17 @@ PPCODE: *PL_stack_max = NULL; +void +bad_EXTEND() + PPCODE: + /* testing failure to extend the stack, do not extend the stack */ + PUSHs(&PL_sv_yes); + PUSHs(&PL_sv_no); + XSRETURN(2); + +bool +hwm_checks_enabled() + void call_sv_C() PREINIT: diff --git a/ext/XS-APItest/t/extend.t b/ext/XS-APItest/t/extend.t index b3834b4cd740..7ebdfb036456 100644 --- a/ext/XS-APItest/t/extend.t +++ b/ext/XS-APItest/t/extend.t @@ -13,9 +13,9 @@ use Test::More; use Config; -use XS::APItest qw(test_EXTEND); +use XS::APItest qw(test_EXTEND hwm_checks_enabled bad_EXTEND); -plan tests => 48; +plan tests => 50; my $uvsize = $Config::Config{uvsize}; # sizeof(UV) my $sizesize = $Config::Config{sizesize}; # sizeof(Size_t) @@ -66,3 +66,15 @@ for my $offset (-1, 0, 1) { } } } + +SKIP: +{ + # we've extended the stack a fair bit above so the actual bad_EXTEND*() should + # be safe in terms of UB *here* + skip "HWM checks not enabled", 2 + unless hwm_checks_enabled(); + + ok(!eval { bad_EXTEND(); 1 }, "bad_EXTEND() should throw"); + like($@, qr/^panic: XSUB XS::APItest::bad_EXTEND \(APItest\.c\) failed to extend arg stack/, + "check panic message"); +} diff --git a/op.c b/op.c index ffc071075be5..7d5db41b5822 100644 --- a/op.c +++ b/op.c @@ -5146,7 +5146,7 @@ S_gen_constant_list(pTHX_ OP *o) switch (ret) { case 0: -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */ #endif Perl_pp_pushmark(aTHX); diff --git a/perl.c b/perl.c index 825628159028..0f1872dd177b 100644 --- a/perl.c +++ b/perl.c @@ -4514,7 +4514,7 @@ Perl_init_stacks(pTHX) REASONABLE(8192/sizeof(PERL_CONTEXT) - 1), make_real); PL_curstackinfo->si_type = PERLSI_MAIN; -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM PL_curstackinfo->si_stack_hwm = 0; #endif PL_curstack = PL_curstackinfo->si_stack; diff --git a/perl.h b/perl.h index 8ab0f73c1f72..11e5bacef9d1 100644 --- a/perl.h +++ b/perl.h @@ -1087,6 +1087,26 @@ violations are fatal. */ #define PERL_USE_SAFE_PUTENV +/* Control whether we set and test the stack high water mark. + * + * When enabled this checks that pp funcs and XSUBs properly EXTEND() + * the stack. + * + * Debugging builds have HWM checks on by default, you can add + * -DPERL_NO_HWM to ccflags to prevent those checks, or add + * -DPERL_USE_HWM to ccflags to perform HWM checks even on + * non-debugging builds. + */ + +#if defined PERL_NO_HWM +# undef PERL_USE_HWM +#elif defined PERL_USE_HWM +/* nothing to do here */ +#elif defined DEBUGGING && !defined DEBUGGING_RE_ONLY +# define PERL_USE_HWM +#endif + + /* HP-UX 10.X CMA (Common Multithreaded Architecture) insists that pthread.h must be included before all other header files. */ @@ -5204,7 +5224,7 @@ typedef Sighandler_t Sigsave_t; #define SCAN_TR 1 #define SCAN_REPL 2 -#ifdef DEBUGGING +#if defined DEBUGGING || defined PERL_USE_HWM # ifndef register # define register # endif diff --git a/pp.h b/pp.h index 866c01e1e3e2..2f34e0d38296 100644 --- a/pp.h +++ b/pp.h @@ -387,7 +387,7 @@ Does not use C. See also C>, C> and C>. /* EXTEND_HWM_SET: note the high-water-mark to which the stack has been * requested to be extended (which is likely to be less than PL_stack_max) */ -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM # define EXTEND_HWM_SET(p, n) \ STMT_START { \ SSize_t extend_hwm_set_ix = (p) - PL_stack_base + (n); \ diff --git a/pp_hot.c b/pp_hot.c index a404363a8202..887c76f20285 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -6494,7 +6494,7 @@ PP(pp_entersub) rpp_invoke_xs(cv); -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM /* This duplicates the check done in runops_debug(), but provides more * information in the common case of the fault being with an XSUB. * diff --git a/scope.c b/scope.c index 3ab3b4a47844..a65a9fd551a3 100644 --- a/scope.c +++ b/scope.c @@ -56,7 +56,7 @@ Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) Perl_croak(aTHX_ "Out of memory during stack extend"); av_extend(PL_curstack, current + n + extra); -#ifdef DEBUGGING +#ifdef PERL_USE_HWM PL_curstackinfo->si_stack_hwm = current + n + extra; #endif diff --git a/sv.c b/sv.c index ee7ed080f8b5..0b3d142e85e4 100644 --- a/sv.c +++ b/sv.c @@ -15159,7 +15159,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) #ifdef PERL_RC_STACK nsi->si_stack_nonrc_base = si->si_stack_nonrc_base; #endif -#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY +#ifdef PERL_USE_HWM nsi->si_stack_hwm = 0; #endif