Perl · tonycoz · Apr 14, 2024 · Apr 9, 2024
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -387,7 +387,7 @@ Does not use C<TARG>.  See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>.
 /* 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
@@ -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
@@ -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
@@ -15149,7 +15149,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