From 7d96ee9eb52d52e7d3d61f1ad40754622a5569f0 Mon Sep 17 00:00:00 2001 From: vehre Date: Mon, 19 Feb 2018 17:30:57 +0000 Subject: gcc/fortran/ChangeLog: 2018-02-19 Andre Vehreschild * gfortran.texi: Document additional src/dst_type. Fix some typos. * trans-decl.c (gfc_build_builtin_function_decls): Declare the new argument of _caf_*_by_ref () with * e { get, send, sendget }. * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Add the type of the data referenced when generating a call to caf_get_by_ref (). (conv_caf_send): Same but for caf_send_by_ref () and caf_sendget_by_ref (). gcc/testsuite/ChangeLog: 2018-02-19 Andre Vehreschild * gfortran.dg/coarray_alloc_comp_6.f08: New test. * gfortran.dg/coarray_alloc_comp_7.f08: New test. * gfortran.dg/coarray_alloc_comp_8.f08: New test. libgfortran/ChangeLog: 2018-02-19 Andre Vehreschild * caf/libcaf.h: Add type parameters to the caf_*_by_ref prototypes. * caf/single.c (get_for_ref): Simplifications and now respecting the type argument. (_gfortran_caf_get_by_ref): Added source type handing to get_for_ref(). (send_by_ref): Simplifications and respecting the dst_type now. (_gfortran_caf_send_by_ref): Added destination type hand over to send_by_ref(). (_gfortran_caf_sendget_by_ref): Added general support and fixed stack corruption. The function is now really usable. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@257813 138bc75d-0d04-0410-961f-82ee72b054a4 --- libgfortran/caf/single.c | 186 ++++++++++++++++++++++++++++------------------- 1 file changed, 113 insertions(+), 73 deletions(-) (limited to 'libgfortran/caf/single.c') diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index bead09a386f..18906e99a94 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -1194,7 +1194,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, caf_single_token_t single_token, gfc_descriptor_t *dst, gfc_descriptor_t *src, void *ds, void *sr, int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, - size_t num, int *stat) + size_t num, int *stat, int src_type) { ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src; size_t next_dst_dim; @@ -1209,25 +1209,24 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, size_t dst_size = GFC_DESCRIPTOR_SIZE (dst); ptrdiff_t array_offset_dst = 0;; size_t dst_rank = GFC_DESCRIPTOR_RANK (dst); - int src_type = -1; switch (ref->type) { case CAF_REF_COMPONENT: /* Because the token is always registered after the component, its - offset is always greater zeor. */ + offset is always greater zero. */ if (ref->u.c.caf_token_offset > 0) + /* Note, that sr is dereffed here. */ copy_data (ds, *(void **)(sr + ref->u.c.offset), - GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst), + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, 1, stat); else copy_data (ds, sr + ref->u.c.offset, - GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src), + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: - src_type = ref->u.a.static_array_type; /* Intentionally fall through. */ case CAF_REF_ARRAY: if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) @@ -1235,8 +1234,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, for (size_t d = 0; d < dst_rank; ++d) array_offset_dst += dst_index[d]; copy_data (ds + array_offset_dst * dst_size, sr, - GFC_DESCRIPTOR_TYPE (dst), - src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type, + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, num, stat); *i += num; @@ -1252,23 +1250,39 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, { case CAF_REF_COMPONENT: if (ref->u.c.caf_token_offset > 0) - get_for_ref (ref->next, i, dst_index, - *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst, - (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc, - ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, - 1, stat); + { + single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset); + + if (ref->next && ref->next->type == CAF_REF_ARRAY) + src = single_token->desc; + else + src = NULL; + + if (ref->next && ref->next->type == CAF_REF_COMPONENT) + /* The currently ref'ed component was allocatabe (caf_token_offset + > 0) and the next ref is a component, too, then the new sr has to + be dereffed. (static arrays can not be allocatable or they + become an array with descriptor. */ + sr = *(void **)(sr + ref->u.c.offset); + else + sr += ref->u.c.offset; + + get_for_ref (ref->next, i, dst_index, single_token, dst, src, + ds, sr, dst_kind, src_kind, dst_dim, 0, + 1, stat, src_type); + } else get_for_ref (ref->next, i, dst_index, single_token, dst, (gfc_descriptor_t *)(sr + ref->u.c.offset), ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1, - stat); + stat, src_type); return; case CAF_REF_ARRAY: if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) { get_for_ref (ref->next, i, dst_index, single_token, dst, src, ds, sr, dst_kind, src_kind, - dst_dim, 0, 1, stat); + dst_dim, 0, 1, stat, src_type); return; } /* Only when on the left most index switch the data pointer to @@ -1311,7 +1325,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1331,7 +1345,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1358,7 +1372,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, next_dst_dim, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1372,7 +1386,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim, src_dim + 1, 1, - stat); + stat, src_type); return; case CAF_ARR_REF_OPEN_END: COMPUTE_NUM_ITEMS (extent_src, @@ -1390,7 +1404,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1410,7 +1424,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1425,7 +1439,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, { get_for_ref (ref->next, i, dst_index, single_token, dst, NULL, ds, sr, dst_kind, src_kind, - dst_dim, 0, 1, stat); + dst_dim, 0, 1, stat, src_type); return; } switch (ref->u.a.mode[src_dim]) @@ -1460,7 +1474,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1474,7 +1488,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1491,7 +1505,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += ref->u.a.dim[src_dim].s.stride; @@ -1502,7 +1516,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim, src_dim + 1, 1, - stat); + stat, src_type); return; /* The OPEN_* are mapped to a RANGE and therefore can not occur. */ case CAF_ARR_REF_OPEN_END: @@ -1523,7 +1537,8 @@ _gfortran_caf_get_by_ref (caf_token_t token, gfc_descriptor_t *dst, caf_reference_t *refs, int dst_kind, int src_kind, bool may_require_tmp __attribute__ ((unused)), - bool dst_reallocatable, int *stat) + bool dst_reallocatable, int *stat, + int src_type) { const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " "unknown kind in vector-ref.\n"; @@ -1585,7 +1600,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, else { memptr += riter->u.c.offset; - src = (gfc_descriptor_t *)memptr; + /* When the next ref is an array ref, assume there is an + array descriptor at memptr. Note, static arrays do not have + a descriptor. */ + if (riter->next && riter->next->type == CAF_REF_ARRAY) + src = (gfc_descriptor_t *)memptr; + else + src = NULL; } break; case CAF_REF_ARRAY: @@ -1677,6 +1698,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, caf_internal_error (extentoutofrange, stat, NULL, 0); return; } + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* When dst is an array. */ if (dst_rank > 0) { @@ -1845,6 +1873,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, caf_internal_error (extentoutofrange, stat, NULL, 0); return; } + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* When dst is an array. */ if (dst_rank > 0) { @@ -1946,6 +1981,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, if (!array_extent_fixed) { assert (size == 1); + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* This can happen only, when the result is scalar. */ for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim) GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1); @@ -1967,7 +2009,7 @@ _gfortran_caf_get_by_ref (caf_token_t token, i = 0; get_for_ref (refs, &i, dst_index, single_token, dst, src, GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0, - 1, stat); + 1, stat, src_type); } @@ -1976,7 +2018,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, caf_single_token_t single_token, gfc_descriptor_t *dst, gfc_descriptor_t *src, void *ds, void *sr, int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, - size_t num, size_t size, int *stat) + size_t num, size_t size, int *stat, int dst_type) { const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): " "unknown kind in vector-ref.\n"; @@ -1992,7 +2034,6 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { size_t src_size = GFC_DESCRIPTOR_SIZE (src); ptrdiff_t array_offset_src = 0;; - int dst_type = -1; switch (ref->type) { @@ -2036,26 +2077,18 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, dst_type = GFC_DESCRIPTOR_TYPE (dst); } else - { - /* When no destination descriptor is present, assume that - source and dest type are identical. */ - dst_type = GFC_DESCRIPTOR_TYPE (src); - ds = *(void **)(ds + ref->u.c.offset); - } + ds = *(void **)(ds + ref->u.c.offset); } copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, 1, stat); } else - copy_data (ds + ref->u.c.offset, sr, - dst != NULL ? GFC_DESCRIPTOR_TYPE (dst) - : GFC_DESCRIPTOR_TYPE (src), + copy_data (ds + ref->u.c.offset, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: - dst_type = ref->u.a.static_array_type; /* Intentionally fall through. */ case CAF_REF_ARRAY: if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) @@ -2064,18 +2097,14 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { for (size_t d = 0; d < src_rank; ++d) array_offset_src += src_index[d]; - copy_data (ds, sr + array_offset_src * ref->item_size, - dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) - : dst_type, - GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, - ref->item_size, src_size, num, stat); + copy_data (ds, sr + array_offset_src * src_size, + dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, + src_kind, ref->item_size, src_size, num, stat); } else - copy_data (ds, sr, - dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) - : dst_type, - GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, - ref->item_size, src_size, num, stat); + copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), + dst_kind, src_kind, ref->item_size, src_size, num, + stat); *i += num; return; } @@ -2123,22 +2152,30 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, return; } single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset); + /* When a component is allocatable (caf_token_offset != 0) and not an + array (ref->next->type == CAF_REF_COMPONENT), then ds has to be + dereffed. */ + if (ref->next && ref->next->type == CAF_REF_COMPONENT) + ds = *(void **)(ds + ref->u.c.offset); + else + ds += ref->u.c.offset; + send_by_ref (ref->next, i, src_index, single_token, - single_token->desc, src, ds + ref->u.c.offset, sr, - dst_kind, src_kind, 0, src_dim, 1, size, stat); + single_token->desc, src, ds, sr, + dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type); } else send_by_ref (ref->next, i, src_index, single_token, (gfc_descriptor_t *)(ds + ref->u.c.offset), src, ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim, - 1, size, stat); + 1, size, stat, dst_type); return; case CAF_REF_ARRAY: if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) { send_by_ref (ref->next, i, src_index, single_token, (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind, - 0, src_dim, 1, size, stat); + 0, src_dim, 1, size, stat, dst_type); return; } /* Only when on the left most index switch the data pointer to @@ -2180,7 +2217,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2201,7 +2238,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2222,7 +2259,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2236,7 +2273,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim, 1, - size, stat); + size, stat, dst_type); return; case CAF_ARR_REF_OPEN_END: COMPUTE_NUM_ITEMS (extent_dst, @@ -2253,7 +2290,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2274,7 +2311,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2290,7 +2327,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { send_by_ref (ref->next, i, src_index, single_token, NULL, src, ds, sr, dst_kind, src_kind, - 0, src_dim, 1, size, stat); + 0, src_dim, 1, size, stat, dst_type); return; } switch (ref->u.a.mode[dst_dim]) @@ -2325,7 +2362,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); } @@ -2339,7 +2376,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2357,7 +2394,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2369,7 +2406,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim, 1, - size, stat); + size, stat, dst_type); return; /* The OPEN_* are mapped to a RANGE and therefore can not occur. */ case CAF_ARR_REF_OPEN_END: @@ -2390,7 +2427,7 @@ _gfortran_caf_send_by_ref (caf_token_t token, gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, int src_kind, bool may_require_tmp __attribute__ ((unused)), - bool dst_reallocatable, int *stat) + bool dst_reallocatable, int *stat, int dst_type) { const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " "unknown kind in vector-ref.\n"; @@ -2748,7 +2785,7 @@ _gfortran_caf_send_by_ref (caf_token_t token, i = 0; send_by_ref (refs, &i, dst_index, single_token, dst, src, memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0, - 1, size, stat); + 1, size, stat, dst_type); assert (i == size); } @@ -2759,20 +2796,23 @@ _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, int src_image_index, caf_reference_t *src_refs, int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, - int *src_stat) + int *src_stat, int dst_type, int src_type) { - gfc_array_void temp; + GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp; + GFC_DESCRIPTOR_DATA (&temp) = NULL; + GFC_DESCRIPTOR_RANK (&temp) = -1; + GFC_DESCRIPTOR_TYPE (&temp) = dst_type; _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs, dst_kind, src_kind, may_require_tmp, true, - src_stat); + src_stat, src_type); if (src_stat && *src_stat != 0) return; _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs, - dst_kind, src_kind, may_require_tmp, true, - dst_stat); + dst_kind, dst_kind, may_require_tmp, true, + dst_stat, dst_type); if (GFC_DESCRIPTOR_DATA (&temp)) free (GFC_DESCRIPTOR_DATA (&temp)); } -- cgit v1.2.1 From 5e04a38ad7a07d60025b6f15836aad7b7311c1e6 Mon Sep 17 00:00:00 2001 From: jb Date: Thu, 22 Feb 2018 09:44:31 +0000 Subject: Character length cleanup for Coarray Fortran library Following the change to use size_t for Fortran character lengths (PR 78534), this patch modifies the Coarray ABI in a similar way. The single-image implementation that is included in libgfortran is updated, but this needs corresponding work in the OpenCoarray library as well for multi-image support. I also fixed the types for the STOP and ERROR STOP implementation in libgfortran, as the calling of them is somewhat intertwined with the calling of the corresponding CAF functions. I'll send the OpenCoarray changes as a separate pull request to the OpenCoarrays repository. Regtested on x86_64-pc-linux-gnu. gcc/fortran/ChangeLog: 2018-02-22 Janne Blomqvist * gfortran.texi: Update Coarray API description. * trans-decl.c (gfc_build_builtin_function_decls): Use size_t for character lengths, int for exit codes. (generate_coarray_sym_init): Use size_t for character length. * trans-intrinsic.c (conv_co_collective): Likewise. * trans-stmt.c (gfc_trans_lock_unlock): Likewise. (gfc_trans_event_post_wait): Likewise. (gfc_trans_sync): Likewise. (gfc_trans_stop): Use size_t for character lengths, int for exit codes. libgfortran/ChangeLog: 2018-02-22 Janne Blomqvist * libgfortran.h (stop_string): Use size_t for character length. * runtime/stop.c (stop_string): Likewise. (error_stop_string): Likewise. (stop_numeric): Use int for exit code. (error_stop_numeric): Likewise. * caf/libcaf.h: Remove stdint.h include. (_gfortran_caf_register): Use size_t for character length. (_gfortran_caf_deregister): Likewise. (_gfortran_caf_sync_all): Likewise. (_gfortran_caf_sync_memory): Likewise. (_gfortran_caf_sync_images): Likewise. (_gfortran_caf_stop_numeric): Use int for exit code. (_gfortran_caf_stop_str): Use size_t for character length. (_gfortran_caf_error_stop_str): Likewise. (_gfortran_caf_error_stop): Use int for exit code. (_gfortran_caf_co_broadcast): Use size_t for character length. (_gfortran_caf_co_sum): Likewise. (_gfortran_caf_co_min): Likewise. (_gfortran_caf_co_max): Likewise. (_gfortran_caf_co_reduce): Likewise. (_gfortran_caf_lock): Likewise. (_gfortran_caf_unlock): Likewise. (_gfortran_caf_event_post): Likewise. (_gfortran_caf_event_wait): Likewise. * caf/mpi.c (_gfortran_caf_register): Update implementation to match prototype. (_gfortran_caf_deregister): Likewise. (_gfortran_caf_sync_all): Likewise. (_gfortran_caf_sync_images): Likewise. (_gfortran_caf_error_stop_str): Likewise. (_gfortran_caf_error_stop): Likewise. * caf/single.c (caf_internal_error): Likewise. (_gfortran_caf_register): Likewise. (_gfortran_caf_deregister): Likewise. (_gfortran_caf_sync_all): Likewise. (_gfortran_caf_sync_memory): Likewise. (_gfortran_caf_sync_images): Likewise. (_gfortran_caf_stop_numeric): Likewise. (_gfortran_caf_stop_str): Likewise. (_gfortran_caf_error_stop_str): Likewise. (_gfortran_caf_error_stop): Likewise. (_gfortran_caf_co_broadcast): Likewise. (_gfortran_caf_co_sum): Likewise. (_gfortran_caf_co_min): Likewise. (_gfortran_caf_co_max): Likewise. (_gfortran_caf_co_reduce): Likewise. (_gfortran_caf_event_post): Likewise. (_gfortran_caf_event_wait): Likewise. (_gfortran_caf_lock): Likewise. (_gfortran_caf_unlock): Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@257894 138bc75d-0d04-0410-961f-82ee72b054a4 --- libgfortran/caf/single.c | 55 ++++++++++++++++++++++++------------------------ 1 file changed, 28 insertions(+), 27 deletions(-) (limited to 'libgfortran/caf/single.c') diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 18906e99a94..053ec87d562 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include /* For exit and malloc. */ #include /* For memcpy and memset. */ #include /* For variadic arguments. */ +#include #include /* Define GFC_CAF_CHECK to enable run-time checking. */ @@ -74,7 +75,7 @@ caf_runtime_error (const char *message, ...) /* Error handling is similar everytime. */ static void caf_internal_error (const char *msg, int *stat, char *errmsg, - int errmsg_len, ...) + size_t errmsg_len, ...) { va_list args; va_start (args, errmsg_len); @@ -83,8 +84,8 @@ caf_internal_error (const char *msg, int *stat, char *errmsg, *stat = 1; if (errmsg_len > 0) { - size_t len = snprintf (errmsg, errmsg_len, msg, args); - if ((size_t)errmsg_len > len) + int len = snprintf (errmsg, errmsg_len, msg, args); + if (len >= 0 && errmsg_len > (size_t) len) memset (&errmsg[len], ' ', errmsg_len - len); } va_end (args); @@ -134,7 +135,7 @@ _gfortran_caf_num_images (int distance __attribute__ ((unused)), void _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, gfc_descriptor_t *data, int *stat, char *errmsg, - int errmsg_len) + size_t errmsg_len) { const char alloc_fail_msg[] = "Failed to allocate coarray"; void *local; @@ -195,7 +196,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, void _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { caf_single_token_t single_token = TOKEN (*token); @@ -221,7 +222,7 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, void _gfortran_caf_sync_all (int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { __asm__ __volatile__ ("":::"memory"); if (stat) @@ -232,7 +233,7 @@ _gfortran_caf_sync_all (int *stat, void _gfortran_caf_sync_memory (int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { __asm__ __volatile__ ("":::"memory"); if (stat) @@ -245,7 +246,7 @@ _gfortran_caf_sync_images (int count __attribute__ ((unused)), int images[] __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { #ifdef GFC_CAF_CHECK int i; @@ -266,7 +267,7 @@ _gfortran_caf_sync_images (int count __attribute__ ((unused)), void -_gfortran_caf_stop_numeric(int32_t stop_code) +_gfortran_caf_stop_numeric(int stop_code) { fprintf (stderr, "STOP %d\n", stop_code); exit (0); @@ -274,7 +275,7 @@ _gfortran_caf_stop_numeric(int32_t stop_code) void -_gfortran_caf_stop_str(const char *string, int32_t len) +_gfortran_caf_stop_str(const char *string, size_t len) { fputs ("STOP ", stderr); while (len--) @@ -286,7 +287,7 @@ _gfortran_caf_stop_str(const char *string, int32_t len) void -_gfortran_caf_error_stop_str (const char *string, int32_t len) +_gfortran_caf_error_stop_str (const char *string, size_t len) { fputs ("ERROR STOP ", stderr); while (len--) @@ -366,7 +367,7 @@ _gfortran_caf_stopped_images (gfc_descriptor_t *array, void -_gfortran_caf_error_stop (int32_t error) +_gfortran_caf_error_stop (int error) { fprintf (stderr, "ERROR STOP %d\n", error); exit (error); @@ -377,7 +378,7 @@ void _gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)), int source_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { if (stat) *stat = 0; @@ -387,7 +388,7 @@ void _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)), int result_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { if (stat) *stat = 0; @@ -398,7 +399,7 @@ _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)), int result_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), int a_len __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { if (stat) *stat = 0; @@ -409,7 +410,7 @@ _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)), int result_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), int a_len __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { if (stat) *stat = 0; @@ -424,7 +425,7 @@ _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)), int result_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), int a_len __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { if (stat) *stat = 0; @@ -2910,7 +2911,7 @@ void _gfortran_caf_event_post (caf_token_t token, size_t index, int image_index __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { uint32_t value = 1; uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index @@ -2925,7 +2926,7 @@ void _gfortran_caf_event_wait (caf_token_t token, size_t index, int until_count, int *stat, char *errmsg __attribute__ ((unused)), - int errmsg_len __attribute__ ((unused))) + size_t errmsg_len __attribute__ ((unused))) { uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index * sizeof (uint32_t)); @@ -2952,7 +2953,7 @@ _gfortran_caf_event_query (caf_token_t token, size_t index, void _gfortran_caf_lock (caf_token_t token, size_t index, int image_index __attribute__ ((unused)), - int *aquired_lock, int *stat, char *errmsg, int errmsg_len) + int *aquired_lock, int *stat, char *errmsg, size_t errmsg_len) { const char *msg = "Already locked"; bool *lock = &((bool *) MEMTOK (token))[index]; @@ -2981,22 +2982,22 @@ _gfortran_caf_lock (caf_token_t token, size_t index, *stat = 1; if (errmsg_len > 0) { - int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len - : (int) sizeof (msg); + size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len + : sizeof (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); } return; } - _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg)); + _gfortran_caf_error_stop_str (msg, strlen (msg)); } void _gfortran_caf_unlock (caf_token_t token, size_t index, int image_index __attribute__ ((unused)), - int *stat, char *errmsg, int errmsg_len) + int *stat, char *errmsg, size_t errmsg_len) { const char *msg = "Variable is not locked"; bool *lock = &((bool *) MEMTOK (token))[index]; @@ -3014,15 +3015,15 @@ _gfortran_caf_unlock (caf_token_t token, size_t index, *stat = 1; if (errmsg_len > 0) { - int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len - : (int) sizeof (msg); + size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len + : sizeof (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); } return; } - _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg)); + _gfortran_caf_error_stop_str (msg, strlen (msg)); } int -- cgit v1.2.1 From dbd7773a83341f3b0f2b41f0b47724e1b159ce45 Mon Sep 17 00:00:00 2001 From: jb Date: Fri, 23 Feb 2018 09:07:24 +0000 Subject: PR 84519 Handle optional QUIET specifier for STOP and ERROR STOP Fortran 2018 adds a new QUIET specifier for the STOP and ERROR STOP statements, in order to suppress the printing of signaling FP exceptions and the stop code. This patch adds the necessary library changes, but for now the new specifier is not parsed and the frontend unconditionally adds a false value for the new argument. Regtested on x86_64-pc-linux-gnu. gcc/fortran/ChangeLog: 2018-02-23 Janne Blomqvist PR fortran/84519 * trans-decl.c (gfc_build_builtin_function_decls): Add bool argument to stop and error stop decls. * trans-stmt.c (gfc_trans_stop): Add false value to argument lists. libgfortran/ChangeLog: 2018-02-23 Janne Blomqvist PR fortran/84519 * caf/libcaf.h (_gfortran_caf_stop_numeric): Add bool argument. (_gfortran_caf_stop_str): Likewise. (_gfortran_caf_error_stop_str): Likewise. (_gfortran_caf_error_stop): Likewise. * caf/mpi.c (_gfortran_caf_error_stop_str): Handle new argument. (_gfortran_caf_error_stop): Likewise. * caf/single.c (_gfortran_caf_stop_numeric): Likewise. (_gfortran_caf_stop_str): Likewise. (_gfortran_caf_error_stop_str): Likewise. (_gfortran_caf_error_stop): Likewise. (_gfortran_caf_lock): Likewise. (_gfortran_caf_unlock): Likewise. * libgfortran.h (stop_string): Add bool argument. * runtime/pause.c (do_pause): Add false argument. * runtime/stop.c (stop_numeric): Handle new argument. (stop_string): Likewise. (error_stop_string): Likewise. (error_stop_numeric): Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@257928 138bc75d-0d04-0410-961f-82ee72b054a4 --- libgfortran/caf/single.c | 42 ++++++++++++++++++++++++------------------ 1 file changed, 24 insertions(+), 18 deletions(-) (limited to 'libgfortran/caf/single.c') diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 053ec87d562..1ad13bd5643 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -267,33 +267,38 @@ _gfortran_caf_sync_images (int count __attribute__ ((unused)), void -_gfortran_caf_stop_numeric(int stop_code) +_gfortran_caf_stop_numeric(int stop_code, bool quiet) { - fprintf (stderr, "STOP %d\n", stop_code); + if (!quiet) + fprintf (stderr, "STOP %d\n", stop_code); exit (0); } void -_gfortran_caf_stop_str(const char *string, size_t len) +_gfortran_caf_stop_str(const char *string, size_t len, bool quiet) { - fputs ("STOP ", stderr); - while (len--) - fputc (*(string++), stderr); - fputs ("\n", stderr); - + if (!quiet) + { + fputs ("STOP ", stderr); + while (len--) + fputc (*(string++), stderr); + fputs ("\n", stderr); + } exit (0); } void -_gfortran_caf_error_stop_str (const char *string, size_t len) +_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet) { - fputs ("ERROR STOP ", stderr); - while (len--) - fputc (*(string++), stderr); - fputs ("\n", stderr); - + if (!quiet) + { + fputs ("ERROR STOP ", stderr); + while (len--) + fputc (*(string++), stderr); + fputs ("\n", stderr); + } exit (1); } @@ -367,9 +372,10 @@ _gfortran_caf_stopped_images (gfc_descriptor_t *array, void -_gfortran_caf_error_stop (int error) +_gfortran_caf_error_stop (int error, bool quiet) { - fprintf (stderr, "ERROR STOP %d\n", error); + if (!quiet) + fprintf (stderr, "ERROR STOP %d\n", error); exit (error); } @@ -2990,7 +2996,7 @@ _gfortran_caf_lock (caf_token_t token, size_t index, } return; } - _gfortran_caf_error_stop_str (msg, strlen (msg)); + _gfortran_caf_error_stop_str (msg, strlen (msg), false); } @@ -3023,7 +3029,7 @@ _gfortran_caf_unlock (caf_token_t token, size_t index, } return; } - _gfortran_caf_error_stop_str (msg, strlen (msg)); + _gfortran_caf_error_stop_str (msg, strlen (msg), false); } int -- cgit v1.2.1