Works better with patch attached...
Am 13.12.21 um 21:25 schrieb Harald Anlauf via Gcc-patches:
Hi Mikael,
Am 09.12.21 um 21:37 schrieb Mikael Morin:
Hello,
On 09/12/2021 21:05, Harald Anlauf via Fortran wrote:
Dear all,
I had thought that we had fixed this in the past (see PR31001),
but it did fail for me with all gcc versions I have tried (7-12)
for a slightly more elaborate case as in the old testcase.
The loop in pack_internal did try to access the first element of
the array argument to PACK even if one (or more) extents were zero.
This is not good.
Solution: check the extents and return early. (We already do a
related check for the vector argument if present).
If there is a vector argument, aren’t we supposed to copy it to the
result ?
There is something else to pay attention for, the early return should
come at least after the return array bounds have been set. In the
testcase an array with the correct bounds has been allocated beforehand
to hold the return value, but it’s not always the case.
you are absolutely right, I had gotten that wrong.
For what it’s worth, the non-generic variant in pack.m4 (or in
pack_{i,f,c}{1,2,4,8,10,16}.c) has a zero extent check and it clears the
source ptr in that case, which makes it setup the return array and then
jump to the vector copy at the end of the function.
The code is so similar (for good reason) that it makes sense to keep
it synchronous. I added code for 'zero_sized' array with the minor
difference that I made it boolean instead of integer.
I also extended the testcase so that it exercises PACK/pack_internal
a little, for argument 'vector' present as well as not. (There are
existing tests for intrinsic types, but not for the issue at hand).
Regtested again, and checked the testcase (against other compilers
and also with valgrind).
OK now?
Thanks,
Harald
From f6879cdcc1de83c86eb47bfae33d06fd00f51a99 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Mon, 13 Dec 2021 20:50:19 +0100
Subject: [PATCH] Fortran: PACK intrinsic should not try to read from
zero-sized array
libgfortran/ChangeLog:
PR libfortran/103634
* intrinsics/pack_generic.c (pack_internal): Handle case when the
array argument of PACK has one or more extents of size zero to
avoid invalid reads.
gcc/testsuite/ChangeLog:
PR libfortran/103634
* gfortran.dg/intrinsic_pack_6.f90: New test.
---
.../gfortran.dg/intrinsic_pack_6.f90 | 57 +++++++++++++++++++
libgfortran/intrinsics/pack_generic.c | 9 +++
2 files changed, 66 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90 b/gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90
new file mode 100644
index 00000000000..917944d8846
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_pack_6.f90
@@ -0,0 +1,57 @@
+! { dg-do run }
+! PR libfortran/103634 - Runtime crash with PACK on zero-sized arrays
+! Exercise PACK intrinsic for cases when it calls pack_internal
+
+program p
+ implicit none
+ type t
+ real :: r(24) = -99.
+ end type
+ type(t), allocatable :: new(:), old(:), vec(:)
+ logical, allocatable :: mask(:)
+ integer :: n, m
+! m = 1 ! works
+ m = 0 ! failed with SIGSEGV in pack_internal
+ do m = 0, 2
+ print *, m
+ allocate (old(m), mask(m), vec(m))
+ if (m > 0) vec(m)% r(1) = 42
+ mask(:) = .true.
+ n = count (mask)
+ allocate (new(n))
+
+ mask(:) = .false.
+ if (size (pack (old, mask)) /= 0) stop 1
+ mask(:) = .true.
+ if (size (pack (old, mask)) /= m) stop 2
+ new(:) = pack (old, mask) ! this used to segfault for m=0
+
+ mask(:) = .false.
+ if (size (pack (old, mask, vector=vec)) /= m) stop 3
+ new(:) = t()
+ new(:) = pack (old, mask, vector=vec) ! this used to segfault for m=0
+ if (m > 0) then
+ if ( new( m )% r(1) /= 42) stop 4
+ if (any (new(:m-1)% r(1) /= -99)) stop 5
+ end if
+
+ if (m > 0) mask(m) = .true.
+ if (size (pack (old, mask, vector=vec)) /= m) stop 6
+ new(:) = t()
+ new(:) = pack (old, mask, vector=vec) ! this used to segfault for m=0
+ if (m > 0) then
+ if (new(1)% r(1) /= -99) stop 7
+ end if
+ if (m > 1) then
+ if (new(m)% r(1) /= 42) stop 8
+ end if
+
+ if (size (pack (old(:0), mask(:0), vector=vec)) /= m) stop 9
+ new(:) = t()
+ new(:) = pack (old(:0), mask(:0), vector=vec) ! did segfault for m=0
+ if (m > 0) then
+ if (new(m)% r(1) /= 42) stop 10
+ end if
+ deallocate (old, mask, new, vec)
+ end do
+end
diff --git a/libgfortran/intrinsics/pack_generic.c b/libgfortran/intrinsics/pack_generic.c
index cad2fbbfbcd..15880e74348 100644
--- a/libgfortran/intrinsics/pack_generic.c
+++ b/libgfortran/intrinsics/pack_generic.c
@@ -85,6 +85,7 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
+ bool zero_sized;
index_type n;
index_type dim;
index_type nelem;
@@ -114,10 +115,13 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
else
runtime_error ("Funny sized logical array");
+ zero_sized = false;
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
+ if (extent[n] <= 0)
+ zero_sized = true;
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
}
@@ -126,6 +130,11 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
if (mstride[0] == 0)
mstride[0] = mask_kind;
+ if (zero_sized)
+ sptr = NULL;
+ else
+ sptr = array->base_addr;
+
if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
{
/* Count the elements, either for allocating memory or
--
2.26.2
