From: Tobias Burnus Date: Sun, 31 Aug 2014 06:32:06 +0000 (+0200) Subject: trans-decl.c (gfc_build_builtin_function_decls): Add may_require_tmp dummy argument. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=93e2e0465e67d3e26f839c3069d0618708054b24;p=gcc.git trans-decl.c (gfc_build_builtin_function_decls): Add may_require_tmp dummy argument. 2014-08-31 Tobias Burnus gcc/fortran/ * trans-decl.c (gfc_build_builtin_function_decls): Add may_require_tmp dummy argument. * trans-intrinsic.c (gfc_conv_intrinsic_caf_get, conv_caf_send): Handle may_require_tmp argument. (gfc_conv_intrinsic_function): Update call. * gfortran.texi (_gfortran_caf_send, _gfortran_caf_get, _gfortran_caf_sendget): Update interface description. gcc/testsuite/ * gfortran.dg/coarray_lib_comm_1.f90: New. libgfortran/ * caf/libcaf.h (_gfortran_caf_send, _gfortran_caf_get, _gfortran_caf_sendget): Update prototype. * caf/single.c (_gfortran_caf_send, _gfortran_caf_get, _gfortran_caf_sendget): Handle may_require_tmp. From-SVN: r214764 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bd766a33b02..57b76bf7af3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2014-08-31 Tobias Burnus + + * trans-decl.c (gfc_build_builtin_function_decls): Add + may_require_tmp dummy argument. + * trans-intrinsic.c (gfc_conv_intrinsic_caf_get, + conv_caf_send): Handle may_require_tmp argument. + (gfc_conv_intrinsic_function): Update call. + * gfortran.texi (_gfortran_caf_send, _gfortran_caf_get, + _gfortran_caf_sendget): Update interface description. + 2014-08-30 Tobias Burnus * trans.h (gfc_caf_get_image_index, diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 0ce72264092..d02452c04e3 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -3448,7 +3448,7 @@ to a remote image identified by the image_index. @item @emph{Syntax}: @code{void _gfortran_caf_send (caf_token_t token, size_t offset, int image_index, gfc_descriptor_t *dest, caf_vector_t *dst_vector, -gfc_descriptor_t *src, int dst_kind, int src_kind)} +gfc_descriptor_t *src, int dst_kind, int src_kind, bool may_require_tmp)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -3466,15 +3466,26 @@ triplet of the dest argument. transferred to the remote image @item @var{dst_kind} @tab Kind of the destination argument @item @var{src_kind} @tab Kind of the source argument +@item @var{may_require_tmp} @tab The variable is false it is known at compile +time that the @var{dest} and @var{src} either cannot overlap or overlap (fully +or partially) such that walking @var{src} and @var{dest} in element wise +element order (honoring the stride value) will not lead to wrong results. +Otherwise, the value is true. @end multitable @item @emph{NOTES} It is permitted to have image_id equal the current image; the memory of the send-to and the send-from might (partially) overlap in that case. The -implementation has to take care that it handles this case. Note that the -assignment of a scalar to an array is permitted. In addition, the library has -to handle numeric-type conversion and for strings, padding and different -character kinds. +implementation has to take care that it handles this case, e.g. using +@code{memmove} which handles (partially) overlapping memory. If +@var{may_require_tmp} is true, the library might additionally create a +temporary variable, unless additional checks show that this is not required +(e.g. because walking backward is possible or because both arrays are +contiguous and @code{memmove} takes care of overlap issues). + +Note that the assignment of a scalar to an array is permitted. In addition, +the library has to handle numeric-type conversion and for strings, padding +and different character kinds. @end table @@ -3490,7 +3501,7 @@ image identified by the image_index. @item @emph{Syntax}: @code{void _gfortran_caf_get_desc (caf_token_t token, size_t offset, int image_index, gfc_descriptor_t *src, caf_vector_t *src_vector, -gfc_descriptor_t *dest, int src_kind, int dst_kind)} +gfc_descriptor_t *dest, int src_kind, int dst_kind, bool may_require_tmp)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -3508,14 +3519,25 @@ subscript of the destination array; the values are relative to the dimension triplet of the dest argument. @item @var{dst_kind} @tab Kind of the destination argument @item @var{src_kind} @tab Kind of the source argument +@item @var{may_require_tmp} @tab The variable is false it is known at compile +time that the @var{dest} and @var{src} either cannot overlap or overlap (fully +or partially) such that walking @var{src} and @var{dest} in element wise +element order (honoring the stride value) will not lead to wrong results. +Otherwise, the value is true. @end multitable @item @emph{NOTES} It is permitted to have image_id equal the current image; the memory of the send-to and the send-from might (partially) overlap in that case. The -implementation has to take care that it handles this case. Note that the -library has to handle numeric-type conversion and for strings, padding -and different character kinds. +implementation has to take care that it handles this case, e.g. using +@code{memmove} which handles (partially) overlapping memory. If +@var{may_require_tmp} is true, the library might additionally create a +temporary variable, unless additional checks show that this is not required +(e.g. because walking backward is possible or because both arrays are +contiguous and @code{memmove} takes care of overlap issues). + +Note that the library has to handle numeric-type conversion and for strings, +padding and different character kinds. @end table @@ -3533,7 +3555,8 @@ dst_image_index. @code{void _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset, int dst_image_index, gfc_descriptor_t *dest, caf_vector_t *dst_vector, caf_token_t src_token, size_t src_offset, int src_image_index, -gfc_descriptor_t *src, caf_vector_t *src_vector, int dst_kind, int src_kind)} +gfc_descriptor_t *src, caf_vector_t *src_vector, int dst_kind, int src_kind, +bool may_require_tmp)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -3543,7 +3566,7 @@ destination coarray. shifted compared to the base address of the destination coarray. @item @var{dst_image_index} @tab The ID of the destination remote image; must be a positive number. -@item @var{dst_dest} @tab intent(in) Array descriptor for the destination +@item @var{dest} @tab intent(in) Array descriptor for the destination remote image for the bounds and the size. The base_addr shall not be accessed. @item @var{dst_vector} @tab intent(int) If not NULL, it contains the vector subscript of the destination array; the values are relative to the dimension @@ -3553,21 +3576,31 @@ triplet of the dest argument. compared to the base address of the source coarray. @item @var{src_image_index} @tab The ID of the source remote image; must be a positive number. -@item @var{src_dest} @tab intent(in) Array descriptor of the local array to be +@item @var{src} @tab intent(in) Array descriptor of the local array to be transferred to the remote image. @item @var{src_vector} @tab intent(in) Array descriptor of the local array to be transferred to the remote image @item @var{dst_kind} @tab Kind of the destination argument @item @var{src_kind} @tab Kind of the source argument +@item @var{may_require_tmp} @tab The variable is false it is known at compile +time that the @var{dest} and @var{src} either cannot overlap or overlap (fully +or partially) such that walking @var{src} and @var{dest} in element wise +element order (honoring the stride value) will not lead to wrong results. +Otherwise, the value is true. @end multitable @item @emph{NOTES} -It is permitted to have image_id equal the current image; the memory of the -send-to and the send-from might (partially) overlap in that case. The -implementation has to take care that it handles this case. Note that the -assignment of a scalar to an array is permitted. In addition, the library has -to handle numeric-type conversion and for strings, padding and different -character kinds. +It is permitted to have image_ids equal; the memory of the send-to and the +send-from might (partially) overlap in that case. The implementation has to +take care that it handles this case, e.g. using @code{memmove} which handles +(partially) overlapping memory. If @var{may_require_tmp} is true, the library +might additionally create a temporary variable, unless additional checks show +that this is not required (e.g. because walking backward is possible or because +both arrays are contiguous and @code{memmove} takes care of overlap issues). + +Note that the assignment of a scalar to an array is permitted. In addition, +the library has to handle numeric-type conversion and for strings, padding and +different character kinds. @end table diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3063fea7323..6afa6f3b696 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3353,20 +3353,23 @@ gfc_build_builtin_function_decls (void) ppvoid_type_node, pint_type, pchar_type_node, integer_type_node); gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 8, + get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node); + pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node); gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 8, + get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node); + pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node); gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node, - 12, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, + 13, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node, integer_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node); + pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node); gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 3aa59c98adc..a13b11356af 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -40,6 +40,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-const.h" #include "trans-types.h" #include "trans-array.h" +#include "dependency.h" /* For CAF array alias analysis. */ /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ #include "trans-stmt.h" #include "tree-nested.h" @@ -1086,7 +1087,8 @@ conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar) /* Get data from a remote coarray. */ static void -gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind) +gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, + tree may_require_tmp) { gfc_expr *array_expr; gfc_se argse; @@ -1193,9 +1195,13 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind) image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl); gfc_get_caf_token_offset (&token, &offset, caf_decl, argse.expr, array_expr); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 8, + /* No overlap possible as we have generated a temporary. */ + if (lhs == NULL_TREE) + may_require_tmp = boolean_false_node; + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 9, token, offset, image_index, argse.expr, vec, - dst_var, kind, lhs_kind); + dst_var, kind, lhs_kind, may_require_tmp); gfc_add_expr_to_block (&se->pre, tmp); if (se->ss) @@ -1215,6 +1221,7 @@ conv_caf_send (gfc_code *code) { gfc_se lhs_se, rhs_se; stmtblock_t block; tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; + tree may_require_tmp; tree lhs_type = NULL_TREE; tree vec = null_pointer_node, rhs_vec = null_pointer_node; @@ -1222,6 +1229,8 @@ conv_caf_send (gfc_code *code) { lhs_expr = code->ext.actual->expr; rhs_expr = code->ext.actual->next->expr; + may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, false) == 0 + ? boolean_false_node : boolean_true_node; gfc_init_block (&block); /* LHS. */ @@ -1275,7 +1284,8 @@ conv_caf_send (gfc_code *code) { { gcc_assert (gfc_is_coindexed (rhs_expr)); gfc_init_se (&rhs_se, NULL); - gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind); + gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind, + may_require_tmp); gfc_add_block_to_block (&block, &rhs_se.pre); gfc_add_block_to_block (&block, &rhs_se.post); gfc_add_block_to_block (&block, &lhs_se.post); @@ -1342,9 +1352,9 @@ conv_caf_send (gfc_code *code) { rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind); if (!gfc_is_coindexed (rhs_expr)) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 8, token, + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 9, token, offset, image_index, lhs_se.expr, vec, - rhs_se.expr, lhs_kind, rhs_kind); + rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp); else { tree rhs_token, rhs_offset, rhs_image_index; @@ -1355,10 +1365,11 @@ conv_caf_send (gfc_code *code) { rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl); gfc_get_caf_token_offset (&rhs_token, &rhs_offset, caf_decl, rhs_se.expr, rhs_expr); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, 12, + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, 13, token, offset, image_index, lhs_se.expr, vec, rhs_token, rhs_offset, rhs_image_index, - rhs_se.expr, rhs_vec, lhs_kind, rhs_kind); + rhs_se.expr, rhs_vec, lhs_kind, rhs_kind, + may_require_tmp); } gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &lhs_se.post); @@ -7383,7 +7394,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_CAF_GET: - gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE); + gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE); break; case GFC_ISYM_CMPLX: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3ce39a55015..8cc10e7f699 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2014-08-31 Tobias Burnus + + * gfortran.dg/coarray_lib_comm_1.f90: New. + 2014-08-30 Andrew Pinski * gcc.c-torture/execute/20140828-1.c: New testcase. diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 new file mode 100644 index 00000000000..1db40feb7f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } +! +! Some dependency-analysis check for coarray communication +! +integer, target, save :: A(10)[*] +integer, pointer :: P(:) +integer, save :: B(10)[*] + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +A(10:2:-1) = A(9:1:-1)[1] ! 0 +B(10:2:-1) = B(9:1:-1) +if (any (A-B /= 0)) call abort + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +A(9:1:-1) = A(10:2:-1)[1] ! 1 +B(9:1:-1) = B(10:2:-1) +if (any (A-B /= 0)) call abort + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +allocate(P(10)) +P(:) = A(:)[1] ! 1 +if (any (A-B /= 0)) call abort + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +allocate(P(10)) +P(:) = B(:)[1] ! 0 + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +A(1:5)[1] = A(3:7)[1] ! 1 +B(1:5) = B(3:7) +if (any (A-B /= 0)) call abort +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0\\\);" 1 "original" } } + +! { dg-final { cleanup-tree-dump "original" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 308b0f52d58..b79790e3f3c 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2014-08-31 Tobias Burnus + + * caf/libcaf.h (_gfortran_caf_send, _gfortran_caf_get, + _gfortran_caf_sendget): Update prototype. + * caf/single.c (_gfortran_caf_send, _gfortran_caf_get, + _gfortran_caf_sendget): Handle may_require_tmp. + 2014-08-20 Steven G. Kargl PR libgfortran/62188 diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 85d6811facf..0f3398ac632 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -114,12 +114,12 @@ void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, int); void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *, - caf_vector_t *, gfc_descriptor_t *, int, int); + caf_vector_t *, gfc_descriptor_t *, int, int, bool); void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *, - caf_vector_t *, gfc_descriptor_t *, int, int); + caf_vector_t *, gfc_descriptor_t *, int, int, bool); void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *, caf_vector_t *, caf_token_t, size_t, int, - gfc_descriptor_t *, caf_vector_t *, int, int); + gfc_descriptor_t *, caf_vector_t *, int, int, bool); void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *, int, int); diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 990953ae4db..773941bc086 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -533,7 +533,8 @@ _gfortran_caf_get (caf_token_t token, size_t offset, int image_index __attribute__ ((unused)), gfc_descriptor_t *src, caf_vector_t *src_vector __attribute__ ((unused)), - gfc_descriptor_t *dest, int src_kind, int dst_kind) + gfc_descriptor_t *dest, int src_kind, int dst_kind, + bool may_require_tmp) { /* FIXME: Handle vector subscripts. */ size_t i, k, size; @@ -584,6 +585,82 @@ _gfortran_caf_get (caf_token_t token, size_t offset, if (size == 0) return; + if (may_require_tmp) + { + ptrdiff_t array_offset_sr, array_offset_dst; + void *tmp = malloc (size*src_size); + + array_offset_dst = 0; + for (i = 0; i < size; i++) + { + ptrdiff_t array_offset_sr = 0; + ptrdiff_t stride = 1; + ptrdiff_t extent = 1; + for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) + { + array_offset_sr += ((i / (extent*stride)) + % (src->dim[j]._ubound + - src->dim[j].lower_bound + 1)) + * src->dim[j]._stride; + extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1); + stride = src->dim[j]._stride; + } + array_offset_sr += (i / extent) * src->dim[rank-1]._stride; + void *sr = (void *)((char *) TOKEN (token) + offset + + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); + memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size); + array_offset_dst += src_size; + } + + array_offset_sr = 0; + for (i = 0; i < size; i++) + { + ptrdiff_t array_offset_dst = 0; + ptrdiff_t stride = 1; + ptrdiff_t extent = 1; + for (j = 0; j < rank-1; j++) + { + array_offset_dst += ((i / (extent*stride)) + % (dest->dim[j]._ubound + - dest->dim[j].lower_bound + 1)) + * dest->dim[j]._stride; + extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1); + stride = dest->dim[j]._stride; + } + array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; + void *dst = dest->base_addr + + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest); + void *sr = tmp + array_offset_sr; + + if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) + && dst_kind == src_kind) + { + memmove (dst, sr, dst_size > src_size ? src_size : dst_size); + if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER + && dst_size > src_size) + { + if (dst_kind == 1) + memset ((void*)(char*) dst + src_size, ' ', + dst_size-src_size); + else /* dst_kind == 4. */ + for (k = src_size/4; k < dst_size/4; k++) + ((int32_t*) dst)[k] = (int32_t) ' '; + } + } + else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) + assign_char1_from_char4 (dst_size, src_size, dst, sr); + else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) + assign_char4_from_char1 (dst_size, src_size, dst, sr); + else + convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, + sr, GFC_DESCRIPTOR_TYPE (src), src_kind); + array_offset_sr += src_size; + } + + free (tmp); + return; + } + for (i = 0; i < size; i++) { ptrdiff_t array_offset_dst = 0; @@ -646,7 +723,8 @@ _gfortran_caf_send (caf_token_t token, size_t offset, int image_index __attribute__ ((unused)), gfc_descriptor_t *dest, caf_vector_t *dst_vector __attribute__ ((unused)), - gfc_descriptor_t *src, int dst_kind, int src_kind) + gfc_descriptor_t *src, int dst_kind, int src_kind, + bool may_require_tmp) { /* FIXME: Handle vector subscripts. */ size_t i, k, size; @@ -697,6 +775,91 @@ _gfortran_caf_send (caf_token_t token, size_t offset, if (size == 0) return; + if (may_require_tmp) + { + ptrdiff_t array_offset_sr, array_offset_dst; + void *tmp; + + if (GFC_DESCRIPTOR_RANK (src) == 0) + { + tmp = malloc (src_size); + memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size); + } + else + { + tmp = malloc (size*src_size); + array_offset_dst = 0; + for (i = 0; i < size; i++) + { + ptrdiff_t array_offset_sr = 0; + ptrdiff_t stride = 1; + ptrdiff_t extent = 1; + for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) + { + array_offset_sr += ((i / (extent*stride)) + % (src->dim[j]._ubound + - src->dim[j].lower_bound + 1)) + * src->dim[j]._stride; + extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1); + stride = src->dim[j]._stride; + } + array_offset_sr += (i / extent) * src->dim[rank-1]._stride; + void *sr = (void *) ((char *) src->base_addr + + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); + memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size); + array_offset_dst += src_size; + } + } + + array_offset_sr = 0; + for (i = 0; i < size; i++) + { + ptrdiff_t array_offset_dst = 0; + ptrdiff_t stride = 1; + ptrdiff_t extent = 1; + for (j = 0; j < rank-1; j++) + { + array_offset_dst += ((i / (extent*stride)) + % (dest->dim[j]._ubound + - dest->dim[j].lower_bound + 1)) + * dest->dim[j]._stride; + extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1); + stride = dest->dim[j]._stride; + } + array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; + void *dst = (void *)((char *) TOKEN (token) + offset + + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest)); + void *sr = tmp + array_offset_sr; + if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) + && dst_kind == src_kind) + { + memmove (dst, sr, + dst_size > src_size ? src_size : dst_size); + if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER + && dst_size > src_size) + { + if (dst_kind == 1) + memset ((void*)(char*) dst + src_size, ' ', + dst_size-src_size); + else /* dst_kind == 4. */ + for (k = src_size/4; k < dst_size/4; k++) + ((int32_t*) dst)[k] = (int32_t) ' '; + } + } + else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) + assign_char1_from_char4 (dst_size, src_size, dst, sr); + else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) + assign_char4_from_char1 (dst_size, src_size, dst, sr); + else + convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, + sr, GFC_DESCRIPTOR_TYPE (src), src_kind); + if (GFC_DESCRIPTOR_RANK (src)) + array_offset_sr += src_size; + } + free (tmp); + return; + } + for (i = 0; i < size; i++) { ptrdiff_t array_offset_dst = 0; @@ -769,7 +932,7 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset, int src_image_index __attribute__ ((unused)), gfc_descriptor_t *src, caf_vector_t *src_vector __attribute__ ((unused)), - int dst_kind, int src_kind) + int dst_kind, int src_kind, bool may_require_tmp) { /* FIXME: Handle vector subscript of 'src_vector'. */ /* For a single image, src->base_addr should be the same as src_token + offset @@ -777,7 +940,7 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset, void *src_base = GFC_DESCRIPTOR_DATA (src); GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset); _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector, - src, dst_kind, src_kind); + src, dst_kind, src_kind, may_require_tmp); GFC_DESCRIPTOR_DATA (src) = src_base; }