Hi all,
attached patch fixes some issue in caf/single.c that were reported as pure
style issues, but uncovered at least one significant error when handling sending
data to a remote image when the memory and associated token was not allocated
yet. The send_by_ref-routine stored the new token only on the stack when the
component to allocate was scalar which lead to crashes, when that token was
later on accessed. Furthermore was the memory and the token lost. This patch
fixes the issue.
Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
gcc/testsuite/ChangeLog:
2016-10-01 Andre Vehreschild <ve...@gcc.gnu.org>
* gfortran.dg/coarray_send_by_ref_1.f08: New test.
libgfortran/ChangeLog:
2016-10-01 Andre Vehreschild <ve...@gcc.gnu.org>
* caf/single.c (caf_internal_error): Fix not terminating va-list.
(_gfortran_caf_register): Free memory also when other allocs failed.
(_gfortran_caf_get_by_ref): Fixed style.
(send_by_ref): Token is now stored at the correct position preventing
inaccessible tokens, memory loss and possibly crashes.
diff --git a/gcc/testsuite/gfortran.dg/coarray_send_by_ref_1.f08 b/gcc/testsuite/gfortran.dg/coarray_send_by_ref_1.f08
new file mode 100644
index 0000000..73f91e0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_send_by_ref_1.f08
@@ -0,0 +1,29 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+
+program check_caf_send_by_ref
+
+ implicit none
+
+ type T
+ integer, allocatable :: scal
+ integer, allocatable :: array(:)
+ end type T
+
+ type(T), save :: obj[*]
+ integer :: me, np, i
+
+ me = this_image()
+ np = num_images()
+
+ obj[np]%scal = 42
+
+ ! Check the token for the scalar is set.
+ if (obj[np]%scal /= 42) call abort()
+
+ ! Now the same for arrays.
+ obj[np]%array = [(i * np + me, i = 1, 15)]
+ if (any(obj[np]%array /= [(i * np + me, i = 1, 15)])) call abort()
+
+end program check_caf_send_by_ref
+
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index c472446..55171fd 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -87,6 +87,7 @@ caf_internal_error (const char *msg, int *stat, char *errmsg,
if ((size_t)errmsg_len > len)
memset (&errmsg[len], ' ', errmsg_len - len);
}
+ va_end (args);
return;
}
else
@@ -149,6 +150,13 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
if (unlikely (local == NULL || *token == NULL))
{
+ /* Freeing the memory conditionally seems pointless, but
+ caf_internal_error () may return, when a stat is given and then the
+ memory may be lost. */
+ if (local)
+ free (local);
+ if (*token)
+ free (*token);
caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
return;
}
@@ -1465,7 +1473,7 @@ _gfortran_caf_get_by_ref (caf_token_t token,
bool array_extent_fixed = false;
realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
- assert (!realloc_needed || (realloc_needed && dst_reallocatable));
+ assert (!realloc_needed || dst_reallocatable);
if (stat)
*stat = 0;
@@ -1909,14 +1917,14 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
GFC_DESCRIPTOR_DTYPE (&static_dst)
= GFC_DESCRIPTOR_DTYPE (src);
- /* The component may be allocated now, because it is a
+ /* The component can be allocated now, because it is a
scalar. */
- single_token = *(caf_single_token_t*)
- (ds + ref->u.c.caf_token_offset);
_gfortran_caf_register (ref->item_size,
CAF_REGTYPE_COARRAY_ALLOC,
- (caf_token_t *)&single_token,
+ ds + ref->u.c.caf_token_offset,
&static_dst, stat, NULL, 0);
+ single_token = *(caf_single_token_t *)
+ (ds + ref->u.c.caf_token_offset);
/* In case of an error in allocation return. When stat is
NULL, then register_component() terminates on error. */
if (stat != NULL && *stat)
@@ -2005,15 +2013,13 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
/* The size of the array is given by size. */
_gfortran_caf_register (size * ref->item_size,
CAF_REGTYPE_COARRAY_ALLOC,
- (void **)&single_token,
+ ds + ref->u.c.caf_token_offset,
dst, stat, NULL, 0);
/* In case of an error in allocation return. When stat is
NULL, then register_component() terminates on error. */
if (stat != NULL && *stat)
return;
/* The memptr, descriptor and the token are set below. */
- *(caf_single_token_t *)(ds + ref->u.c.caf_token_offset)
- = single_token;
}
single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
send_by_ref (ref->next, i, src_index, single_token,
