Hi Harald, Thanks for the review. The attached resubmission fixes all the invalid accesses, memory leaks and puts right the incorrect result.
In the course of fixing the fix, I found that deferred character length MOLDs gave an ICE because reallocation on assign was using 'dest_word_len' before it was defined. This is fixed by not fixing 'dest_word_len' for these MOLDs. Unfortunately, the same did not work for unlimited polymorphic MOLD expressions and so I added a TODO error in iresolve.cc since it results in all manner of memory errors in runtime. I will return to this another day. A resubmission of the patch for PR113363 will follow since it depends on this one to fix all the memory problems. OK for mainline? Regards Paul On Thu, 9 May 2024 at 08:52, Paul Richard Thomas < paul.richard.tho...@gmail.com> wrote: > Hi Harald, > > The Linaro people caught that as well. Thanks. > > Interestingly, I was about to re-submit the patch for PR113363, in which > all the invalid accesses and memory leaks are fixed but requires this patch > to do so. The final transfer was thrown in because it seemed to be working > out of the box but should be checked anyway. > > Inserting your print statements, my test shows the difference in > size(chr_a) but prints chr_a as "abcdefgjj" no matter what I do. Needless > to say, the latter was the only check that I did. The problem, I suspect, > lies somewhere in the murky depths of > trans-array.cc(gfc_alloc_allocatable_for_assignment) or in the array part > of intrinsic_transfer, untouched by either patch, and is present in 13- and > 14-branches. > > I am onto it. > > Cheers > > Paul > > > On Wed, 8 May 2024 at 22:06, Harald Anlauf <anl...@gmx.de> wrote: > >> Hi Paul, >> >> this looks mostly good, but the new testcase transfer_class_4.f90 >> does exhibit a problem with your patch. Run it with valgrind, >> or with -fcheck=bounds, or with -fsanitize=address, or add the >> following around the final transfer: >> >> print *, storage_size (star_a), storage_size (chr_a), size (chr_a), len >> (chr_a) >> chr_a = transfer (star_a, chr_a) >> print *, storage_size (star_a), storage_size (chr_a), size (chr_a), len >> (chr_a) >> print *, ">", chr_a, "<" >> >> This prints for me: >> >> 40 40 2 5$ >> 40 40 4 5$ >> >abcdefghij^@^@^@^@^@^@^@^@^@^@<$ >> >> So since the physical representation of chr_a is sufficient >> to hold star_a (F2023:16.9.212), no reallocation with a wrong >> calculated size should happen. (Intel and NAG get this right.) >> >> Can you check again? >> >> Thanks, >> Harald >> >> >>
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index c961cdbc2df..c63a4a8d38c 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3025,6 +3025,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
}
}
+ if (UNLIMITED_POLY (mold))
+ gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
+ &mold->where);
+
f->ts = mold->ts;
if (size == NULL && mold->rank == 0)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index bc8eb419cff..4590aa6edb4 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
size = gfc_evaluate_now (size, block);
tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
}
+ else
+ tmp = fold_convert (type , tmp);
tmp2 = fold_build2_loc (input_location, MULT_EXPR,
type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
@@ -11994,15 +11996,24 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
/* Take into account _len of unlimited polymorphic entities.
TODO: handle class(*) allocatable function results on rhs. */
- if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE)
+ if (UNLIMITED_POLY (rhs))
{
- tree len = trans_get_upoly_len (block, rhs);
+ tree len;
+ if (rhs->expr_type == EXPR_VARIABLE)
+ len = trans_get_upoly_len (block, rhs);
+ else
+ len = gfc_class_len_get (tmp);
len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
fold_convert (size_type_node, len),
size_one_node);
size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
size, fold_convert (TREE_TYPE (size), len));
}
+ else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_charlen_type_node, size,
+ rse->string_length);
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 83041183fcb..80dc3426ab0 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -8250,7 +8250,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
gfc_expr *arg;
gfc_se argse;
- tree type, result_type, tmp;
+ tree type, result_type, tmp, class_decl = NULL;
+ gfc_symbol *sym;
+ bool unlimited = false;
arg = expr->value.function.actual->expr;
@@ -8261,10 +8263,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
if (arg->ts.type == BT_CLASS)
{
+ unlimited = UNLIMITED_POLY (arg);
gfc_add_vptr_component (arg);
gfc_add_size_component (arg);
gfc_conv_expr (&argse, arg);
tmp = fold_convert (result_type, argse.expr);
+ class_decl = gfc_get_class_from_expr (argse.expr);
goto done;
}
@@ -8276,14 +8280,20 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg);
+ sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
if (arg->ts.type == BT_CLASS)
{
- if (arg->rank > 0)
+ unlimited = UNLIMITED_POLY (arg);
+ if (TREE_CODE (argse.expr) == COMPONENT_REF)
+ tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
+ else if (arg->rank > 0 && sym
+ && DECL_LANG_SPECIFIC (sym->backend_decl))
tmp = gfc_class_vtab_size_get (
- GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
+ GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
else
- tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
+ gcc_unreachable ();
tmp = fold_convert (result_type, tmp);
+ class_decl = gfc_get_class_from_expr (argse.expr);
goto done;
}
type = gfc_get_element_type (TREE_TYPE (argse.expr));
@@ -8297,6 +8307,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
tmp = fold_convert (result_type, tmp);
done:
+ if (unlimited && class_decl)
+ tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
+
se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
build_int_cst (result_type, BITS_PER_UNIT));
gfc_add_block_to_block (&se->pre, &argse.pre);
@@ -8419,7 +8432,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- source = gfc_class_data_get (tmp);
+ {
+ source = gfc_class_data_get (tmp);
+ class_ref = tmp;
+ }
else
{
/* Array elements are evaluated as a reference to the data.
@@ -8446,9 +8462,17 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
break;
case BT_CLASS:
if (class_ref != NULL_TREE)
- tmp = gfc_class_vtab_size_get (class_ref);
+ {
+ tmp = gfc_class_vtab_size_get (class_ref);
+ if (UNLIMITED_POLY (source_expr))
+ tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
+ }
else
- tmp = gfc_class_vtab_size_get (argse.expr);
+ {
+ tmp = gfc_class_vtab_size_get (argse.expr);
+ if (UNLIMITED_POLY (source_expr))
+ tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
+ }
break;
default:
source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
@@ -8501,6 +8525,13 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
if (arg->expr->ts.type == BT_CHARACTER)
tmp = size_of_string_in_bytes (arg->expr->ts.kind,
argse.string_length);
+ else if (arg->expr->ts.type == BT_CLASS)
+ {
+ class_ref = TREE_OPERAND (argse.expr, 0);
+ tmp = gfc_class_vtab_size_get (class_ref);
+ if (UNLIMITED_POLY (arg->expr))
+ tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
+ }
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (source_type));
@@ -8541,15 +8572,14 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
if (arg->expr->rank == 0)
{
- gfc_conv_expr_reference (&argse, arg->expr);
+ gfc_conv_expr_reference (&argse, mold_expr);
mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
argse.expr));
}
else
{
- gfc_init_se (&argse, NULL);
argse.want_pointer = 0;
- gfc_conv_expr_descriptor (&argse, arg->expr);
+ gfc_conv_expr_descriptor (&argse, mold_expr);
mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
@@ -8560,27 +8590,41 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
/* If this TRANSFER is nested in another TRANSFER, use a type
that preserves all bits. */
- if (arg->expr->ts.type == BT_LOGICAL)
- mold_type = gfc_get_int_type (arg->expr->ts.kind);
+ if (mold_expr->ts.type == BT_LOGICAL)
+ mold_type = gfc_get_int_type (mold_expr->ts.kind);
}
/* Obtain the destination word length. */
- switch (arg->expr->ts.type)
+ switch (mold_expr->ts.type)
{
case BT_CHARACTER:
- tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
- mold_type = gfc_get_character_type_len (arg->expr->ts.kind,
+ tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
+ mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
argse.string_length);
break;
case BT_CLASS:
- tmp = gfc_class_vtab_size_get (argse.expr);
+ if (scalar_mold)
+ class_ref = argse.expr;
+ else
+ class_ref = TREE_OPERAND (argse.expr, 0);
+ tmp = gfc_class_vtab_size_get (class_ref);
+ if (UNLIMITED_POLY (arg->expr))
+ tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
break;
default:
tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
break;
}
- dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
- gfc_add_modify (&se->pre, dest_word_len, tmp);
+
+ /* Do not fix dest_word_len if it is a variable, since the temporary can wind
+ up being used before the assignment. */
+ if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
+ dest_word_len = tmp;
+ else
+ {
+ dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_add_modify (&se->pre, dest_word_len, tmp);
+ }
/* Finally convert SIZE, if it is present. */
arg = arg->next;
diff --git a/gcc/testsuite/gfortran.dg/storage_size_7.f90 b/gcc/testsuite/gfortran.dg/storage_size_7.f90
new file mode 100644
index 00000000000..e32ca1b6a0e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/storage_size_7.f90
@@ -0,0 +1,91 @@
+! { dg-do run }
+! Fix STORAGE_SIZE intrinsic for polymorphic arguments PR84006 and PR100027.
+! Contributed by Steve Kargl <kar...@comcast.net>
+! and José Rui Faustino de Sousa <jrfso...@gcc.gnu.org>
+program p
+ use, intrinsic :: ISO_FORTRAN_ENV, only: int64
+ type t
+ integer i
+ end type
+ type s
+ class(t), allocatable :: c(:)
+ end type
+ integer :: rslt, class_rslt
+ integer(kind=int64), target :: tgt
+ class(t), allocatable, target :: t_alloc(:)
+ class(s), allocatable, target :: s_alloc(:)
+ character(:), allocatable, target :: chr(:)
+ class(*), pointer :: ptr_s, ptr_a(:)
+
+ allocate (t_alloc(2), source=t(1))
+ rslt = storage_size(t_alloc(1)) ! Scalar arg - the original testcase
+ if (rslt .ne. 32) stop 1
+
+ rslt = storage_size(t_alloc) ! Array arg
+ if (rslt .ne. 32) stop 2
+
+ call pr100027
+
+ allocate (s_alloc(2), source=s([t(1), t(2)]))
+! This, of course, is processor dependent: gfortran gives 576, NAG 448
+! and Intel 1216.
+ class_rslt = storage_size(s_alloc) ! Type with a class component
+ ptr_s => s_alloc(2)
+! However, the unlimited polymorphic result should be the same
+ if (storage_size (ptr_s) .ne. class_rslt) stop 3
+ ptr_a => s_alloc
+ if (storage_size (ptr_a) .ne. class_rslt) stop 4
+
+ rslt = storage_size(s_alloc(1)%c(2)) ! Scalar component arg
+ if (rslt .ne. 32) stop 5
+
+ rslt = storage_size(s_alloc(1)%c) ! Scalar component of array arg
+ if (rslt .ne. 32) stop 6
+
+ ptr_s => tgt
+ rslt = storage_size (ptr_s) ! INTEGER(8) target
+ if (rslt .ne. 64) stop 7
+
+ allocate (chr(2), source = ["abcde", "fghij"])
+ ptr_s => chr(2)
+ rslt = storage_size (ptr_s) ! CHARACTER(5) scalar
+ if (rslt .ne. 40) stop 8
+
+ ptr_a => chr
+ rslt = storage_size (ptr_a) ! CHARACTER(5) array
+ if (rslt .ne. 40) stop 9
+
+ deallocate (t_alloc, s_alloc, chr) ! For valgrind check
+
+contains
+
+! Original testcase from José Rui Faustino de Sousa
+ subroutine pr100027
+ implicit none
+
+ integer, parameter :: n = 11
+
+ type :: foo_t
+ end type foo_t
+
+ type, extends(foo_t) :: bar_t
+ end type bar_t
+
+ class(*), pointer :: apu(:)
+ class(foo_t), pointer :: apf(:)
+ class(bar_t), pointer :: apb(:)
+ type(bar_t), target :: atb(n)
+
+ integer :: m
+
+ apu => atb
+ m = storage_size(apu)
+ if (m .ne. 0) stop 10
+ apf => atb
+ m = storage_size(apf)
+ if (m .ne. 0) stop 11
+ apb => atb
+ m = storage_size(apb)
+ if (m .ne. 0) stop 12
+ end
+end program p
diff --git a/gcc/testsuite/gfortran.dg/transfer_class_4.f90 b/gcc/testsuite/gfortran.dg/transfer_class_4.f90
new file mode 100644
index 00000000000..4a2731a34b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_4.f90
@@ -0,0 +1,87 @@
+! { dg-do run }
+!
+! Fix TRANSFER intrinsic for unlimited polymorphic SOURCEs - PR98534
+! Note that unlimited polymorphic MOLD is a TODO.
+!
+! Contributed by Paul Thomas <pa...@gcc.gnu.org>
+!
+ use, intrinsic :: ISO_FORTRAN_ENV, only: real32
+ implicit none
+ character(*), parameter :: string = "abcdefgh"
+ character(len=:), allocatable :: string_a(:)
+ class(*), allocatable :: star
+ class(*), allocatable :: star_a(:)
+ character(len=:), allocatable :: chr
+ character(len=:), allocatable :: chr_a(:)
+ integer :: sz, sum1, sum2, i
+ real(real32) :: r = 1.0
+
+! Part 1: worked correctly
+ star = r
+ sz = storage_size (star)/8
+ allocate (character(len=sz) :: chr)
+ chr = transfer (star, chr)
+ sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+ chr = transfer(1.0, chr)
+ sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+
+ if (sz /= storage_size (real32)/8) stop 1
+ if (sum1 /= sum2) stop 2
+
+ deallocate (star) ! The automatic reallocation causes invalid writes
+ ! and memory leaks. Even with this deallocation
+ ! The invalid writes still occur.
+ deallocate (chr)
+
+! Part 2: Got everything wrong because '_len' field of unlimited polymorphic
+! expressions was not used.
+ star = string
+ sz = storage_size (star)/8
+ if (sz /= len (string)) stop 3 ! storage_size failed
+
+ sz = len (string) ! Ignore previous error in storage_size
+ allocate (character(len=sz) :: chr)
+ chr = transfer (star, chr)
+ sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+ chr = transfer(string, chr)
+ sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)])
+ if (sum1 /= sum2) stop 4 ! transfer failed
+
+! Check that arrays are OK for transfer
+ star_a = ['abcde','fghij']
+ allocate (character (len = 5) :: chr_a(2))
+ chr_a = transfer (star_a, chr_a)
+ if (any (chr_a .ne. ['abcde','fghij'])) stop 5
+
+! Check that string length and size are correctly handled
+ string_a = ["abcdefgh", "ijklmnop"]
+ star_a = string_a;
+ chr_a = transfer (star_a, chr_a) ! Old string length used for size
+ if (size(chr_a) .ne. 4) stop 6
+ if (len(chr_a) .ne. 5) stop 7
+ if (trim (chr_a(3)) .ne. "klmno") stop 8
+ if (chr_a(4)(1:1) .ne. "p") stop 9
+
+ chr_a = transfer (star_a, string_a) ! Use correct string_length for payload
+ if (size(chr_a) .ne. 2) stop 10
+ if (len(chr_a) .ne. 8) stop 11
+ if (any (chr_a .ne. string_a)) stop 12
+
+! Check that an unlimited polymorphic function result is transferred OK
+ deallocate (chr_a)
+ string_a = ['abc', 'def', 'hij']
+ chr_a = transfer (foo (string_a), string_a)
+ if (any (chr_a .ne. string_a)) stop 13
+
+! Finally, check that the SIZE gives correct results with unlimited sources.
+ chr_a = transfer (star_a, chr_a, 4)
+ if (chr_a (4) .ne. 'jkl') stop 14
+
+ deallocate (star, chr, star_a, chr_a, string_a)
+contains
+ function foo (arg) result(res)
+ character(*), intent(in) :: arg(:)
+ class(*), allocatable :: res(:)
+ res = arg
+ end
+end
Change.Logs
Description: Binary data
