From d3244675441faf9c2d3949821f7deee34705e9c8 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Fri, 7 Feb 2025 12:09:53 +0100 Subject: [PATCH] Fortran: Remove deprecated coarray routines [PR107635] gcc/fortran/ChangeLog: PR fortran/107635 * gfortran.texi: Remove deprecated functions from documentation. * trans-decl.cc (gfc_build_builtin_function_decls): Remove decprecated function decls. * trans-intrinsic.cc (gfc_conv_intrinsic_exponent): Remove deprecated/no longer needed routines. * trans.h: Remove unused decls. libgfortran/ChangeLog: * caf/libcaf.h (_gfortran_caf_get): Removed because deprecated. (_gfortran_caf_send): Same. (_gfortran_caf_sendget): Same. (_gfortran_caf_send_by_ref): Same. * caf/single.c (assign_char4_from_char1): Same. (assign_char1_from_char4): Same. (convert_type): Same. (defined): Same. (_gfortran_caf_get): Same. (_gfortran_caf_send): Same. (_gfortran_caf_sendget): Same. (copy_data): Same. (get_for_ref): Same. (_gfortran_caf_get_by_ref): Same. (send_by_ref): Same. (_gfortran_caf_send_by_ref): Same. (_gfortran_caf_sendget_by_ref): Same. --- gcc/fortran/gfortran.texi | 335 ----- gcc/fortran/trans-decl.cc | 49 - gcc/fortran/trans-intrinsic.cc | 1100 --------------- gcc/fortran/trans.h | 10 - libgfortran/caf/libcaf.h | 112 -- libgfortran/caf/single.c | 2387 -------------------------------- 6 files changed, 3993 deletions(-) diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 36c203b27b3..ba3c3771c43 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -4205,12 +4205,6 @@ future implementation of teams. It is about to change without further notice. * _gfortran_caf_register_accessor:: Register an accessor for remote access * _gfortran_caf_register_accessors_finish:: Finish registering accessor functions * _gfortran_caf_get_remote_function_index:: Get the index of an accessor -* _gfortran_caf_is_present:: Query whether an allocatable or pointer component in a derived type coarray is allocated -* _gfortran_caf_send:: Sending data from a local image to a remote image -* _gfortran_caf_get:: Getting data from a remote image -* _gfortran_caf_sendget:: Sending data between remote images -* _gfortran_caf_send_by_ref:: Sending data from a local image to a remote image using enhanced references -* _gfortran_caf_get_by_ref:: Getting data from a remote image using enhanced references * _gfortran_caf_get_from_remote:: Getting data from a remote image using a remote side accessor * _gfortran_caf_is_present_on_remote:: Check that a coarray or a part of it is allocated on the remote image * _gfortran_caf_send_to_remote:: Send data to a remote image using a remote side accessor to store it @@ -4649,335 +4643,6 @@ message, when the hash could not be found. @end table - -@node _gfortran_caf_is_present -@subsection @code{_gfortran_caf_is_present} --- Query whether an allocatable or pointer component in a derived type coarray is allocated -@cindex Coarray, _gfortran_caf_is_present - -@table @asis -@item @emph{Description}: -Used to query the coarray library whether an allocatable component in a derived -type coarray is allocated on a remote image. - -@item @emph{Syntax}: -@code{void _gfortran_caf_is_present (caf_token_t token, int image_index, -gfc_reference_t *ref)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{token} @tab An opaque pointer identifying the coarray. -@item @var{image_index} @tab The ID of the remote image; must be a positive -number. -@item @var{ref} @tab A chain of references to address the allocatable or -pointer component in the derived type coarray. The object reference needs to be -a scalar or a full array reference, respectively. -@end multitable - -@end table - -@node _gfortran_caf_send -@subsection @code{_gfortran_caf_send} --- Sending data from a local image to a remote image -@cindex Coarray, _gfortran_caf_send - -@table @asis -@item @emph{Description}: -Called to send a scalar, an array section or a whole array from a local -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, bool may_require_tmp, -int *stat)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{token} @tab intent(in) An opaque pointer identifying the coarray. -@item @var{offset} @tab intent(in) The number of bytes the actual data is -shifted compared to the base address of the coarray. -@item @var{image_index} @tab intent(in) The ID of the remote image; must be a -positive number. -@item @var{dest} @tab intent(in) Array descriptor for the remote image for the -bounds and the size. The @code{base_addr} shall not be accessed. -@item @var{dst_vector} @tab intent(in) If not NULL, it contains the vector -subscript of the destination array; the values are relative to the dimension -triplet of the dest argument. -@item @var{src} @tab intent(in) Array descriptor of the local array to be -transferred to the remote image -@item @var{dst_kind} @tab intent(in) Kind of the destination argument -@item @var{src_kind} @tab intent(in) Kind of the source argument -@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when -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 elementwise order (honoring the stride value) does not -lead to wrong results. Otherwise, the value is @code{true}. -@item @var{stat} @tab intent(out) when non-NULL give the result of the -operation, i.e., zero on success and nonzero on error. When NULL and an error -occurs, then an error message is printed and the program is terminated. -@end multitable - -@item @emph{NOTES} -It is permitted to have @var{image_index} 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, 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 padding -and different character kinds for strings. -@end table - - -@node _gfortran_caf_get -@subsection @code{_gfortran_caf_get} --- Getting data from a remote image -@cindex Coarray, _gfortran_caf_get - -@table @asis -@item @emph{Description}: -Called to get an array section or a whole array from a remote, -image identified by the image_index. - -@item @emph{Syntax}: -@code{void _gfortran_caf_get (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, bool may_require_tmp, -int *stat)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{token} @tab intent(in) An opaque pointer identifying the coarray. -@item @var{offset} @tab intent(in) The number of bytes the actual data is -shifted compared to the base address of the coarray. -@item @var{image_index} @tab intent(in) The ID of the remote image; must be a -positive number. -@item @var{dest} @tab intent(out) Array descriptor of the local array to store -the data retrieved from the remote image -@item @var{src} @tab intent(in) Array descriptor for the remote image for the -bounds and the size. The @code{base_addr} shall not be accessed. -@item @var{src_vector} @tab intent(in) If not NULL, it contains the vector -subscript of the source array; the values are relative to the dimension -triplet of the @var{src} argument. -@item @var{dst_kind} @tab intent(in) Kind of the destination argument -@item @var{src_kind} @tab intent(in) Kind of the source argument -@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when -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 elementwise order (honoring the stride value) does not -lead to wrong results. Otherwise, the value is @code{true}. -@item @var{stat} @tab intent(out) When non-NULL give the result of the -operation, i.e., zero on success and nonzero on error. When NULL and an error -occurs, then an error message is printed and the program is terminated. -@end multitable - -@item @emph{NOTES} -It is permitted to have @var{image_index} 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, 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 - - -@node _gfortran_caf_sendget -@subsection @code{_gfortran_caf_sendget} --- Sending data between remote images -@cindex Coarray, _gfortran_caf_sendget - -@table @asis -@item @emph{Description}: -Called to send a scalar, an array section or a whole array from a remote image -identified by the @var{src_image_index} to a remote image identified by the -@var{dst_image_index}. - -@item @emph{Syntax}: -@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, -bool may_require_tmp, int *stat)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{dst_token} @tab intent(in) An opaque pointer identifying the -destination coarray. -@item @var{dst_offset} @tab intent(in) The number of bytes the actual data -is shifted compared to the base address of the destination coarray. -@item @var{dst_image_index} @tab intent(in) The ID of the destination remote -image; must be a positive number. -@item @var{dest} @tab intent(in) Array descriptor for the destination -remote image for the bounds and the size. The @code{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 -triplet of the @var{dest} argument. -@item @var{src_token} @tab intent(in) An opaque pointer identifying the source -coarray. -@item @var{src_offset} @tab intent(in) The number of bytes the actual data -is shifted compared to the base address of the source coarray. -@item @var{src_image_index} @tab intent(in) The ID of the source remote image; -must be a positive number. -@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 intent(in) Kind of the destination argument -@item @var{src_kind} @tab intent(in) Kind of the source argument -@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when -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 elementwise order (honoring the stride value) does not -lead to wrong results. Otherwise, the value is @code{true}. -@item @var{stat} @tab intent(out) when non-NULL give the result of the -operation, i.e., zero on success and nonzero on error. When NULL and an error -occurs, then an error message is printed and the program is terminated. -@end multitable - -@item @emph{NOTES} -It is permitted to have the same image index for both @var{src_image_index} and -@var{dst_image_index}; 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 - -@node _gfortran_caf_send_by_ref -@subsection @code{_gfortran_caf_send_by_ref} --- Sending data from a local image to a remote image with enhanced referencing options -@cindex Coarray, _gfortran_caf_send_by_ref - -@table @asis -@item @emph{Description}: -Called to send a scalar, an array section or a whole array from a local to a -remote image identified by the @var{image_index}. - -@item @emph{Syntax}: -@code{void _gfortran_caf_send_by_ref (caf_token_t token, int image_index, -gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, int src_kind, -bool may_require_tmp, bool dst_reallocatable, int *stat, int dst_type)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{token} @tab intent(in) An opaque pointer identifying the coarray. -@item @var{image_index} @tab intent(in) The ID of the remote image; must be a -positive number. -@item @var{src} @tab intent(in) Array descriptor of the local array to be -transferred to the remote image -@item @var{refs} @tab intent(in) The references on the remote array to store -the data given by src. Guaranteed to have at least one entry. -@item @var{dst_kind} @tab intent(in) Kind of the destination argument -@item @var{src_kind} @tab intent(in) Kind of the source argument -@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when -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 elementwise order (honoring the stride value) does not -lead to wrong results. Otherwise, the value is @code{true}. -@item @var{dst_reallocatable} @tab intent(in) Set when the destination is of -allocatable or pointer type and the refs allow reallocation, i.e., the ref -is a full array or component ref. -@item @var{stat} @tab intent(out) When non-@code{NULL} give the result of the -operation, i.e., zero on success and nonzero on error. When @code{NULL} and -an error occurs, then an error message is printed and the program is terminated. -@item @var{dst_type} @tab intent(in) Give the type of the destination. When -the destination is not an array, than the precise type, e.g. of a component in -a derived type, is not known, but provided here. -@end multitable - -@item @emph{NOTES} -It is permitted to have @var{image_index} 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, 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. - -Because of the more complicated references possible some operations may be -unsupported by certain libraries. The library is expected to issue a precise -error message why the operation is not permitted. -@end table - - -@node _gfortran_caf_get_by_ref -@subsection @code{_gfortran_caf_get_by_ref} --- Getting data from a remote image using enhanced references -@cindex Coarray, _gfortran_caf_get_by_ref - -@table @asis -@item @emph{Description}: -Called to get a scalar, an array section or a whole array from a remote image -identified by the @var{image_index}. - -@item @emph{Syntax}: -@code{void _gfortran_caf_get_by_ref (caf_token_t token, int image_index, -caf_reference_t *refs, gfc_descriptor_t *dst, int dst_kind, int src_kind, -bool may_require_tmp, bool dst_reallocatable, int *stat, int src_type)} - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{token} @tab intent(in) An opaque pointer identifying the coarray. -@item @var{image_index} @tab intent(in) The ID of the remote image; must be a -positive number. -@item @var{refs} @tab intent(in) The references to apply to the remote structure -to get the data. -@item @var{dst} @tab intent(in) Array descriptor of the local array to store -the data transferred from the remote image. May be reallocated where needed -and when @var{DST_REALLOCATABLE} allows it. -@item @var{dst_kind} @tab intent(in) Kind of the destination argument -@item @var{src_kind} @tab intent(in) Kind of the source argument -@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when -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 elementwise order (honoring the stride value) does not -lead to wrong results. Otherwise, the value is @code{true}. -@item @var{dst_reallocatable} @tab intent(in) Set when @var{DST} is of -allocatable or pointer type and its refs allow reallocation, i.e., the full -array or a component is referenced. -@item @var{stat} @tab intent(out) When non-@code{NULL} give the result of the -operation, i.e., zero on success and nonzero on error. When @code{NULL} and an -error occurs, then an error message is printed and the program is terminated. -@item @var{src_type} @tab intent(in) Give the type of the source. When the -source is not an array, than the precise type, e.g. of a component in a -derived type, is not known, but provided here. -@end multitable - -@item @emph{NOTES} -It is permitted to have @code{image_index} 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, 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. - -Because of the more complicated references possible some operations may be -unsupported by certain libraries. The library is expected to issue a precise -error message why the operation is not permitted. -@end table - - @node _gfortran_caf_get_from_remote @subsection @code{_gfortran_caf_get_from_remote} --- Getting data from a remote image using a remote side accessor @cindex Coarray, _gfortran_caf_get_from_remote diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 025ad539d25..893eac07c76 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -135,22 +135,12 @@ tree gfor_fndecl_caf_this_image; tree gfor_fndecl_caf_num_images; tree gfor_fndecl_caf_register; tree gfor_fndecl_caf_deregister; - -// Deprecate start -tree gfor_fndecl_caf_get; -tree gfor_fndecl_caf_send; -tree gfor_fndecl_caf_sendget; -tree gfor_fndecl_caf_send_by_ref; -tree gfor_fndecl_caf_sendget_by_ref; -// Deprecate end - tree gfor_fndecl_caf_register_accessor; tree gfor_fndecl_caf_register_accessors_finish; tree gfor_fndecl_caf_get_remote_function_index; tree gfor_fndecl_caf_get_from_remote; tree gfor_fndecl_caf_send_to_remote; tree gfor_fndecl_caf_transfer_between_remotes; - tree gfor_fndecl_caf_sync_all; tree gfor_fndecl_caf_sync_memory; tree gfor_fndecl_caf_sync_images; @@ -4073,45 +4063,6 @@ gfc_build_builtin_function_decls (void) ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, size_type_node); - // Deprecate start - gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ", - void_type_node, 10, - pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type); - - gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send")), ". r . . w r r . . . w ", - void_type_node, 11, - pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type, pvoid_type_node); - - gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sendget")), ". r . . w r r . . r r . . . w ", - void_type_node, 14, 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, boolean_type_node, integer_type_node); - - gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send_by_ref")), ". r . r r . . . . w . ", - void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, boolean_type_node, pint_type, integer_type_node); - - gfor_fndecl_caf_sendget_by_ref - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sendget_by_ref")), - ". r . r r . r . . . w w . . ", - void_type_node, 13, pvoid_type_node, integer_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, - pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type, pint_type, integer_type_node, - integer_type_node); - // Deprecate end - gfor_fndecl_caf_register_accessor = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX ("caf_register_accessor")), ". r r ", diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 84f18a533a9..2c4c47816c8 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -1025,653 +1025,6 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) } -/* Fill in the following structure - struct caf_vector_t { - size_t nvec; // size of the vector - union { - struct { - void *vector; - int kind; - } v; - struct { - ptrdiff_t lower_bound; - ptrdiff_t upper_bound; - ptrdiff_t stride; - } triplet; - } u; - } */ - -// static void -// conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc, -// tree lower, tree upper, tree stride, -// tree vector, int kind, tree nvec) -// { -// tree field, type, tmp; - -// desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE); -// type = TREE_TYPE (desc); - -// field = gfc_advance_chain (TYPE_FIELDS (type), 0); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), -// desc, field, NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec)); - -// /* Access union. */ -// field = gfc_advance_chain (TYPE_FIELDS (type), 1); -// desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), -// desc, field, NULL_TREE); -// type = TREE_TYPE (desc); - -// /* Access the inner struct. */ -// field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : -// 1); desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// desc, field, NULL_TREE); -// type = TREE_TYPE (desc); - -// if (vector != NULL_TREE) -// { -// /* Set vector and kind. */ -// field = gfc_advance_chain (TYPE_FIELDS (type), 0); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// desc, field, NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector)); -// field = gfc_advance_chain (TYPE_FIELDS (type), 1); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// desc, field, NULL_TREE); -// gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind)); -// } -// else -// { -// /* Set dim.lower/upper/stride. */ -// field = gfc_advance_chain (TYPE_FIELDS (type), 0); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// desc, field, NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower)); - -// field = gfc_advance_chain (TYPE_FIELDS (type), 1); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// desc, field, NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper)); - -// field = gfc_advance_chain (TYPE_FIELDS (type), 2); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// desc, field, NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride)); -// } -// } - -// static tree -// conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar) -// { -// gfc_se argse; -// tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec; -// tree lbound, ubound, tmp; -// int i; - -// var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector"); - -// for (i = 0; i < ar->dimen; i++) -// switch (ar->dimen_type[i]) -// { -// case DIMEN_RANGE: -// if (ar->end[i]) -// { -// gfc_init_se (&argse, NULL); -// gfc_conv_expr (&argse, ar->end[i]); -// gfc_add_block_to_block (block, &argse.pre); -// upper = gfc_evaluate_now (argse.expr, block); -// } -// else -// upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); -// if (ar->stride[i]) -// { -// gfc_init_se (&argse, NULL); -// gfc_conv_expr (&argse, ar->stride[i]); -// gfc_add_block_to_block (block, &argse.pre); -// stride = gfc_evaluate_now (argse.expr, block); -// } -// else -// stride = gfc_index_one_node; - -// /* Fall through. */ -// case DIMEN_ELEMENT: -// if (ar->start[i]) -// { -// gfc_init_se (&argse, NULL); -// gfc_conv_expr (&argse, ar->start[i]); -// gfc_add_block_to_block (block, &argse.pre); -// lower = gfc_evaluate_now (argse.expr, block); -// } -// else -// lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); -// if (ar->dimen_type[i] == DIMEN_ELEMENT) -// { -// upper = lower; -// stride = gfc_index_one_node; -// } -// vector = NULL_TREE; -// nvec = size_zero_node; -// conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, -// vector, 0, nvec); -// break; - -// case DIMEN_VECTOR: -// gfc_init_se (&argse, NULL); -// argse.descriptor_only = 1; -// gfc_conv_expr_descriptor (&argse, ar->start[i]); -// gfc_add_block_to_block (block, &argse.pre); -// vector = argse.expr; -// lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]); -// ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]); -// nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL); -// tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]); -// nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR, -// TREE_TYPE (nvec), nvec, tmp); -// lower = gfc_index_zero_node; -// upper = gfc_index_zero_node; -// stride = gfc_index_zero_node; -// vector = gfc_conv_descriptor_data_get (vector); -// conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, -// vector, ar->start[i]->ts.kind, nvec); -// break; -// default: -// gcc_unreachable(); -// } -// return gfc_build_addr_expr (NULL_TREE, var); -// } - -// static tree -// compute_component_offset (tree field, tree type) -// { -// tree tmp; -// if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE -// && !integer_zerop (DECL_FIELD_BIT_OFFSET (field))) -// { -// tmp = fold_build2 (TRUNC_DIV_EXPR, type, -// DECL_FIELD_BIT_OFFSET (field), -// bitsize_unit_node); -// return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp); -// } -// else -// return DECL_FIELD_OFFSET (field); -// } - -// static tree -// conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr) -// { -// gfc_ref *ref = expr->ref, *last_comp_ref; -// tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, -// tmp2, -// field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, -// dim_type, start, end, stride, vector, nvec; -// gfc_se se; -// bool ref_static_array = false; -// tree last_component_ref_tree = NULL_TREE; -// int i, last_type_n; - -// if (expr->symtree) -// { -// last_component_ref_tree = expr->symtree->n.sym->backend_decl; -// ref_static_array = !expr->symtree->n.sym->attr.allocatable -// && !expr->symtree->n.sym->attr.pointer; -// } - -// /* Prevent uninit-warning. */ -// reference_type = NULL_TREE; - -// /* Skip refs upto the first coarray-ref. */ -// last_comp_ref = NULL; -// while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0)) -// { -// /* Remember the type of components skipped. */ -// if (ref->type == REF_COMPONENT) -// last_comp_ref = ref; -// ref = ref->next; -// } -// /* When a component was skipped, get the type information of the last -// component ref, else get the type from the symbol. */ -// if (last_comp_ref) -// { -// last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts); -// last_type_n = last_comp_ref->u.c.component->ts.type; -// } -// else -// { -// last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts); -// last_type_n = expr->symtree->n.sym->ts.type; -// } - -// while (ref) -// { -// if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0 -// && ref->u.ar.dimen == 0) -// { -// /* Skip pure coindexes. */ -// ref = ref->next; -// continue; -// } -// tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref"); -// reference_type = TREE_TYPE (tmp); - -// if (caf_ref == NULL_TREE) -// caf_ref = tmp; - -// /* Construct the chain of refs. */ -// if (prev_caf_ref != NULL_TREE) -// { -// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0); -// tmp2 = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), prev_caf_ref, field, -// NULL_TREE); -// gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field), -// tmp)); -// } -// prev_caf_ref = tmp; - -// switch (ref->type) -// { -// case REF_COMPONENT: -// last_type = gfc_typenode_for_spec (&ref->u.c.component->ts); -// last_type_n = ref->u.c.component->ts.type; -// /* Set the type of the ref. */ -// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), prev_caf_ref, field, -// NULL_TREE); -// gfc_add_modify (block, tmp, build_int_cst (integer_type_node, -// GFC_CAF_REF_COMPONENT)); - -// /* Ref the c in union u. */ -// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), prev_caf_ref, field, -// NULL_TREE); -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0); -// inner_struct = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); - -// /* Set the offset. */ -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), inner_struct, field, -// NULL_TREE); -// /* Computing the offset is somewhat harder. The bit_offset has to be -// taken into account. When the bit_offset in the field_decl is non- -// null, divide it by the bitsize_unit and add it to the regular -// offset. */ -// tmp2 = compute_component_offset (ref->u.c.component->backend_decl, -// TREE_TYPE (tmp)); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); - -// /* Set caf_token_offset. */ -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), inner_struct, field, -// NULL_TREE); -// if ((ref->u.c.component->attr.allocatable -// || ref->u.c.component->attr.pointer) -// && ref->u.c.component->attr.dimension) -// { -// tree arr_desc_token_offset; -// /* Get the token field from the descriptor. */ -// arr_desc_token_offset = TREE_OPERAND ( -// gfc_conv_descriptor_token -// (ref->u.c.component->backend_decl), 1); arr_desc_token_offset -// = compute_component_offset (arr_desc_token_offset, -// TREE_TYPE (tmp)); tmp2 = fold_build2_loc (input_location, PLUS_EXPR, -// TREE_TYPE (tmp2), tmp2, arr_desc_token_offset); -// } -// else if (ref->u.c.component->caf_token) -// tmp2 = compute_component_offset (gfc_comp_caf_token ( -// ref->u.c.component), -// TREE_TYPE (tmp)); -// else -// tmp2 = integer_zero_node; -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); - -// /* Remember whether this ref was to a non-allocatable/non-pointer -// component so the next array ref can be tailored correctly. */ -// ref_static_array = !ref->u.c.component->attr.allocatable -// && !ref->u.c.component->attr.pointer; -// last_component_ref_tree = ref_static_array -// ? ref->u.c.component->backend_decl : NULL_TREE; -// break; -// case REF_ARRAY: -// if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED) -// ref_static_array = false; -// /* Set the type of the ref. */ -// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), prev_caf_ref, field, -// NULL_TREE); -// gfc_add_modify (block, tmp, build_int_cst (integer_type_node, -// ref_static_array -// ? GFC_CAF_REF_STATIC_ARRAY -// : GFC_CAF_REF_ARRAY)); - -// /* Ref the a in union u. */ -// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), prev_caf_ref, field, -// NULL_TREE); -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1); -// inner_struct = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); - -// /* Set the static_array_type in a for static arrays. */ -// if (ref_static_array) -// { -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), -// 1); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), inner_struct, field, -// NULL_TREE); -// gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp), -// last_type_n)); -// } -// /* Ref the mode in the inner_struct. */ -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0); -// mode = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), inner_struct, field, -// NULL_TREE); -// /* Ref the dim in the inner_struct. */ -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2); -// dim_array = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), inner_struct, field, -// NULL_TREE); -// for (i = 0; i < ref->u.ar.dimen; ++i) -// { -// /* Ref dim i. */ -// dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE); -// dim_type = TREE_TYPE (dim); -// mode_rhs = start = end = stride = NULL_TREE; -// switch (ref->u.ar.dimen_type[i]) -// { -// case DIMEN_RANGE: -// if (ref->u.ar.end[i]) -// { -// gfc_init_se (&se, NULL); -// gfc_conv_expr (&se, ref->u.ar.end[i]); -// gfc_add_block_to_block (block, &se.pre); -// if (ref_static_array) -// { -// /* Make the index zero-based, when reffing a static -// array. */ -// end = se.expr; -// gfc_init_se (&se, NULL); -// gfc_conv_expr (&se, ref->u.ar.as->lower[i]); -// gfc_add_block_to_block (block, &se.pre); -// se.expr = fold_build2 (MINUS_EXPR, -// gfc_array_index_type, -// end, fold_convert ( -// gfc_array_index_type, -// se.expr)); -// } -// end = gfc_evaluate_now (fold_convert ( -// gfc_array_index_type, -// se.expr), -// block); -// } -// else if (ref_static_array) -// end = fold_build2 (MINUS_EXPR, -// gfc_array_index_type, -// gfc_conv_array_ubound ( -// last_component_ref_tree, i), -// gfc_conv_array_lbound ( -// last_component_ref_tree, i)); -// else -// { -// end = NULL_TREE; -// mode_rhs = build_int_cst (unsigned_char_type_node, -// GFC_CAF_ARR_REF_OPEN_END); -// } -// if (ref->u.ar.stride[i]) -// { -// gfc_init_se (&se, NULL); -// gfc_conv_expr (&se, ref->u.ar.stride[i]); -// gfc_add_block_to_block (block, &se.pre); -// stride = gfc_evaluate_now (fold_convert ( -// gfc_array_index_type, -// se.expr), -// block); -// if (ref_static_array) -// { -// /* Make the index zero-based, when reffing a static -// array. */ -// stride = fold_build2 (MULT_EXPR, -// gfc_array_index_type, -// gfc_conv_array_stride ( -// last_component_ref_tree, -// i), -// stride); -// gcc_assert (end != NULL_TREE); -// /* Multiply with the product of array's stride and -// the step of the ref to a virtual upper bound. -// We cannot compute the actual upper bound here or -// the caflib would compute the extend -// incorrectly. */ -// end = fold_build2 (MULT_EXPR, gfc_array_index_type, -// end, gfc_conv_array_stride ( -// last_component_ref_tree, -// i)); -// end = gfc_evaluate_now (end, block); -// stride = gfc_evaluate_now (stride, block); -// } -// } -// else if (ref_static_array) -// { -// stride = gfc_conv_array_stride (last_component_ref_tree, -// i); -// end = fold_build2 (MULT_EXPR, gfc_array_index_type, -// end, stride); -// end = gfc_evaluate_now (end, block); -// } -// else -// /* Always set a ref stride of one to make caflib's -// handling easier. */ -// stride = gfc_index_one_node; - -// /* Fall through. */ -// case DIMEN_ELEMENT: -// if (ref->u.ar.start[i]) -// { -// gfc_init_se (&se, NULL); -// gfc_conv_expr (&se, ref->u.ar.start[i]); -// gfc_add_block_to_block (block, &se.pre); -// if (ref_static_array) -// { -// /* Make the index zero-based, when reffing a static -// array. */ -// start = fold_convert (gfc_array_index_type, se.expr); -// gfc_init_se (&se, NULL); -// gfc_conv_expr (&se, ref->u.ar.as->lower[i]); -// gfc_add_block_to_block (block, &se.pre); -// se.expr = fold_build2 (MINUS_EXPR, -// gfc_array_index_type, -// start, fold_convert ( -// gfc_array_index_type, -// se.expr)); -// /* Multiply with the stride. */ -// se.expr = fold_build2 (MULT_EXPR, -// gfc_array_index_type, -// se.expr, -// gfc_conv_array_stride ( -// last_component_ref_tree, -// i)); -// } -// start = gfc_evaluate_now (fold_convert ( -// gfc_array_index_type, -// se.expr), -// block); -// if (mode_rhs == NULL_TREE) -// mode_rhs = build_int_cst (unsigned_char_type_node, -// ref->u.ar.dimen_type[i] -// == DIMEN_ELEMENT -// ? GFC_CAF_ARR_REF_SINGLE -// : GFC_CAF_ARR_REF_RANGE); -// } -// else if (ref_static_array) -// { -// start = integer_zero_node; -// mode_rhs = build_int_cst (unsigned_char_type_node, -// ref->u.ar.start[i] == NULL -// ? GFC_CAF_ARR_REF_FULL -// : GFC_CAF_ARR_REF_RANGE); -// } -// else if (end == NULL_TREE) -// mode_rhs = build_int_cst (unsigned_char_type_node, -// GFC_CAF_ARR_REF_FULL); -// else -// mode_rhs = build_int_cst (unsigned_char_type_node, -// GFC_CAF_ARR_REF_OPEN_START); - -// /* Ref the s in dim. */ -// field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), dim, field, -// NULL_TREE); - -// /* Set start in s. */ -// if (start != NULL_TREE) -// { -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), -// 0); -// tmp2 = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); -// gfc_add_modify (block, tmp2, -// fold_convert (TREE_TYPE (tmp2), start)); -// } - -// /* Set end in s. */ -// if (end != NULL_TREE) -// { -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), -// 1); -// tmp2 = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); -// gfc_add_modify (block, tmp2, -// fold_convert (TREE_TYPE (tmp2), end)); -// } - -// /* Set end in s. */ -// if (stride != NULL_TREE) -// { -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), -// 2); -// tmp2 = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); -// gfc_add_modify (block, tmp2, -// fold_convert (TREE_TYPE (tmp2), stride)); -// } -// break; -// case DIMEN_VECTOR: -// /* TODO: In case of static array. */ -// gcc_assert (!ref_static_array); -// mode_rhs = build_int_cst (unsigned_char_type_node, -// GFC_CAF_ARR_REF_VECTOR); -// gfc_init_se (&se, NULL); -// se.descriptor_only = 1; -// gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]); -// gfc_add_block_to_block (block, &se.pre); -// vector = se.expr; -// tmp = gfc_conv_descriptor_lbound_get (vector, -// gfc_rank_cst[0]); -// tmp2 = gfc_conv_descriptor_ubound_get (vector, -// gfc_rank_cst[0]); -// nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL); -// tmp = gfc_conv_descriptor_stride_get (vector, -// gfc_rank_cst[0]); -// nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR, -// TREE_TYPE (nvec), nvec, tmp); -// vector = gfc_conv_descriptor_data_get (vector); - -// /* Ref the v in dim. */ -// field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), dim, field, -// NULL_TREE); - -// /* Set vector in v. */ -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0); -// tmp2 = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); -// gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2), -// vector)); - -// /* Set nvec in v. */ -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1); -// tmp2 = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); -// gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2), -// nvec)); - -// /* Set kind in v. */ -// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2); -// tmp2 = fold_build3_loc (input_location, COMPONENT_REF, -// TREE_TYPE (field), tmp, field, -// NULL_TREE); -// gfc_add_modify (block, tmp2, build_int_cst (integer_type_node, -// ref->u.ar.start[i]->ts.kind)); -// break; -// default: -// gcc_unreachable (); -// } -// /* Set the mode for dim i. */ -// tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), -// mode_rhs)); -// } - -// /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */ -// if (i < GFC_MAX_DIMENSIONS) -// { -// tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE); -// gfc_add_modify (block, tmp, -// build_int_cst (unsigned_char_type_node, -// GFC_CAF_ARR_REF_NONE)); -// } -// break; -// default: -// gcc_unreachable (); -// } - -// /* Set the size of the current type. */ -// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// prev_caf_ref, field, NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), -// TYPE_SIZE_UNIT (last_type))); - -// ref = ref->next; -// } - -// if (prev_caf_ref != NULL_TREE) -// { -// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0); -// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE -// (field), -// prev_caf_ref, field, NULL_TREE); -// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), -// null_pointer_node)); -// } -// return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref) -// : NULL_TREE; -// } - static int caf_call_cnt = 0; static tree @@ -2202,15 +1555,6 @@ conv_caf_send_to_remote (gfc_code *code) return gfc_finish_block (&block); } -// static bool -// has_ref_after_cafref (gfc_expr *expr) -// { -// for (gfc_ref *ref = expr->ref; ref; ref = ref->next) -// if (ref->type == REF_ARRAY && ref->u.ar.codimen) -// return ref->next; -// return false; -// } - /* Send-get data to a remote coarray. */ static tree @@ -2436,450 +1780,6 @@ conv_caf_sendget (gfc_code *code) return gfc_finish_block (&block); } -// static tree -// conv_caf_sendget (gfc_code *code) -// { -// gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team; -// 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, src_stat, dst_stat, dst_team; -// tree lhs_type = NULL_TREE; -// tree vec = null_pointer_node, rhs_vec = null_pointer_node; -// symbol_attribute lhs_caf_attr, rhs_caf_attr; -// bool lhs_is_coindexed, rhs_is_coindexed; - -// gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); - -// lhs_expr -// = code->ext.actual->expr->expr_type == EXPR_FUNCTION -// && code->ext.actual->expr->value.function.isym->id == GFC_ISYM_CAF_GET -// ? code->ext.actual->expr->value.function.actual->expr -// : code->ext.actual->expr; -// rhs_expr = code->ext.actual->next->expr->expr_type == EXPR_FUNCTION -// && code->ext.actual->next->expr->value.function.isym->id -// == GFC_ISYM_CAF_GET -// ? code->ext.actual->next->expr->value.function.actual->expr -// : code->ext.actual->next->expr; -// lhs_is_coindexed = gfc_is_coindexed (lhs_expr); -// rhs_is_coindexed = gfc_is_coindexed (rhs_expr); -// may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0 -// ? boolean_false_node : boolean_true_node; -// gfc_init_block (&block); - -// lhs_caf_attr = gfc_caf_attr (lhs_expr); -// rhs_caf_attr = gfc_caf_attr (rhs_expr); -// src_stat = dst_stat = null_pointer_node; -// dst_team = null_pointer_node; - -// /* LHS. */ -// gfc_init_se (&lhs_se, NULL); -// if (lhs_expr->rank == 0) -// { -// if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred) -// { -// lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr); -// if (!POINTER_TYPE_P (TREE_TYPE (lhs_se.expr))) -// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); -// } -// else -// { -// symbol_attribute attr; -// gfc_clear_attr (&attr); -// gfc_conv_expr (&lhs_se, lhs_expr); -// lhs_type = TREE_TYPE (lhs_se.expr); -// if (lhs_is_coindexed) -// lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, -// attr); -// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); -// } -// } -// else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp) -// && lhs_caf_attr.codimension) -// { -// lhs_se.want_pointer = 1; -// gfc_conv_expr_descriptor (&lhs_se, lhs_expr); -// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that -// has the wrong type if component references are done. */ -// lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); -// tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); -// gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), -// gfc_get_dtype_rank_type ( -// gfc_has_vector_subscript (lhs_expr) -// ? gfc_find_array_ref (lhs_expr)->dimen -// : lhs_expr->rank, -// lhs_type)); -// } -// else -// { -// bool has_vector = gfc_has_vector_subscript (lhs_expr); - -// if (lhs_is_coindexed || !has_vector) -// { -// /* If has_vector, pass descriptor for whole array and the -// vector bounds separately. */ -// gfc_array_ref *ar, ar2; -// bool has_tmp_lhs_array = false; -// if (has_vector) -// { -// has_tmp_lhs_array = true; -// ar = gfc_find_array_ref (lhs_expr); -// ar2 = *ar; -// memset (ar, '\0', sizeof (*ar)); -// ar->as = ar2.as; -// ar->type = AR_FULL; -// } -// lhs_se.want_pointer = 1; -// gfc_conv_expr_descriptor (&lhs_se, lhs_expr); -// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but -// that has the wrong type if component references are done. */ -// lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); -// tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); -// gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), -// gfc_get_dtype_rank_type (has_vector ? ar2.dimen -// : lhs_expr->rank, -// lhs_type)); -// if (has_tmp_lhs_array) -// { -// vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2); -// *ar = ar2; -// } -// } -// else if (rhs_is_coindexed) -// { -// /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to -// indexed array expression. This is rewritten to: - -// tmp_array = arr2[...] -// arr1 ([...]) = tmp_array - -// because using the standard gfc_conv_expr (lhs_expr) did the -// assignment with lhs and rhs exchanged. */ - -// gfc_ss *lss_for_tmparray, *lss_real; -// gfc_loopinfo loop; -// gfc_se se; -// stmtblock_t body; -// tree tmparr_desc, src; -// tree index = gfc_index_zero_node; -// tree stride = gfc_index_zero_node; -// int n; - -// /* Walk both sides of the assignment, once to get the shape of the -// temporary array to create right. */ -// lss_for_tmparray = gfc_walk_expr (lhs_expr); -// /* And a second time to be able to create an assignment of the -// temporary to the lhs_expr. gfc_trans_create_temp_array replaces -// the tree in the descriptor with the one for the temporary -// array. */ -// lss_real = gfc_walk_expr (lhs_expr); -// gfc_init_loopinfo (&loop); -// gfc_add_ss_to_loop (&loop, lss_for_tmparray); -// gfc_add_ss_to_loop (&loop, lss_real); -// gfc_conv_ss_startstride (&loop); -// gfc_conv_loop_setup (&loop, &lhs_expr->where); -// lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); -// gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post, -// lss_for_tmparray, lhs_type, NULL_TREE, -// false, true, false, -// &lhs_expr->where); -// tmparr_desc = lss_for_tmparray->info->data.array.descriptor; -// gfc_start_scalarized_body (&loop, &body); -// gfc_init_se (&se, NULL); -// gfc_copy_loopinfo_to_se (&se, &loop); -// se.ss = lss_real; -// gfc_conv_expr (&se, lhs_expr); -// gfc_add_block_to_block (&body, &se.pre); - -// /* Walk over all indexes of the loop. */ -// for (n = loop.dimen - 1; n > 0; --n) -// { -// tmp = loop.loopvar[n]; -// tmp = fold_build2_loc (input_location, MINUS_EXPR, -// gfc_array_index_type, tmp, loop.from[n]); -// tmp = fold_build2_loc (input_location, PLUS_EXPR, -// gfc_array_index_type, tmp, index); - -// stride = fold_build2_loc (input_location, MINUS_EXPR, -// gfc_array_index_type, -// loop.to[n - 1], loop.from[n - 1]); -// stride = fold_build2_loc (input_location, PLUS_EXPR, -// gfc_array_index_type, -// stride, gfc_index_one_node); - -// index = fold_build2_loc (input_location, MULT_EXPR, -// gfc_array_index_type, tmp, stride); -// } - -// index = fold_build2_loc (input_location, MINUS_EXPR, -// gfc_array_index_type, -// index, loop.from[0]); - -// index = fold_build2_loc (input_location, PLUS_EXPR, -// gfc_array_index_type, -// loop.loopvar[0], index); - -// src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc)); -// src = gfc_build_array_ref (src, index, NULL); -// /* Now create the assignment of lhs_expr = tmp_array. */ -// gfc_add_modify (&body, se.expr, src); -// gfc_add_block_to_block (&body, &se.post); -// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc); -// gfc_trans_scalarizing_loops (&loop, &body); -// gfc_add_block_to_block (&loop.pre, &loop.post); -// gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre)); -// gfc_free_ss (lss_for_tmparray); -// gfc_free_ss (lss_real); -// } -// } - -// lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind); - -// /* Special case: RHS is a coarray but LHS is not; this code path avoids a -// temporary and a loop. */ -// if (!lhs_is_coindexed && rhs_is_coindexed -// && (!lhs_caf_attr.codimension -// || !(lhs_expr->rank > 0 -// && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer)))) -// { -// bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable; -// gfc_init_se (&rhs_se, NULL); -// if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable) -// { -// gfc_se scal_se; -// gfc_init_se (&scal_se, NULL); -// scal_se.want_pointer = 1; -// gfc_conv_expr (&scal_se, lhs_expr); -// /* Ensure scalar on lhs is allocated. */ -// gfc_add_block_to_block (&block, &scal_se.pre); - -// gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr, -// TYPE_SIZE_UNIT ( -// gfc_typenode_for_spec (&lhs_expr->ts)), -// NULL_TREE); -// tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr, -// null_pointer_node); -// tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, -// tmp, gfc_finish_block (&scal_se.pre), -// build_empty_stmt (input_location)); -// gfc_add_expr_to_block (&block, tmp); -// } -// else -// lhs_may_realloc = lhs_may_realloc -// && gfc_full_array_ref_p (lhs_expr->ref, NULL); -// gfc_add_block_to_block (&block, &lhs_se.pre); -// gfc_conv_intrinsic_caf_get (&rhs_se, code->ext.actual->next->expr, -// lhs_se.expr, lhs_may_realloc, &rhs_caf_attr); -// 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); -// return gfc_finish_block (&block); -// } - -// gfc_add_block_to_block (&block, &lhs_se.pre); - -// /* Obtain token, offset and image index for the LHS. */ -// caf_decl = gfc_get_tree_for_caf_expr (lhs_expr); -// if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) -// caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); -// image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl); -// tmp = lhs_se.expr; -// if (lhs_caf_attr.alloc_comp) -// gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE, -// NULL); -// else -// gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp, -// lhs_expr); -// lhs_se.expr = tmp; - -// /* RHS. */ -// gfc_init_se (&rhs_se, NULL); -// if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym -// && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION) -// rhs_expr = rhs_expr->value.function.actual->expr; -// if (rhs_expr->rank == 0) -// { -// symbol_attribute attr; -// gfc_clear_attr (&attr); -// gfc_conv_expr (&rhs_se, rhs_expr); -// rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, -// attr); rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr); -// } -// else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp) -// && rhs_caf_attr.codimension) -// { -// tree tmp2; -// rhs_se.want_pointer = 1; -// gfc_conv_expr_descriptor (&rhs_se, rhs_expr); -// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that -// has the wrong type if component references are done. */ -// tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); -// tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); -// gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), -// gfc_get_dtype_rank_type ( -// gfc_has_vector_subscript (rhs_expr) -// ? gfc_find_array_ref (rhs_expr)->dimen -// : rhs_expr->rank, -// tmp2)); -// } -// else -// { -// /* If has_vector, pass descriptor for whole array and the -// vector bounds separately. */ -// gfc_array_ref *ar, ar2; -// bool has_vector = false; -// tree tmp2; - -// if (rhs_is_coindexed && gfc_has_vector_subscript (rhs_expr)) -// { -// has_vector = true; -// ar = gfc_find_array_ref (rhs_expr); -// ar2 = *ar; -// memset (ar, '\0', sizeof (*ar)); -// ar->as = ar2.as; -// ar->type = AR_FULL; -// } -// rhs_se.want_pointer = 1; -// gfc_conv_expr_descriptor (&rhs_se, rhs_expr); -// /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that -// has the wrong type if component references are done. */ -// tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); -// tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); -// gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), -// gfc_get_dtype_rank_type (has_vector ? ar2.dimen -// : rhs_expr->rank, -// tmp2)); -// if (has_vector) -// { -// rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2); -// *ar = ar2; -// } -// } - -// gfc_add_block_to_block (&block, &rhs_se.pre); - -// rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind); - -// tmp_stat = gfc_find_stat_co (lhs_expr); - -// if (tmp_stat) -// { -// gfc_se stat_se; -// gfc_init_se (&stat_se, NULL); -// gfc_conv_expr_reference (&stat_se, tmp_stat); -// dst_stat = stat_se.expr; -// gfc_add_block_to_block (&block, &stat_se.pre); -// gfc_add_block_to_block (&block, &stat_se.post); -// } - -// tmp_team = gfc_find_team_co (lhs_expr); - -// if (tmp_team) -// { -// gfc_se team_se; -// gfc_init_se (&team_se, NULL); -// gfc_conv_expr_reference (&team_se, tmp_team); -// dst_team = team_se.expr; -// gfc_add_block_to_block (&block, &team_se.pre); -// gfc_add_block_to_block (&block, &team_se.post); -// } - -// if (!rhs_is_coindexed) -// { -// if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp -// || has_ref_after_cafref (lhs_expr)) -// { -// tree reference, dst_realloc; -// reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); -// dst_realloc -// = lhs_caf_attr.allocatable ? boolean_true_node : boolean_false_node; -// tmp = build_call_expr_loc (input_location, -// gfor_fndecl_caf_send_by_ref, -// 10, token, image_index, rhs_se.expr, -// reference, lhs_kind, rhs_kind, -// may_require_tmp, dst_realloc, src_stat, -// build_int_cst (integer_type_node, -// lhs_expr->ts.type)); -// } -// else -// tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11, -// token, offset, image_index, lhs_se.expr, vec, -// rhs_se.expr, lhs_kind, rhs_kind, -// may_require_tmp, src_stat, dst_team); -// } -// else -// { -// tree rhs_token, rhs_offset, rhs_image_index; - -// /* It guarantees memory consistency within the same segment. */ -// tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); -// tmp = build5_loc (input_location, ASM_EXPR, void_type_node, -// gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, -// tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); -// ASM_VOLATILE_P (tmp) = 1; -// gfc_add_expr_to_block (&block, tmp); - -// caf_decl = gfc_get_tree_for_caf_expr (rhs_expr); -// if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) -// caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); -// rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl); -// tmp = rhs_se.expr; -// if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp -// || has_ref_after_cafref (lhs_expr)) -// { -// tmp_stat = gfc_find_stat_co (lhs_expr); - -// if (tmp_stat) -// { -// gfc_se stat_se; -// gfc_init_se (&stat_se, NULL); -// gfc_conv_expr_reference (&stat_se, tmp_stat); -// src_stat = stat_se.expr; -// gfc_add_block_to_block (&block, &stat_se.pre); -// gfc_add_block_to_block (&block, &stat_se.post); -// } - -// gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl, -// NULL_TREE, NULL); -// tree lhs_reference, rhs_reference; -// lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); -// rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr); -// tmp = build_call_expr_loc (input_location, -// gfor_fndecl_caf_sendget_by_ref, 13, -// token, image_index, lhs_reference, -// rhs_token, rhs_image_index, rhs_reference, -// lhs_kind, rhs_kind, may_require_tmp, -// dst_stat, src_stat, -// build_int_cst (integer_type_node, -// lhs_expr->ts.type), -// build_int_cst (integer_type_node, -// rhs_expr->ts.type)); -// } -// else -// { -// gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl, -// tmp, rhs_expr); -// tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, -// 14, token, offset, image_index, -// lhs_se.expr, vec, rhs_token, rhs_offset, -// rhs_image_index, tmp, rhs_vec, lhs_kind, -// rhs_kind, may_require_tmp, src_stat); -// } -// } -// gfc_add_expr_to_block (&block, tmp); -// gfc_add_block_to_block (&block, &lhs_se.post); -// gfc_add_block_to_block (&block, &rhs_se.post); - -// /* It guarantees memory consistency within the same segment. */ -// tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); -// tmp = build5_loc (input_location, ASM_EXPR, void_type_node, -// gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, -// tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); -// ASM_VOLATILE_P (tmp) = 1; -// gfc_add_expr_to_block (&block, tmp); - -// return gfc_finish_block (&block); -// } static void trans_this_image (gfc_se * se, gfc_expr *expr) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index fcb091a3cc6..e22e0f18f6f 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -883,22 +883,12 @@ extern GTY(()) tree gfor_fndecl_caf_this_image; extern GTY(()) tree gfor_fndecl_caf_num_images; extern GTY(()) tree gfor_fndecl_caf_register; extern GTY(()) tree gfor_fndecl_caf_deregister; - -// Deprecate start -extern GTY(()) tree gfor_fndecl_caf_get; -extern GTY(()) tree gfor_fndecl_caf_send; -extern GTY(()) tree gfor_fndecl_caf_sendget; -extern GTY(()) tree gfor_fndecl_caf_send_by_ref; -extern GTY(()) tree gfor_fndecl_caf_sendget_by_ref; -// Deprecate end - extern GTY(()) tree gfor_fndecl_caf_register_accessor; extern GTY(()) tree gfor_fndecl_caf_register_accessors_finish; extern GTY(()) tree gfor_fndecl_caf_get_remote_function_index; extern GTY(()) tree gfor_fndecl_caf_get_from_remote; extern GTY(()) tree gfor_fndecl_caf_send_to_remote; extern GTY(()) tree gfor_fndecl_caf_transfer_between_remotes; - extern GTY(()) tree gfor_fndecl_caf_sync_all; extern GTY(()) tree gfor_fndecl_caf_sync_memory; extern GTY(()) tree gfor_fndecl_caf_sync_images; diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index ef3dacfd8e7..0b371d02a18 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -89,98 +89,6 @@ typedef struct caf_static_t { } caf_static_t; -/* When there is a vector subscript in this dimension, nvec == 0, otherwise, - lower_bound, upper_bound, stride contains the bounds relative to the declared - bounds; kind denotes the integer kind of the elements of vector[]. */ -typedef struct caf_vector_t { - size_t nvec; - union { - struct { - void *vector; - int kind; - } v; - struct { - ptrdiff_t lower_bound, upper_bound, stride; - } triplet; - } u; -} -caf_vector_t; - -typedef enum caf_ref_type_t { - /* Reference a component of a derived type, either regular one or an - allocatable or pointer type. For regular ones idx in caf_reference_t is - set to -1. */ - CAF_REF_COMPONENT, - /* Reference an allocatable array. */ - CAF_REF_ARRAY, - /* Reference a non-allocatable/non-pointer array. */ - CAF_REF_STATIC_ARRAY -} caf_ref_type_t; - -typedef enum caf_array_ref_t { - /* No array ref. This terminates the array ref. */ - CAF_ARR_REF_NONE = 0, - /* Reference array elements given by a vector. Only for this mode - caf_reference_t.u.a.dim[i].v is valid. */ - CAF_ARR_REF_VECTOR, - /* A full array ref (:). */ - CAF_ARR_REF_FULL, - /* Reference a range on elements given by start, end and stride. */ - CAF_ARR_REF_RANGE, - /* Only a single item is referenced given in the start member. */ - CAF_ARR_REF_SINGLE, - /* An array ref of the kind (i:), where i is an arbitrary valid index in the - array. The index i is given in the start member. */ - CAF_ARR_REF_OPEN_END, - /* An array ref of the kind (:i), where the lower bound of the array ref - is given by the remote side. The index i is given in the end member. */ - CAF_ARR_REF_OPEN_START -} caf_array_ref_t; - -/* References to remote components of a derived type. */ -typedef struct caf_reference_t { - /* A pointer to the next ref or NULL. */ - struct caf_reference_t *next; - /* The type of the reference. */ - /* caf_ref_type_t, replaced by int to allow specification in fortran FE. */ - int type; - /* The size of an item referenced in bytes. I.e. in an array ref this is - the factor to advance the array pointer with to get to the next item. - For component refs this gives just the size of the element referenced. */ - size_t item_size; - union { - struct { - /* The offset (in bytes) of the component in the derived type. */ - ptrdiff_t offset; - /* The offset (in bytes) to the caf_token associated with this - component. NULL, when not allocatable/pointer ref. */ - ptrdiff_t caf_token_offset; - } c; - struct { - /* The mode of the array ref. See CAF_ARR_REF_*. */ - /* caf_array_ref_t, replaced by unsigend char to allow specification in - fortran FE. */ - unsigned char mode[GFC_MAX_DIMENSIONS]; - /* The type of a static array. Unset for array's with descriptors. */ - int static_array_type; - /* Subscript refs (s) or vector refs (v). */ - union { - struct { - /* The start and end boundary of the ref and the stride. */ - index_type start, end, stride; - } s; - struct { - /* nvec entries of kind giving the elements to reference. */ - void *vector; - /* The number of entries in vector. */ - size_t nvec; - /* The integer kind used for the elements in vector. */ - int kind; - } v; - } dim[GFC_MAX_DIMENSIONS]; - } a; - } u; -} caf_reference_t; void _gfortran_caf_init (int *, char ***); void _gfortran_caf_finalize (void); @@ -213,26 +121,6 @@ void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, size_t); void _gfortran_caf_co_reduce (gfc_descriptor_t *, void* (*) (void *, void*), int, int, int *, char *, int, size_t); -void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *, - caf_vector_t *, gfc_descriptor_t *, int, int, bool, - int *); -void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *, - caf_vector_t *, gfc_descriptor_t *, int, int, bool, - int *); -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, bool); - -void _gfortran_caf_send_by_ref (caf_token_t token, int image_index, - gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, - int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat, - int dst_type); -void _gfortran_caf_sendget_by_ref ( - caf_token_t dst_token, int dst_image_index, caf_reference_t *dst_refs, - caf_token_t src_token, 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 dst_type, int src_type); - void _gfortran_caf_register_accessor ( const int hash, void (*accessor) (void *, const int *, void **, int32_t *, void *, diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 1f7a9022e39..d4e081be4dd 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -477,2393 +477,6 @@ _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)), } -static void -assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst, - unsigned char *src) -{ - size_t i, n; - n = dst_size/4 > src_size ? src_size : dst_size/4; - for (i = 0; i < n; ++i) - dst[i] = (int32_t) src[i]; - for (; i < dst_size/4; ++i) - dst[i] = (int32_t) ' '; -} - - -static void -assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst, - uint32_t *src) -{ - size_t i, n; - n = dst_size > src_size/4 ? src_size/4 : dst_size; - for (i = 0; i < n; ++i) - dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i]; - if (dst_size > n) - memset (&dst[n], ' ', dst_size - n); -} - - -static void -convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type, - int src_kind, int *stat) -{ -#ifdef HAVE_GFC_INTEGER_16 - typedef __int128 int128t; -#else - typedef int64_t int128t; -#endif - -#if defined(GFC_REAL_16_IS_LONG_DOUBLE) - typedef long double real128t; - typedef _Complex long double complex128t; -#elif defined(HAVE_GFC_REAL_16) - typedef _Float128 real128t; - typedef _Complex _Float128 complex128t; -#elif defined(HAVE_GFC_REAL_10) - typedef long double real128t; - typedef _Complex long double complex128t; -#else - typedef double real128t; - typedef _Complex double complex128t; -#endif - - int128t int_val = 0; - real128t real_val = 0; - complex128t cmpx_val = 0; - - switch (src_type) - { - case BT_INTEGER: - if (src_kind == 1) - int_val = *(int8_t*) src; - else if (src_kind == 2) - int_val = *(int16_t*) src; - else if (src_kind == 4) - int_val = *(int32_t*) src; - else if (src_kind == 8) - int_val = *(int64_t*) src; -#ifdef HAVE_GFC_INTEGER_16 - else if (src_kind == 16) - int_val = *(int128t*) src; -#endif - else - goto error; - break; - case BT_REAL: - if (src_kind == 4) - real_val = *(float*) src; - else if (src_kind == 8) - real_val = *(double*) src; -#ifdef HAVE_GFC_REAL_10 - else if (src_kind == 10) - real_val = *(long double*) src; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (src_kind == 16) - real_val = *(real128t*) src; -#endif - else - goto error; - break; - case BT_COMPLEX: - if (src_kind == 4) - cmpx_val = *(_Complex float*) src; - else if (src_kind == 8) - cmpx_val = *(_Complex double*) src; -#ifdef HAVE_GFC_REAL_10 - else if (src_kind == 10) - cmpx_val = *(_Complex long double*) src; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (src_kind == 16) - cmpx_val = *(complex128t*) src; -#endif - else - goto error; - break; - default: - goto error; - } - - switch (dst_type) - { - case BT_INTEGER: - if (src_type == BT_INTEGER) - { - if (dst_kind == 1) - *(int8_t*) dst = (int8_t) int_val; - else if (dst_kind == 2) - *(int16_t*) dst = (int16_t) int_val; - else if (dst_kind == 4) - *(int32_t*) dst = (int32_t) int_val; - else if (dst_kind == 8) - *(int64_t*) dst = (int64_t) int_val; -#ifdef HAVE_GFC_INTEGER_16 - else if (dst_kind == 16) - *(int128t*) dst = (int128t) int_val; -#endif - else - goto error; - } - else if (src_type == BT_REAL) - { - if (dst_kind == 1) - *(int8_t*) dst = (int8_t) real_val; - else if (dst_kind == 2) - *(int16_t*) dst = (int16_t) real_val; - else if (dst_kind == 4) - *(int32_t*) dst = (int32_t) real_val; - else if (dst_kind == 8) - *(int64_t*) dst = (int64_t) real_val; -#ifdef HAVE_GFC_INTEGER_16 - else if (dst_kind == 16) - *(int128t*) dst = (int128t) real_val; -#endif - else - goto error; - } - else if (src_type == BT_COMPLEX) - { - if (dst_kind == 1) - *(int8_t*) dst = (int8_t) cmpx_val; - else if (dst_kind == 2) - *(int16_t*) dst = (int16_t) cmpx_val; - else if (dst_kind == 4) - *(int32_t*) dst = (int32_t) cmpx_val; - else if (dst_kind == 8) - *(int64_t*) dst = (int64_t) cmpx_val; -#ifdef HAVE_GFC_INTEGER_16 - else if (dst_kind == 16) - *(int128t*) dst = (int128t) cmpx_val; -#endif - else - goto error; - } - else - goto error; - return; - case BT_REAL: - if (src_type == BT_INTEGER) - { - if (dst_kind == 4) - *(float*) dst = (float) int_val; - else if (dst_kind == 8) - *(double*) dst = (double) int_val; -#ifdef HAVE_GFC_REAL_10 - else if (dst_kind == 10) - *(long double*) dst = (long double) int_val; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (dst_kind == 16) - *(real128t*) dst = (real128t) int_val; -#endif - else - goto error; - } - else if (src_type == BT_REAL) - { - if (dst_kind == 4) - *(float*) dst = (float) real_val; - else if (dst_kind == 8) - *(double*) dst = (double) real_val; -#ifdef HAVE_GFC_REAL_10 - else if (dst_kind == 10) - *(long double*) dst = (long double) real_val; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (dst_kind == 16) - *(real128t*) dst = (real128t) real_val; -#endif - else - goto error; - } - else if (src_type == BT_COMPLEX) - { - if (dst_kind == 4) - *(float*) dst = (float) cmpx_val; - else if (dst_kind == 8) - *(double*) dst = (double) cmpx_val; -#ifdef HAVE_GFC_REAL_10 - else if (dst_kind == 10) - *(long double*) dst = (long double) cmpx_val; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (dst_kind == 16) - *(real128t*) dst = (real128t) cmpx_val; -#endif - else - goto error; - } - return; - case BT_COMPLEX: - if (src_type == BT_INTEGER) - { - if (dst_kind == 4) - *(_Complex float*) dst = (_Complex float) int_val; - else if (dst_kind == 8) - *(_Complex double*) dst = (_Complex double) int_val; -#ifdef HAVE_GFC_REAL_10 - else if (dst_kind == 10) - *(_Complex long double*) dst = (_Complex long double) int_val; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (dst_kind == 16) - *(complex128t*) dst = (complex128t) int_val; -#endif - else - goto error; - } - else if (src_type == BT_REAL) - { - if (dst_kind == 4) - *(_Complex float*) dst = (_Complex float) real_val; - else if (dst_kind == 8) - *(_Complex double*) dst = (_Complex double) real_val; -#ifdef HAVE_GFC_REAL_10 - else if (dst_kind == 10) - *(_Complex long double*) dst = (_Complex long double) real_val; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (dst_kind == 16) - *(complex128t*) dst = (complex128t) real_val; -#endif - else - goto error; - } - else if (src_type == BT_COMPLEX) - { - if (dst_kind == 4) - *(_Complex float*) dst = (_Complex float) cmpx_val; - else if (dst_kind == 8) - *(_Complex double*) dst = (_Complex double) cmpx_val; -#ifdef HAVE_GFC_REAL_10 - else if (dst_kind == 10) - *(_Complex long double*) dst = (_Complex long double) cmpx_val; -#endif -#ifdef HAVE_GFC_REAL_16 - else if (dst_kind == 16) - *(complex128t*) dst = (complex128t) cmpx_val; -#endif - else - goto error; - } - else - goto error; - return; - default: - goto error; - } - -error: - fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind " - "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind); - if (stat) - *stat = 1; - else - abort (); -} - - -void -_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, - bool may_require_tmp, int *stat) -{ - /* FIXME: Handle vector subscripts. */ - size_t i, k, size; - int j; - int rank = GFC_DESCRIPTOR_RANK (dest); - size_t src_size = GFC_DESCRIPTOR_SIZE (src); - size_t dst_size = GFC_DESCRIPTOR_SIZE (dest); - - if (stat) - *stat = 0; - - if (rank == 0) - { - void *sr = (void *) ((char *) MEMTOK (token) + offset); - if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) - && dst_kind == src_kind) - { - memmove (GFC_DESCRIPTOR_DATA (dest), 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*) GFC_DESCRIPTOR_DATA (dest) + src_size, - ' ', dst_size - src_size); - else /* dst_kind == 4. */ - for (i = src_size/4; i < dst_size/4; i++) - ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' '; - } - } - else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) - assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest), - sr); - else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) - assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest), - sr); - else - convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest), - dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); - return; - } - - size = 1; - for (j = 0; j < rank; j++) - { - ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1; - if (dimextent < 0) - dimextent = 0; - size *= dimextent; - } - - 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 *) MEMTOK (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, stat); - array_offset_sr += src_size; - } - - free (tmp); - return; - } - - 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); - - ptrdiff_t array_offset_sr = 0; - stride = 1; - 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 *) MEMTOK (token) + offset - + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); - - 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, stat); - } -} - - -void -_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, - bool may_require_tmp, int *stat) -{ - /* FIXME: Handle vector subscripts. */ - size_t i, k, size; - int j; - int rank = GFC_DESCRIPTOR_RANK (dest); - size_t src_size = GFC_DESCRIPTOR_SIZE (src); - size_t dst_size = GFC_DESCRIPTOR_SIZE (dest); - - if (stat) - *stat = 0; - - if (rank == 0) - { - void *dst = (void *) ((char *) MEMTOK (token) + offset); - if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src) - && dst_kind == src_kind) - { - memmove (dst, GFC_DESCRIPTOR_DATA (src), - 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 (i = src_size/4; i < dst_size/4; i++) - ((int32_t*) dst)[i] = (int32_t) ' '; - } - } - else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1) - assign_char1_from_char4 (dst_size, src_size, dst, - GFC_DESCRIPTOR_DATA (src)); - else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER) - assign_char4_from_char1 (dst_size, src_size, dst, - GFC_DESCRIPTOR_DATA (src)); - else - convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, - GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src), - src_kind, stat); - return; - } - - size = 1; - for (j = 0; j < rank; j++) - { - ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1; - if (dimextent < 0) - dimextent = 0; - size *= dimextent; - } - - 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 *) MEMTOK (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, stat); - 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; - 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 *) MEMTOK (token) + offset - + array_offset_dst * dest->span); - void *sr; - if (GFC_DESCRIPTOR_RANK (src) != 0) - { - ptrdiff_t array_offset_sr = 0; - stride = 1; - 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; - sr = (void *) ((char *) src->base_addr + array_offset_sr * src->span); - } - else - sr = src->base_addr; - - 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, stat); - } -} - - -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 __attribute__ ((unused)), - gfc_descriptor_t *src, - caf_vector_t *src_vector __attribute__ ((unused)), - 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 - but to play save, we do it properly. */ - void *src_base = GFC_DESCRIPTOR_DATA (src); - GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token) - + src_offset); - _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector, - src, dst_kind, src_kind, may_require_tmp, NULL); - GFC_DESCRIPTOR_DATA (src) = src_base; -} - - -/* Emitted when a theorectically unreachable part is reached. */ -const char unreachable[] = "Fatal error: unreachable alternative found.\n"; - - -static void -copy_data (void *ds, void *sr, int dst_type, int src_type, - int dst_kind, int src_kind, size_t dst_size, size_t src_size, - size_t num, int *stat) -{ - size_t k; - if (dst_type == src_type && dst_kind == src_kind) - { - memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num); - if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER) - && dst_size > src_size) - { - if (dst_kind == 1) - memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size); - else /* dst_kind == 4. */ - for (k = src_size/4; k < dst_size/4; k++) - ((int32_t*) ds)[k] = (int32_t) ' '; - } - } - else if (dst_type == BT_CHARACTER && dst_kind == 1) - assign_char1_from_char4 (dst_size, src_size, ds, sr); - else if (dst_type == BT_CHARACTER) - assign_char4_from_char1 (dst_size, src_size, ds, sr); - else - for (k = 0; k < num; ++k) - { - convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat); - ds += dst_size; - sr += src_size; - } -} - - -#define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \ - do { \ - index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \ - num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \ - if (num <= 0 || abs_stride < 1) return; \ - num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \ - } while (0) - - -static void -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, int src_type) -{ - ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src; - size_t next_dst_dim; - - if (unlikely (ref == NULL)) - /* May be we should issue an error here, because this case should not - occur. */ - return; - - if (ref->next == NULL) - { - size_t dst_size = GFC_DESCRIPTOR_SIZE (dst); - ptrdiff_t array_offset_dst = 0;; - size_t dst_rank = GFC_DESCRIPTOR_RANK (dst); - - switch (ref->type) - { - case CAF_REF_COMPONENT: - /* Because the token is always registered after the component, its - 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), 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), src_type, - dst_kind, src_kind, dst_size, ref->item_size, 1, stat); - ++(*i); - return; - case CAF_REF_STATIC_ARRAY: - /* Intentionally fall through. */ - case CAF_REF_ARRAY: - if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) - { - 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, - dst_kind, src_kind, dst_size, ref->item_size, num, - stat); - *i += num; - return; - } - break; - default: - caf_runtime_error (unreachable); - } - } - - switch (ref->type) - { - case CAF_REF_COMPONENT: - if (ref->u.c.caf_token_offset > 0) - { - 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 cannot 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, 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, src_type); - return; - } - /* Only when on the left most index switch the data pointer to - the array's data pointer. */ - if (src_dim == 0) - sr = GFC_DESCRIPTOR_DATA (src); - switch (ref->u.a.mode[src_dim]) - { - case CAF_ARR_REF_VECTOR: - extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]); - array_offset_src = 0; - dst_index[dst_dim] = 0; - for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec; - ++idx) - { -#define KINDCASE(kind, type) case kind: \ - array_offset_src = (((index_type) \ - ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \ - - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \ - * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \ - break - - switch (ref->u.a.dim[src_dim].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_runtime_error (unreachable); - return; - } -#undef KINDCASE - - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - } - return; - case CAF_ARR_REF_FULL: - COMPUTE_NUM_ITEMS (extent_src, - ref->u.a.dim[src_dim].s.stride, - GFC_DIMENSION_LBOUND (src->dim[src_dim]), - GFC_DIMENSION_UBOUND (src->dim[src_dim])); - stride_src = src->dim[src_dim]._stride - * ref->u.a.dim[src_dim].s.stride; - array_offset_src = 0; - dst_index[dst_dim] = 0; - for (index_type idx = 0; idx < extent_src; - ++idx, array_offset_src += stride_src) - { - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - } - return; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (extent_src, - ref->u.a.dim[src_dim].s.stride, - ref->u.a.dim[src_dim].s.start, - ref->u.a.dim[src_dim].s.end); - array_offset_src = (ref->u.a.dim[src_dim].s.start - - GFC_DIMENSION_LBOUND (src->dim[src_dim])) - * GFC_DIMENSION_STRIDE (src->dim[src_dim]); - stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim]) - * ref->u.a.dim[src_dim].s.stride; - dst_index[dst_dim] = 0; - /* Increase the dst_dim only, when the src_extent is greater one - or src and dst extent are both one. Don't increase when the scalar - source is not present in the dst. */ - next_dst_dim = extent_src > 1 - || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1 - && extent_src == 1) ? (dst_dim + 1) : dst_dim; - for (index_type idx = 0; idx < extent_src; ++idx) - { - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - array_offset_src += stride_src; - } - return; - case CAF_ARR_REF_SINGLE: - array_offset_src = (ref->u.a.dim[src_dim].s.start - - src->dim[src_dim].lower_bound) - * GFC_DIMENSION_STRIDE (src->dim[src_dim]); - dst_index[dst_dim] = 0; - 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, src_type); - return; - case CAF_ARR_REF_OPEN_END: - COMPUTE_NUM_ITEMS (extent_src, - ref->u.a.dim[src_dim].s.stride, - ref->u.a.dim[src_dim].s.start, - GFC_DIMENSION_UBOUND (src->dim[src_dim])); - stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim]) - * ref->u.a.dim[src_dim].s.stride; - array_offset_src = (ref->u.a.dim[src_dim].s.start - - GFC_DIMENSION_LBOUND (src->dim[src_dim])) - * GFC_DIMENSION_STRIDE (src->dim[src_dim]); - dst_index[dst_dim] = 0; - for (index_type idx = 0; idx < extent_src; ++idx) - { - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - array_offset_src += stride_src; - } - return; - case CAF_ARR_REF_OPEN_START: - COMPUTE_NUM_ITEMS (extent_src, - ref->u.a.dim[src_dim].s.stride, - GFC_DIMENSION_LBOUND (src->dim[src_dim]), - ref->u.a.dim[src_dim].s.end); - stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim]) - * ref->u.a.dim[src_dim].s.stride; - array_offset_src = 0; - dst_index[dst_dim] = 0; - for (index_type idx = 0; idx < extent_src; ++idx) - { - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - array_offset_src += stride_src; - } - return; - default: - caf_runtime_error (unreachable); - } - return; - case CAF_REF_STATIC_ARRAY: - if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) - { - get_for_ref (ref->next, i, dst_index, single_token, dst, - NULL, ds, sr, dst_kind, src_kind, - dst_dim, 0, 1, stat, src_type); - return; - } - switch (ref->u.a.mode[src_dim]) - { - case CAF_ARR_REF_VECTOR: - array_offset_src = 0; - dst_index[dst_dim] = 0; - for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec; - ++idx) - { -#define KINDCASE(kind, type) case kind: \ - array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \ - break - - switch (ref->u.a.dim[src_dim].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_runtime_error (unreachable); - return; - } -#undef KINDCASE - - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - } - return; - case CAF_ARR_REF_FULL: - dst_index[dst_dim] = 0; - for (array_offset_src = 0 ; - array_offset_src <= ref->u.a.dim[src_dim].s.end; - array_offset_src += ref->u.a.dim[src_dim].s.stride) - { - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - } - return; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (extent_src, - ref->u.a.dim[src_dim].s.stride, - ref->u.a.dim[src_dim].s.start, - ref->u.a.dim[src_dim].s.end); - array_offset_src = ref->u.a.dim[src_dim].s.start; - dst_index[dst_dim] = 0; - for (index_type idx = 0; idx < extent_src; ++idx) - { - 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, src_type); - dst_index[dst_dim] - += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - array_offset_src += ref->u.a.dim[src_dim].s.stride; - } - return; - case CAF_ARR_REF_SINGLE: - array_offset_src = ref->u.a.dim[src_dim].s.start; - 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, src_type); - return; - /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */ - case CAF_ARR_REF_OPEN_END: - case CAF_ARR_REF_OPEN_START: - default: - caf_runtime_error (unreachable); - } - return; - default: - caf_runtime_error (unreachable); - } -} - -/* For internal use only. */ -static void -_gfortran_caf_get_by_ref (caf_token_t token, - int image_index __attribute__ ((unused)), - 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, int src_type) -{ - const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " - "unknown kind in vector-ref.\n"; - const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): " - "unknown reference type.\n"; - const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): " - "unknown array reference type.\n"; - const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): " - "rank out of range.\n"; - const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): " - "extent out of range.\n"; - const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): " - "cannot allocate memory.\n"; - const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): " - "extent of non-allocatable arrays mismatch (%lu != %lu).\n"; - const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): " - "two or more array part references are not supported.\n"; - size_t size, i; - size_t dst_index[GFC_MAX_DIMENSIONS]; - int dst_rank = GFC_DESCRIPTOR_RANK (dst); - int dst_cur_dim = 0; - size_t src_size = 0; - caf_single_token_t single_token = TOKEN (token); - void *memptr = single_token->memptr; - gfc_descriptor_t *src = single_token->desc; - caf_reference_t *riter = refs; - long delta; - /* Reallocation of dst.data is needed (e.g., array to small). */ - bool realloc_needed; - /* Reallocation of dst.data is required, because data is not alloced at - all. */ - bool realloc_required; - bool extent_mismatch = false; - /* Set when the first non-scalar array reference is encountered. */ - bool in_array_ref = false; - bool array_extent_fixed = false; - realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL; - - assert (!realloc_needed || dst_reallocatable); - - if (stat) - *stat = 0; - - /* Compute the size of the result. In the beginning size just counts the - number of elements. */ - size = 1; - while (riter) - { - switch (riter->type) - { - case CAF_REF_COMPONENT: - if (riter->u.c.caf_token_offset) - { - single_token = *(caf_single_token_t*) - (memptr + riter->u.c.caf_token_offset); - memptr = single_token->memptr; - src = single_token->desc; - } - else - { - memptr += riter->u.c.offset; - /* 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: - for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) - { - switch (riter->u.a.mode[i]) - { - case CAF_ARR_REF_VECTOR: - delta = riter->u.a.dim[i].v.nvec; -#define KINDCASE(kind, type) case kind: \ - memptr += (((index_type) \ - ((type *)riter->u.a.dim[i].v.vector)[0]) \ - - GFC_DIMENSION_LBOUND (src->dim[i])) \ - * GFC_DIMENSION_STRIDE (src->dim[i]) \ - * riter->item_size; \ - break - - switch (riter->u.a.dim[i].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_internal_error (vecrefunknownkind, stat, NULL, 0); - return; - } -#undef KINDCASE - break; - case CAF_ARR_REF_FULL: - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - GFC_DIMENSION_LBOUND (src->dim[i]), - GFC_DIMENSION_UBOUND (src->dim[i])); - /* The memptr stays unchanged when ref'ing the first element - in a dimension. */ - break; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - riter->u.a.dim[i].s.start, - riter->u.a.dim[i].s.end); - memptr += (riter->u.a.dim[i].s.start - - GFC_DIMENSION_LBOUND (src->dim[i])) - * GFC_DIMENSION_STRIDE (src->dim[i]) - * riter->item_size; - break; - case CAF_ARR_REF_SINGLE: - delta = 1; - memptr += (riter->u.a.dim[i].s.start - - GFC_DIMENSION_LBOUND (src->dim[i])) - * GFC_DIMENSION_STRIDE (src->dim[i]) - * riter->item_size; - break; - case CAF_ARR_REF_OPEN_END: - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - riter->u.a.dim[i].s.start, - GFC_DIMENSION_UBOUND (src->dim[i])); - memptr += (riter->u.a.dim[i].s.start - - GFC_DIMENSION_LBOUND (src->dim[i])) - * GFC_DIMENSION_STRIDE (src->dim[i]) - * riter->item_size; - break; - case CAF_ARR_REF_OPEN_START: - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - GFC_DIMENSION_LBOUND (src->dim[i]), - riter->u.a.dim[i].s.end); - /* The memptr stays unchanged when ref'ing the first element - in a dimension. */ - break; - default: - caf_internal_error (unknownarrreftype, stat, NULL, 0); - return; - } - if (delta <= 0) - return; - /* Check the various properties of the destination array. - Is an array expected and present? */ - if (delta > 1 && dst_rank == 0) - { - /* No, an array is required, but not provided. */ - 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) - { - /* Check that dst_cur_dim is valid for dst. Can be - superceeded only by scalar data. */ - if (dst_cur_dim >= dst_rank && delta != 1) - { - caf_internal_error (rankoutofrange, stat, NULL, 0); - return; - } - /* Do further checks, when the source is not scalar. */ - else if (delta != 1) - { - /* Check that the extent is not scalar and we are not in - an array ref for the dst side. */ - if (!in_array_ref) - { - /* Check that this is the non-scalar extent. */ - if (!array_extent_fixed) - { - /* In an array extent now. */ - in_array_ref = true; - /* Check that we haven't skipped any scalar - dimensions yet and that the dst is - compatible. */ - if (i > 0 - && dst_rank == GFC_DESCRIPTOR_RANK (src)) - { - if (dst_reallocatable) - { - /* Dst is reallocatable, which means that - the bounds are not set. Set them. */ - for (dst_cur_dim= 0; dst_cur_dim < (int)i; - ++dst_cur_dim) - GFC_DIMENSION_SET (dst->dim[dst_cur_dim], - 1, 1, 1); - } - else - dst_cur_dim = i; - } - /* Else press thumbs, that there are enough - dimensional refs to come. Checked below. */ - } - else - { - caf_internal_error (doublearrayref, stat, NULL, - 0); - return; - } - } - /* When the realloc is required, then no extent may have - been set. */ - extent_mismatch = realloc_required - || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta; - /* When it already known, that a realloc is needed or - the extent does not match the needed one. */ - if (realloc_required || realloc_needed - || extent_mismatch) - { - /* Check whether dst is reallocatable. */ - if (unlikely (!dst_reallocatable)) - { - caf_internal_error (nonallocextentmismatch, stat, - NULL, 0, delta, - GFC_DESCRIPTOR_EXTENT (dst, - dst_cur_dim)); - return; - } - /* Only report an error, when the extent needs to be - modified, which is not allowed. */ - else if (!dst_reallocatable && extent_mismatch) - { - caf_internal_error (extentoutofrange, stat, NULL, - 0); - return; - } - realloc_needed = true; - } - /* Only change the extent when it does not match. This is - to prevent resetting given array bounds. */ - if (extent_mismatch) - GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta, - size); - } - - /* Only increase the dim counter, when in an array ref. */ - if (in_array_ref && dst_cur_dim < dst_rank) - ++dst_cur_dim; - } - size *= (index_type)delta; - } - if (in_array_ref) - { - array_extent_fixed = true; - in_array_ref = false; - /* Check, if we got less dimensional refs than the rank of dst - expects. */ - assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst)); - } - break; - case CAF_REF_STATIC_ARRAY: - for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) - { - switch (riter->u.a.mode[i]) - { - case CAF_ARR_REF_VECTOR: - delta = riter->u.a.dim[i].v.nvec; -#define KINDCASE(kind, type) case kind: \ - memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \ - * riter->item_size; \ - break - - switch (riter->u.a.dim[i].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_internal_error (vecrefunknownkind, stat, NULL, 0); - return; - } -#undef KINDCASE - break; - case CAF_ARR_REF_FULL: - delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride - + 1; - /* The memptr stays unchanged when ref'ing the first element - in a dimension. */ - break; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - riter->u.a.dim[i].s.start, - riter->u.a.dim[i].s.end); - memptr += riter->u.a.dim[i].s.start - * riter->u.a.dim[i].s.stride - * riter->item_size; - break; - case CAF_ARR_REF_SINGLE: - delta = 1; - memptr += riter->u.a.dim[i].s.start - * riter->u.a.dim[i].s.stride - * riter->item_size; - break; - case CAF_ARR_REF_OPEN_END: - /* This and OPEN_START are mapped to a RANGE and therefore - cannot occur here. */ - case CAF_ARR_REF_OPEN_START: - default: - caf_internal_error (unknownarrreftype, stat, NULL, 0); - return; - } - if (delta <= 0) - return; - /* Check the various properties of the destination array. - Is an array expected and present? */ - if (delta > 1 && dst_rank == 0) - { - /* No, an array is required, but not provided. */ - 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) - { - /* Check that dst_cur_dim is valid for dst. Can be - superceeded only by scalar data. */ - if (dst_cur_dim >= dst_rank && delta != 1) - { - caf_internal_error (rankoutofrange, stat, NULL, 0); - return; - } - /* Do further checks, when the source is not scalar. */ - else if (delta != 1) - { - /* Check that the extent is not scalar and we are not in - an array ref for the dst side. */ - if (!in_array_ref) - { - /* Check that this is the non-scalar extent. */ - if (!array_extent_fixed) - { - /* In an array extent now. */ - in_array_ref = true; - /* The dst is not reallocatable, so nothing more - to do, then correct the dim counter. */ - dst_cur_dim = i; - } - else - { - caf_internal_error (doublearrayref, stat, NULL, - 0); - return; - } - } - /* When the realloc is required, then no extent may have - been set. */ - extent_mismatch = realloc_required - || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta; - /* When it is already known, that a realloc is needed or - the extent does not match the needed one. */ - if (realloc_required || realloc_needed - || extent_mismatch) - { - /* Check whether dst is reallocatable. */ - if (unlikely (!dst_reallocatable)) - { - caf_internal_error (nonallocextentmismatch, stat, - NULL, 0, delta, - GFC_DESCRIPTOR_EXTENT (dst, - dst_cur_dim)); - return; - } - /* Only report an error, when the extent needs to be - modified, which is not allowed. */ - else if (!dst_reallocatable && extent_mismatch) - { - caf_internal_error (extentoutofrange, stat, NULL, - 0); - return; - } - realloc_needed = true; - } - /* Only change the extent when it does not match. This is - to prevent resetting given array bounds. */ - if (extent_mismatch) - GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta, - size); - } - /* Only increase the dim counter, when in an array ref. */ - if (in_array_ref && dst_cur_dim < dst_rank) - ++dst_cur_dim; - } - size *= (index_type)delta; - } - if (in_array_ref) - { - array_extent_fixed = true; - in_array_ref = false; - /* Check, if we got less dimensional refs than the rank of dst - expects. */ - assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst)); - } - break; - default: - caf_internal_error (unknownreftype, stat, NULL, 0); - return; - } - src_size = riter->item_size; - riter = riter->next; - } - if (size == 0 || src_size == 0) - return; - /* Postcondition: - - size contains the number of elements to store in the destination array, - - src_size gives the size in bytes of each item in the destination array. - */ - - if (realloc_needed) - { - 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); - } - - GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst)); - if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL)) - { - caf_internal_error (cannotallocdst, stat, NULL, 0); - return; - } - } - - /* Reset the token. */ - single_token = TOKEN (token); - memptr = single_token->memptr; - src = single_token->desc; - memset(dst_index, 0, sizeof (dst_index)); - 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, src_type); -} - - -static void -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, int dst_type) -{ - const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): " - "unknown kind in vector-ref.\n"; - ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst; - const size_t src_rank = GFC_DESCRIPTOR_RANK (src); - - if (unlikely (ref == NULL)) - /* May be we should issue an error here, because this case should not - occur. */ - return; - - if (ref->next == NULL) - { - size_t src_size = GFC_DESCRIPTOR_SIZE (src); - ptrdiff_t array_offset_src = 0;; - - switch (ref->type) - { - case CAF_REF_COMPONENT: - if (ref->u.c.caf_token_offset > 0) - { - if (*(void**)(ds + ref->u.c.offset) == NULL) - { - /* Create a scalar temporary array descriptor. */ - gfc_descriptor_t static_dst; - GFC_DESCRIPTOR_DATA (&static_dst) = NULL; - GFC_DESCRIPTOR_DTYPE (&static_dst) - = GFC_DESCRIPTOR_DTYPE (src); - /* The component can be allocated now, because it is a - scalar. */ - _gfortran_caf_register (ref->item_size, - CAF_REGTYPE_COARRAY_ALLOC, - 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) - return; - /* Publish the allocated memory. */ - *((void **)(ds + ref->u.c.offset)) - = GFC_DESCRIPTOR_DATA (&static_dst); - ds = GFC_DESCRIPTOR_DATA (&static_dst); - /* Set the type from the src. */ - dst_type = GFC_DESCRIPTOR_TYPE (src); - } - else - { - single_token = *(caf_single_token_t *) - (ds + ref->u.c.caf_token_offset); - dst = single_token->desc; - if (dst) - { - ds = GFC_DESCRIPTOR_DATA (dst); - dst_type = GFC_DESCRIPTOR_TYPE (dst); - } - else - 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_type, - GFC_DESCRIPTOR_TYPE (src), - dst_kind, src_kind, ref->item_size, src_size, 1, stat); - ++(*i); - return; - case CAF_REF_STATIC_ARRAY: - /* Intentionally fall through. */ - case CAF_REF_ARRAY: - if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) - { - if (src_rank > 0) - { - for (size_t d = 0; d < src_rank; ++d) - array_offset_src += src_index[d]; - 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, GFC_DESCRIPTOR_TYPE (src), - dst_kind, src_kind, ref->item_size, src_size, num, - stat); - *i += num; - return; - } - break; - default: - caf_runtime_error (unreachable); - } - } - - switch (ref->type) - { - case CAF_REF_COMPONENT: - if (ref->u.c.caf_token_offset > 0) - { - if (*(void**)(ds + ref->u.c.offset) == NULL) - { - /* This component refs an unallocated array. Non-arrays are - caught in the if (!ref->next) above. */ - dst = (gfc_descriptor_t *)(ds + ref->u.c.offset); - /* Assume that the rank and the dimensions fit for copying src - to dst. */ - GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src); - GFC_DESCRIPTOR_SPAN (dst) = GFC_DESCRIPTOR_SPAN (src); - stride_dst = 1; - dst->offset = 0; - for (size_t d = 0; d < src_rank; ++d) - { - extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]); - GFC_DIMENSION_LBOUND (dst->dim[d]) = 1; - GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst; - GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst; - dst->offset -= stride_dst; - stride_dst *= extent_dst; - } - /* Null the data-pointer to make register_component allocate - its own memory. */ - GFC_DESCRIPTOR_DATA (dst) = NULL; - - /* The size of the array is given by size. */ - _gfortran_caf_register (size * ref->item_size, - CAF_REGTYPE_COARRAY_ALLOC, - 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; - } - 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, 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, 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, dst_type); - return; - } - /* Only when on the left most index switch the data pointer to - the array's data pointer. And only for non-static arrays. */ - if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY) - ds = GFC_DESCRIPTOR_DATA (dst); - switch (ref->u.a.mode[dst_dim]) - { - case CAF_ARR_REF_VECTOR: - array_offset_dst = 0; - src_index[src_dim] = 0; - for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec; - ++idx) - { -#define KINDCASE(kind, type) case kind: \ - array_offset_dst = (((index_type) \ - ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \ - - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \ - * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \ - break - - switch (ref->u.a.dim[dst_dim].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_internal_error (vecrefunknownkind, stat, NULL, 0); - return; - } -#undef KINDCASE - - 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, dst_type); - if (src_rank > 0) - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - } - return; - case CAF_ARR_REF_FULL: - COMPUTE_NUM_ITEMS (extent_dst, - ref->u.a.dim[dst_dim].s.stride, - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]), - GFC_DIMENSION_UBOUND (dst->dim[dst_dim])); - array_offset_dst = 0; - stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) - * ref->u.a.dim[dst_dim].s.stride; - src_index[src_dim] = 0; - for (index_type idx = 0; idx < extent_dst; - ++idx, array_offset_dst += stride_dst) - { - 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, dst_type); - if (src_rank > 0) - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - } - return; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (extent_dst, - ref->u.a.dim[dst_dim].s.stride, - ref->u.a.dim[dst_dim].s.start, - ref->u.a.dim[dst_dim].s.end); - array_offset_dst = ref->u.a.dim[dst_dim].s.start - - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]); - stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) - * ref->u.a.dim[dst_dim].s.stride; - src_index[src_dim] = 0; - for (index_type idx = 0; idx < extent_dst; ++idx) - { - 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, dst_type); - if (src_rank > 0) - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - array_offset_dst += stride_dst; - } - return; - case CAF_ARR_REF_SINGLE: - array_offset_dst = (ref->u.a.dim[dst_dim].s.start - - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) - * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); - 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, dst_type); - return; - case CAF_ARR_REF_OPEN_END: - COMPUTE_NUM_ITEMS (extent_dst, - ref->u.a.dim[dst_dim].s.stride, - ref->u.a.dim[dst_dim].s.start, - GFC_DIMENSION_UBOUND (dst->dim[dst_dim])); - array_offset_dst = ref->u.a.dim[dst_dim].s.start - - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]); - stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) - * ref->u.a.dim[dst_dim].s.stride; - src_index[src_dim] = 0; - for (index_type idx = 0; idx < extent_dst; ++idx) - { - 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, dst_type); - if (src_rank > 0) - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - array_offset_dst += stride_dst; - } - return; - case CAF_ARR_REF_OPEN_START: - COMPUTE_NUM_ITEMS (extent_dst, - ref->u.a.dim[dst_dim].s.stride, - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]), - ref->u.a.dim[dst_dim].s.end); - array_offset_dst = 0; - stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim]) - * ref->u.a.dim[dst_dim].s.stride; - src_index[src_dim] = 0; - for (index_type idx = 0; idx < extent_dst; ++idx) - { - 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, dst_type); - if (src_rank > 0) - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - array_offset_dst += stride_dst; - } - return; - default: - caf_runtime_error (unreachable); - } - return; - case CAF_REF_STATIC_ARRAY: - if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) - { - send_by_ref (ref->next, i, src_index, single_token, NULL, - src, ds, sr, dst_kind, src_kind, - 0, src_dim, 1, size, stat, dst_type); - return; - } - switch (ref->u.a.mode[dst_dim]) - { - case CAF_ARR_REF_VECTOR: - array_offset_dst = 0; - src_index[src_dim] = 0; - for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec; - ++idx) - { -#define KINDCASE(kind, type) case kind: \ - array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \ - break - - switch (ref->u.a.dim[dst_dim].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_runtime_error (unreachable); - return; - } -#undef KINDCASE - - 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, dst_type); - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - } - return; - case CAF_ARR_REF_FULL: - src_index[src_dim] = 0; - for (array_offset_dst = 0 ; - array_offset_dst <= ref->u.a.dim[dst_dim].s.end; - array_offset_dst += ref->u.a.dim[dst_dim].s.stride) - { - 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, dst_type); - if (src_rank > 0) - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - } - return; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (extent_dst, - ref->u.a.dim[dst_dim].s.stride, - ref->u.a.dim[dst_dim].s.start, - ref->u.a.dim[dst_dim].s.end); - array_offset_dst = ref->u.a.dim[dst_dim].s.start; - src_index[src_dim] = 0; - for (index_type idx = 0; idx < extent_dst; ++idx) - { - 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, dst_type); - if (src_rank > 0) - src_index[src_dim] - += GFC_DIMENSION_STRIDE (src->dim[src_dim]); - array_offset_dst += ref->u.a.dim[dst_dim].s.stride; - } - return; - case CAF_ARR_REF_SINGLE: - array_offset_dst = ref->u.a.dim[dst_dim].s.start; - 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, dst_type); - return; - /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */ - case CAF_ARR_REF_OPEN_END: - case CAF_ARR_REF_OPEN_START: - default: - caf_runtime_error (unreachable); - } - return; - default: - caf_runtime_error (unreachable); - } -} - - -void -_gfortran_caf_send_by_ref (caf_token_t token, - int image_index __attribute__ ((unused)), - 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, int dst_type) -{ - const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " - "unknown kind in vector-ref.\n"; - const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): " - "unknown reference type.\n"; - const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): " - "unknown array reference type.\n"; - const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): " - "rank out of range.\n"; - const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): " - "reallocation of array followed by component ref not allowed.\n"; - const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): " - "cannot allocate memory.\n"; - const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): " - "extent of non-allocatable array mismatch.\n"; - const char innercompref[] = "libcaf_single::caf_send_by_ref(): " - "inner unallocated component detected.\n"; - size_t size, i; - size_t dst_index[GFC_MAX_DIMENSIONS]; - int src_rank = GFC_DESCRIPTOR_RANK (src); - int src_cur_dim = 0; - size_t src_size = 0; - caf_single_token_t single_token = TOKEN (token); - void *memptr = single_token->memptr; - gfc_descriptor_t *dst = single_token->desc; - caf_reference_t *riter = refs; - long delta; - bool extent_mismatch; - /* Note that the component is not allocated yet. */ - index_type new_component_idx = -1; - - if (stat) - *stat = 0; - - /* Compute the size of the result. In the beginning size just counts the - number of elements. */ - size = 1; - while (riter) - { - switch (riter->type) - { - case CAF_REF_COMPONENT: - if (unlikely (new_component_idx != -1)) - { - /* Allocating a component in the middle of a component ref is not - support. We don't know the type to allocate. */ - caf_internal_error (innercompref, stat, NULL, 0); - return; - } - if (riter->u.c.caf_token_offset > 0) - { - /* Check whether the allocatable component is zero, then no - token is present, too. The token's pointer is not cleared - when the structure is initialized. */ - if (*(void**)(memptr + riter->u.c.offset) == NULL) - { - /* This component is not yet allocated. Check that it is - allocatable here. */ - if (!dst_reallocatable) - { - caf_internal_error (cannotallocdst, stat, NULL, 0); - return; - } - single_token = NULL; - memptr = NULL; - dst = NULL; - break; - } - single_token = *(caf_single_token_t*) - (memptr + riter->u.c.caf_token_offset); - memptr += riter->u.c.offset; - dst = single_token->desc; - } - else - { - /* Regular component. */ - memptr += riter->u.c.offset; - dst = (gfc_descriptor_t *)memptr; - } - break; - case CAF_REF_ARRAY: - if (dst != NULL) - memptr = GFC_DESCRIPTOR_DATA (dst); - else - dst = src; - /* When the dst array needs to be allocated, then look at the - extent of the source array in the dimension dst_cur_dim. */ - for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) - { - switch (riter->u.a.mode[i]) - { - case CAF_ARR_REF_VECTOR: - delta = riter->u.a.dim[i].v.nvec; -#define KINDCASE(kind, type) case kind: \ - memptr += (((index_type) \ - ((type *)riter->u.a.dim[i].v.vector)[0]) \ - - GFC_DIMENSION_LBOUND (dst->dim[i])) \ - * GFC_DIMENSION_STRIDE (dst->dim[i]) \ - * riter->item_size; \ - break - - switch (riter->u.a.dim[i].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_internal_error (vecrefunknownkind, stat, NULL, 0); - return; - } -#undef KINDCASE - break; - case CAF_ARR_REF_FULL: - if (dst) - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - GFC_DIMENSION_LBOUND (dst->dim[i]), - GFC_DIMENSION_UBOUND (dst->dim[i])); - else - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]), - GFC_DIMENSION_UBOUND (src->dim[src_cur_dim])); - break; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - riter->u.a.dim[i].s.start, - riter->u.a.dim[i].s.end); - memptr += (riter->u.a.dim[i].s.start - - dst->dim[i].lower_bound) - * GFC_DIMENSION_STRIDE (dst->dim[i]) - * riter->item_size; - break; - case CAF_ARR_REF_SINGLE: - delta = 1; - memptr += (riter->u.a.dim[i].s.start - - dst->dim[i].lower_bound) - * GFC_DIMENSION_STRIDE (dst->dim[i]) - * riter->item_size; - break; - case CAF_ARR_REF_OPEN_END: - if (dst) - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - riter->u.a.dim[i].s.start, - GFC_DIMENSION_UBOUND (dst->dim[i])); - else - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - riter->u.a.dim[i].s.start, - GFC_DIMENSION_UBOUND (src->dim[src_cur_dim])); - memptr += (riter->u.a.dim[i].s.start - - dst->dim[i].lower_bound) - * GFC_DIMENSION_STRIDE (dst->dim[i]) - * riter->item_size; - break; - case CAF_ARR_REF_OPEN_START: - if (dst) - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - GFC_DIMENSION_LBOUND (dst->dim[i]), - riter->u.a.dim[i].s.end); - else - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]), - riter->u.a.dim[i].s.end); - /* The memptr stays unchanged when ref'ing the first element - in a dimension. */ - break; - default: - caf_internal_error (unknownarrreftype, stat, NULL, 0); - return; - } - - if (delta <= 0) - return; - /* Check the various properties of the source array. - When src is an array. */ - if (delta > 1 && src_rank > 0) - { - /* Check that src_cur_dim is valid for src. Can be - superceeded only by scalar data. */ - if (src_cur_dim >= src_rank) - { - caf_internal_error (rankoutofrange, stat, NULL, 0); - return; - } - /* Do further checks, when the source is not scalar. */ - else - { - /* When the realloc is required, then no extent may have - been set. */ - extent_mismatch = memptr == NULL - || (dst - && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim) - != delta); - /* When it already known, that a realloc is needed or - the extent does not match the needed one. */ - if (extent_mismatch) - { - /* Check whether dst is reallocatable. */ - if (unlikely (!dst_reallocatable)) - { - caf_internal_error (nonallocextentmismatch, stat, - NULL, 0, delta, - GFC_DESCRIPTOR_EXTENT (dst, - src_cur_dim)); - return; - } - /* Report error on allocatable but missing inner - ref. */ - else if (riter->next != NULL) - { - caf_internal_error (realloconinnerref, stat, NULL, - 0); - return; - } - } - /* Only change the extent when it does not match. This is - to prevent resetting given array bounds. */ - if (extent_mismatch) - GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta, - size); - } - /* Increase the dim-counter of the src only when the extent - matches. */ - if (src_cur_dim < src_rank - && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta) - ++src_cur_dim; - } - size *= (index_type)delta; - } - break; - case CAF_REF_STATIC_ARRAY: - for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i) - { - switch (riter->u.a.mode[i]) - { - case CAF_ARR_REF_VECTOR: - delta = riter->u.a.dim[i].v.nvec; -#define KINDCASE(kind, type) case kind: \ - memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \ - * riter->item_size; \ - break - - switch (riter->u.a.dim[i].v.kind) - { - KINDCASE (1, GFC_INTEGER_1); - KINDCASE (2, GFC_INTEGER_2); - KINDCASE (4, GFC_INTEGER_4); -#ifdef HAVE_GFC_INTEGER_8 - KINDCASE (8, GFC_INTEGER_8); -#endif -#ifdef HAVE_GFC_INTEGER_16 - KINDCASE (16, GFC_INTEGER_16); -#endif - default: - caf_internal_error (vecrefunknownkind, stat, NULL, 0); - return; - } -#undef KINDCASE - break; - case CAF_ARR_REF_FULL: - delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride - + 1; - /* The memptr stays unchanged when ref'ing the first element - in a dimension. */ - break; - case CAF_ARR_REF_RANGE: - COMPUTE_NUM_ITEMS (delta, - riter->u.a.dim[i].s.stride, - riter->u.a.dim[i].s.start, - riter->u.a.dim[i].s.end); - memptr += riter->u.a.dim[i].s.start - * riter->u.a.dim[i].s.stride - * riter->item_size; - break; - case CAF_ARR_REF_SINGLE: - delta = 1; - memptr += riter->u.a.dim[i].s.start - * riter->u.a.dim[i].s.stride - * riter->item_size; - break; - case CAF_ARR_REF_OPEN_END: - /* This and OPEN_START are mapped to a RANGE and therefore - cannot occur here. */ - case CAF_ARR_REF_OPEN_START: - default: - caf_internal_error (unknownarrreftype, stat, NULL, 0); - return; - } - if (delta <= 0) - return; - /* Check the various properties of the source array. - Only when the source array is not scalar examine its - properties. */ - if (delta > 1 && src_rank > 0) - { - /* Check that src_cur_dim is valid for src. Can be - superceeded only by scalar data. */ - if (src_cur_dim >= src_rank) - { - caf_internal_error (rankoutofrange, stat, NULL, 0); - return; - } - else - { - /* We will not be able to realloc the dst, because that's - a fixed size array. */ - extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) - != delta; - /* When the extent does not match the needed one we can - only stop here. */ - if (extent_mismatch) - { - caf_internal_error (nonallocextentmismatch, stat, - NULL, 0, delta, - GFC_DESCRIPTOR_EXTENT (src, - src_cur_dim)); - return; - } - } - ++src_cur_dim; - } - size *= (index_type)delta; - } - break; - default: - caf_internal_error (unknownreftype, stat, NULL, 0); - return; - } - src_size = riter->item_size; - riter = riter->next; - } - if (size == 0 || src_size == 0) - return; - /* Postcondition: - - size contains the number of elements to store in the destination array, - - src_size gives the size in bytes of each item in the destination array. - */ - - /* Reset the token. */ - single_token = TOKEN (token); - memptr = single_token->memptr; - dst = single_token->desc; - memset (dst_index, 0, sizeof (dst_index)); - 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, dst_type); - assert (i == size); -} - - -void -_gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, - caf_reference_t *dst_refs, caf_token_t src_token, - 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 dst_type, int src_type) -{ - 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, - (gfc_descriptor_t *) &temp, src_refs, - dst_kind, src_kind, may_require_tmp, true, - src_stat, src_type); - - if (src_stat && *src_stat != 0) - return; - - _gfortran_caf_send_by_ref (dst_token, dst_image_index, - (gfc_descriptor_t *) &temp, dst_refs, - dst_kind, dst_kind, may_require_tmp, true, - dst_stat, dst_type); - if (GFC_DESCRIPTOR_DATA (&temp)) - free (GFC_DESCRIPTOR_DATA (&temp)); -} - void _gfortran_caf_register_accessor (const int hash, getter_t accessor) {