make EXTEND() and stack_grow() safe(r)

This commit fixes various issues around stack_grow() and its
two main wrappers, EXTEND() and MEXTEND(). In particular it behaves
very badly on systems with 32-bit pointers but 64-bit ints.

One noticeable effect of this is commit is that various usages of EXTEND()
etc will now start to give compiler warnings - usually because they're
passing an unsigned N arg when it should be signed. This may indicate
a logic error in the caller's code which needs fixing. This commit causes
several such warnings to appear in core code, which will be fixed in the
next commit.

Essentially there are several potential false negatives in this basic
code:

     if (PL_stack_max - p < (SSize_t)(n))
        stack_grow(sp,p,(SSize_t)(n));

where it incorrectly skips the call to stack_grow() and then the caller
tramples over the end of the stack because it assumes that it has in fact
been extended. The value of N passed to stack_grow() can also potentially
get truncated or wrapped.

Note that the N arg of stack_grow() is SSize_t and EXTEND()'s N arg is
documented as SSize_t.  In earlier times, they were both ints.
Significantly, this means that they are both signed, and always have been.

In detail, the problems and their solutions are:

1) N is a signed value: if negative, it could be an indication of a
    caller's invalid logic or wrapping in the caller's code. This should
    trigger a panic. Make it so by adding an extra test to EXTEND() to
    always call stack_grow if negative, then add a check and panic in
    stack_grow() (and other places too). This extra test will be constant
    folded when EXTEND() is called with a literal N.

2) If the caller passes an unsigned value of N, then the comparison is
    between a signed and an unsigned value, leading to potential
    wrap-around. Casting N to SSize_t merely hides any compiler warnings,
    thus failing to alert the caller to a problem with their code. In
    addition, where sizeof(N) > sizeof(SSize_t), the cast may truncate N,
    again leading to false negatives. The solution is to remove the cast,
    and let the caller deal with any compiler warnings that result.

3) Similarly, casting stack_grow()'s N arg can hide any warnings issued by
    e.g. -Wconversion. So remove it.  It still does the wrong thing if the
    caller uses a non-signed type (usually a panic in stack_grow()), but
    coders have slightly more chance of spotting issues at compile time
    now.

4) If sizeof(N) > sizeof(SSize_t), then the N arg to stack_grow() may get
   truncated or sign-swapped. Add a test for this (basically that N is too
   big to fit in a SSize_t); for simplicity, in this case just set N to
   -1 so that stack_grow() panics shortly afterwards. In platforms where
   this can't happen, the test is constant folded away.

With all these changes, the macro now looks in essence like:

     if ( n < 0 || PL_stack_max - p < n)
        stack_grow(sp,p,
            (sizeof(n) > sizeof(SSize_t) && ((SSize_t)(n) != n) ? -1 : n));

7 files changed, 151 insertions, 10 deletions

diff --git a/MANIFEST b/MANIFEST
index 7ae4148fc1..864dd4a0df 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/av.c b/av.c
index cb99ceb29b..2c4740b621 100644
--- a/av.c
+++ b/av.c
@@ -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)";
+
+
+        }
+    }
+}
diff --git a/pp.h b/pp.h
index 2d99a7242d..b497085a35 100644
--- a/pp.h
+++ b/pp.h
@@ -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
diff --git a/pp_hot.c b/pp_hot.c
index 840d131a97..66e8b9d9d3 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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;
diff --git a/scope.c b/scope.c
index 9768c30734..1b891861de 100644
--- a/scope.c
+++ b/scope.c
@@ -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);