===================================================================
@@ -1,3 +1,80 @@
+2016-09-19 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ PR fortran/71952
+ * expr.c (gfc_check_assign): Added flag to control whether datatype
+ conversion is allowed.
+ * gfortran.h: Added caf-token-tree to gfc_component. Changed
+ prototypes mostly to add whether datatype conversion is allowed.
+ * gfortran.texi: Added documentation for the caf_reference_t and the
+ caf_*_by_ref function.
+ * primary.c (caf_variable_attr): Similar to gfc_variable_attr but
+ focused on the needs of coarrays.
+ (gfc_caf_attr): Same.
+ * resolve.c (resolve_ordinary_assign): Set the conversion allowed
+ flag when not in a coarray.
+ * trans-array.c (gfc_array_init_size): Moved setting of array
+ descriptor's datatype before the alloc, because caf_register needs it.
+ (gfc_array_allocate): Changed notion of whether an array is a coarray.
+ (gfc_array_deallocate): Same.
+ (gfc_alloc_allocatable_for_assignment): Added setting of coarray's
+ array descriptor datatype before the register. And using deregister/
+ register to mimmick a realloc for coarrays.
+ * trans-decl.c (gfc_build_builtin_function_decls): Corrected signatures
+ of old caf-functions and added signature definitions of the _by_ref
+ ones.
+ (generate_coarray_sym_init): Adapted to new caf_register signature.
+ * trans-expr.c (gfc_conv_scalar_to_descriptor): Make sure a constant
+ is translated to an lvalue expression before use in an array
+ descriptor.
+ (gfc_get_ultimate_alloc_ptr_comps_caf_token): New function. Get the
+ last allocatable component's coarray token.
+ (gfc_get_tree_for_caf_expr): For top-level object get the coarray
+ token and check for unsupported features.
+ (gfc_get_caf_token_offset): Getting the offset might procude new
+ statements, which now are stored in the pre and post of the current se.
+ (gfc_caf_get_image_index): For this image return a call to
+ caf_this_image.
+ (expr_may_alias_variables): Check that the result is set for testing
+ its properties.
+ (alloc_scalar_allocatable_for_assignment): Added auto allocation of
+ coarray components.
+ (gfc_trans_assignment_1): Rewrite an assign to a coarray object to
+ be a sendget.
+ * trans-intrinsic.c (conv_caf_vector_subscript_elem): Corrected
+ wrong comment.
+ (compute_component_offset): Compute the correct offset a structure
+ member.
+ (conv_expr_ref_to_caf_ref): Convert to a chain of refs into
+ caf_references.
+ (gfc_conv_intrinsic_caf_get): Call caf_get_by_ref instead of caf_get.
+ (conv_caf_send): Call caf_*_by_ref for coarrays that need
+ reallocation.
+ (gfc_conv_intrinsic_function): Adapted to new signuature of the caf
+ drivers.
+ (conv_intrinsic_atomic_op): Add pre and post statements correctly.
+ (conv_intrinsic_atomic_ref): Same.
+ (conv_intrinsic_atomic_cas): Same.
+ (conv_intrinsic_event_query): Same.
+ * trans-stmt.c (gfc_trans_lock_unlock): Same.
+ (gfc_trans_event_post_wait): Same.
+ (gfc_trans_allocate): Support allocation of allocatable coarrays.
+ (gfc_trans_deallocate): And there deallocation.
+ * trans-types.c (gfc_typenode_for_spec): Added flag to control whether
+ a component is part of coarray. When so, then add space to store a
+ coarray token.
+ (gfc_build_array_type): Same.
+ (gfc_get_array_descriptor_base): Same.
+ (gfc_get_array_type_bounds): Same.
+ (gfc_sym_type): Same.
+ (gfc_get_derived_type): Same.
+ (gfc_get_caf_reference_type): Declare the caf_reference_type.
+ * trans-types.h: Prototype changes only.
+ * trans.c (gfc_allocate_using_lib): Use the updated caf_register
+ signature.
+ (gfc_allocate_allocatable): Same.
+ (gfc_deallocate_with_status): Same.
+ * trans.h: Defined the runtime types for caf_reference_t and the enums.
+
2016-09-19 Fritz Reese <fritzoreese@gmail.com>
PR fortran/77584
===================================================================
@@ -3128,10 +3128,14 @@
/* Given an assignable expression and an arbitrary expression, make
- sure that the assignment can take place. */
+ sure that the assignment can take place. Only add a call to the intrinsic
+ conversion routines, when allow_convert is set. When this assign is a
+ coarray call, then the convert is done by the coarray routine implictly and
+ adding the intrinsic conversion would do harm in most cases. */
bool
-gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
+gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
+ bool allow_convert)
{
gfc_symbol *sym;
gfc_ref *ref;
@@ -3309,12 +3313,15 @@
kind values can be converted into one another. */
if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
{
- if (lvalue->ts.kind != rvalue->ts.kind)
+ if (lvalue->ts.kind != rvalue->ts.kind && allow_convert)
gfc_convert_chartype (rvalue, &lvalue->ts);
return true;
}
+ if (!allow_convert)
+ return true;
+
return gfc_convert_type (rvalue, &lvalue->ts, 1);
}
===================================================================
@@ -1043,6 +1043,8 @@
/* Needed for procedure pointer components. */
struct gfc_typebound_proc *tb;
+ /* When allocatable/pointer and in a coarray the associated token. */
+ tree caf_token;
}
gfc_component;
@@ -2768,7 +2770,7 @@
int gfc_get_int_kind_from_width_isofortranenv (int size);
int gfc_get_real_kind_from_width_isofortranenv (int size);
tree gfc_get_union_type (gfc_symbol *);
-tree gfc_get_derived_type (gfc_symbol * derived);
+tree gfc_get_derived_type (gfc_symbol * derived, bool in_coarray = false);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
extern int gfc_max_integer_kind;
@@ -3047,7 +3049,7 @@
int gfc_kind_max (gfc_expr *, gfc_expr *);
bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
-bool gfc_check_assign (gfc_expr *, gfc_expr *, int);
+bool gfc_check_assign (gfc_expr *, gfc_expr *, int, bool c = true);
bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
@@ -3212,6 +3214,7 @@
/* primary.c */
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
+symbol_attribute gfc_caf_attr (gfc_expr *, bool in_allocate = false);
match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool, bool);
int gfc_check_digit (char, int);
===================================================================
@@ -3571,6 +3571,7 @@
@menu
* caf_token_t::
* caf_register_t::
+* caf_reference_t::
@end menu
@node caf_token_t
@@ -3597,7 +3598,115 @@
caf_register_t;
@end verbatim
+@node caf_reference_t
+@subsection @code{caf_reference_t}
+The structure used for implementing arbitrary reference chains.
+A @code{CAF_REFERENCE_T} allows to specify a component reference or any kind
+of array reference of any rank supported by gfortran. For array references all
+kinds as known by the compiler/Fortran standard are supported indicated by
+a @code{MODE}.
+
+@verbatim
+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. I.e., the coarray object
+ has no array descriptor associated and the addressing is done
+ completely using the ref. */
+ CAF_REF_STATIC_ARRAY
+} caf_ref_type_t;
+@end verbatim
+
+@verbatim
+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;
+@end verbatim
+
+@verbatim
+/* 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.
+ Unused for allocatable or pointer components. */
+ 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;
+@end verbatim
+
+The references make up a single linked list of reference operations. The
+@code{NEXT} member links to the next reference or NULL to indicate the end of
+the chain. Component and array refs can be arbitrarly mixed as long as they
+comply to the Fortran standard.
+
+@emph{NOTES}
+The member @code{STATIC_ARRAY_TYPE} is used only when the @code{TYPE} is
+@code{CAF_REF_STATIC_ARRAY}. The member gives the type of the data referenced.
+Because no array descriptor is available for a descriptor-less array and
+type conversion still needs to take place the type is transported here.
+
+At the moment @code{CAF_ARR_REF_VECTOR} is not implemented in the front end for
+descriptor-less arrays. The library caf_single has untested support for it.
+
+
@node Function ABI Documentation
@section Function ABI Documentation
@@ -3611,6 +3720,9 @@
* _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_sendget_by_ref:: Sending data between remote images using enhanced references
* _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable
* _gfortran_caf_event_post:: Post an event
@@ -3742,19 +3854,24 @@
@node _gfortran_caf_register
@subsection @code{_gfortran_caf_register} --- Registering coarrays
-@cindex Coarray, _gfortran_caf_deregister
+@cindex Coarray, _gfortran_caf_register
@table @asis
@item @emph{Description}:
-Allocates memory for a coarray and creates a token to identify the coarray. The
-function is called for both coarrays with @code{SAVE} attribute and using an
-explicit @code{ALLOCATE} statement. If an error occurs and @var{STAT} is a
+Registers memory for a coarray and creates a token to identify the coarray. The
+routine is called for both coarrays with @code{SAVE} attribute and using an
+explicit @code{ALLOCATE} statement. If an error occurs and @var{STAT} is a
@code{NULL} pointer, the function shall abort with printing an error message
and starting the error termination. If no error occurs and @var{STAT} is
-present, it shall be set to zero. Otherwise, it shall be set to a positive
+present, it shall be set to zero. Otherwise, it shall be set to a positive
value and, if not-@code{NULL}, @var{ERRMSG} shall be set to a string describing
-the failure. The function shall return a pointer to the requested memory
-for the local image as a call to @code{malloc} would do.
+the failure. The routine shall register the memory provided in the
+@code{DATA}-component of the array descriptor @var{DESC}, when that component
+is non-@code{NULL}, else it shall allocate sufficient memory and provide a
+pointer to it in the @code{DATA}-component of @var{DESC}. The array descriptor
+has rank zero, when a scalar object is to be registered and the array
+descriptor may be invalid after the call to @code{_gfortran_caf_register}.
+When an array is to be allocated the descriptor persists.
For @code{CAF_REGTYPE_COARRAY_STATIC} and @code{CAF_REGTYPE_COARRAY_ALLOC},
the passed size is the byte size requested. For @code{CAF_REGTYPE_LOCK_STATIC},
@@ -3763,8 +3880,8 @@
@item @emph{Syntax}:
-@code{void *caf_register (size_t size, caf_register_t type, caf_token_t *token,
-int *stat, char *errmsg, int errmsg_len)}
+@code{void caf_register (size_t size, caf_register_t type, caf_token_t *token,
+gfc_descriptor_t *desc, int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@@ -3772,6 +3889,7 @@
allocated; for lock types and event types, the number of elements.
@item @var{type} @tab one of the caf_register_t types.
@item @var{token} @tab intent(out) An opaque pointer identifying the coarray.
+@item @var{desc} @tab intent(inout) The (pseudo) array descriptor.
@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
@@ -3787,12 +3905,12 @@
static memory is used. The token permits to identify the coarray; to the
processor, the token is a nonaliasing pointer. The library can, for instance,
store the base address of the coarray in the token, some handle or a more
-complicated struct.
+complicated struct. The library may also store the array descriptor
+@var{DESC} when its rank is non-zero.
-For normal coarrays, the returned pointer is used for accesses on the local
-image. For lock types, the value shall only used for checking the allocation
+For lock types, the value shall only used for checking the allocation
status. Note that for critical blocks, the locking is only required on one
-image; in the locking statement, the processor shall always pass always an
+image; in the locking statement, the processor shall always pass an
image index of one for critical-block lock variables
(@code{CAF_REGTYPE_CRITICAL}). For lock types and critical-block variables,
the initial value shall be unlocked (or, respecitively, not in critical
@@ -3800,7 +3918,6 @@
be no event, e.g. zero.
@end table
-
@node _gfortran_caf_deregister
@subsection @code{_gfortran_caf_deregister} --- Deregistering coarrays
@cindex Coarray, _gfortran_caf_deregister
@@ -3809,14 +3926,17 @@
@item @emph{Description}:
Called to free the memory of a coarray; the processor calls this function for
automatic and explicit deallocation. In case of an error, this function shall
-fail with an error message, unless the @var{STAT} variable is not null.
+fail with an error message, unless the @var{STAT} variable is not null. The
+library is only expected to free memory it allocated itself during a call to
+@code{_gfortran_caf_register}.
@item @emph{Syntax}:
-@code{void caf_deregister (const caf_token_t *token, int *stat, char *errmsg,
+@code{void caf_deregister (caf_token_t *token, int *stat, char *errmsg,
int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
+@item @var{token} @tab the token to free.
@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set
to an error message; may be NULL
@@ -3997,7 +4117,187 @@
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 whole array from a local to a
+remote image identified by the 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)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{image_index} @tab 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 Kind of the destination argument
+@item @var{src_kind} @tab Kind of the source argument
+@item @var{may_require_tmp} @tab The variable is false it is known at compile
+time that the @var{dest} and @var{src} either cannot overlap or overlap (fully
+or partially) such that walking @var{src} and @var{dest} in element wise
+element order (honoring the stride value) will not lead to wrong results.
+Otherwise, the value is true.
+@item @var{dst_reallocatable} @tab set when the destination is of allocatable
+or pointer type and the refs will 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 non-zero on error. When @code{NULL} and
+error occurs, then an error message is printed and the program is terminated.
+@end multitable
+
+@item @emph{NOTES}
+It is permitted to have image_id equal the current image; the memory of the
+send-to and the send-from might (partially) overlap in that case. The
+implementation has to take care that it handles this case, 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 whole array from a a remote image
+identified by the 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)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
+@item @var{image_index} @tab 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 Kind of the destination argument
+@item @var{src_kind} @tab Kind of the source argument
+@item @var{may_require_tmp} @tab The variable is false it is known at compile
+time that the @var{dest} and @var{src} either cannot overlap or overlap (fully
+or partially) such that walking @var{src} and @var{dest} in element wise
+element order (honoring the stride value) will not lead to wrong results.
+Otherwise, the value is true.
+@item @var{dst_reallocatable} @tab 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 non-zero on error. When @code{NULL} and
+error occurs, then an error message is printed and the program is terminated.
+@end multitable
+
+@item @emph{NOTES}
+It is permitted to have image_id equal the current image; the memory of the
+send-to and the send-from might (partially) overlap in that case. The
+implementation has to take care that it handles this case, 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_sendget_by_ref
+@subsection @code{_gfortran_caf_sendget_by_ref} --- Sending data between remote images using enhanced references on both sides
+@cindex Coarray, _gfortran_caf_sendget_by_ref
+
+@table @asis
+@item @emph{Description}:
+Called to send a scalar, an array section or whole array from a remote image
+identified by the src_image_index to a remote image identified by the
+dst_image_index.
+
+@item @emph{Syntax}:
+@code{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)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{dst_token} @tab intent(in) An opaque pointer identifying the
+destination coarray.
+@item @var{dst_image_index} @tab The ID of the destination remote image; must
+be a positive number.
+@item @var{dst_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{src_token} @tab An opaque pointer identifying the source coarray.
+@item @var{src_image_index} @tab The ID of the source remote image; must be a
+positive number.
+@item @var{src_refs} @tab intent(in) the references to apply to the remote
+structure to get the data.
+@item @var{dst_kind} @tab Kind of the destination argument
+@item @var{src_kind} @tab Kind of the source argument
+@item @var{may_require_tmp} @tab The variable is false it is known at compile
+time that the @var{dest} and @var{src} either cannot overlap or overlap (fully
+or partially) such that walking @var{src} and @var{dest} in element wise
+element order (honoring the stride value) will not lead to wrong results.
+Otherwise, the value is true.
+@item @var{dst_stat} @tab intent(out) when non-@code{NULL} give the result of
+the send-operation, i.e., zero on success and non-zero on error. When
+@code{NULL} and an error occurs, then an error message is printed and the
+program is terminated.
+@item @var{src_stat} @tab intent(out) when non-@code{NULL} give the result of
+the get-operation, i.e., zero on success and non-zero on error. When
+@code{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 image_ids equal; the memory of the send-to and the
+send-from might (partially) overlap in that case. The implementation has to
+take care that it handles this case, e.g. using @code{memmove} which handles
+(partially) overlapping memory. If @var{may_require_tmp} is true, the library
+might additionally create a temporary variable, unless additional checks show
+that this is not required (e.g. because walking backward is possible or because
+both arrays are contiguous and @code{memmove} takes care of overlap issues).
+
+Note that the assignment of a scalar to an array is permitted. In addition,
+the library has to handle numeric-type conversion and for strings, padding and
+different character kinds.
+
+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_lock
@subsection @code{_gfortran_caf_lock} --- Locking a lock variable
@cindex Coarray, _gfortran_caf_lock
===================================================================
@@ -2376,6 +2376,163 @@
}
+/* Given an expression, figure out what the ultimate expression
+ attribute is. This routine is similar to gfc_variable_attr with
+ parts of gfc_expr_attr, but focuses more on the needs of
+ coarrays. For coarrays a codimension attribute is kind of
+ "infectious" being propagated once set and never cleared. */
+
+static symbol_attribute
+caf_variable_attr (gfc_expr *expr, bool in_allocate)
+{
+ int dimension, codimension, pointer, allocatable, target, coarray_comp,
+ alloc_comp;
+ symbol_attribute attr;
+ gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
+
+ if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
+ gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
+
+ sym = expr->symtree->n.sym;
+ gfc_clear_attr (&attr);
+
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ {
+ dimension = CLASS_DATA (sym)->attr.dimension;
+ codimension = CLASS_DATA (sym)->attr.codimension;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ coarray_comp = CLASS_DATA (sym)->attr.coarray_comp;
+ alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
+ }
+ else
+ {
+ dimension = sym->attr.dimension;
+ codimension = sym->attr.codimension;
+ pointer = sym->attr.pointer;
+ allocatable = sym->attr.allocatable;
+ coarray_comp = sym->attr.coarray_comp;
+ alloc_comp = sym->ts.type == BT_DERIVED
+ ? sym->ts.u.derived->attr.alloc_comp : 0;
+ }
+
+ target = attr.target;
+ if (pointer || attr.proc_pointer)
+ target = 1;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+
+ switch (ref->u.ar.type)
+ {
+ case AR_FULL:
+ case AR_SECTION:
+ dimension = 1;
+ break;
+
+ case AR_ELEMENT:
+ /* Handle coarrays. */
+ if (ref->u.ar.dimen > 0 && !in_allocate)
+ allocatable = pointer = 0;
+ break;
+
+ case AR_UNKNOWN:
+ /* If any of start, end or stride is not integer, there will
+ already have been an error issued. */
+ int errors;
+ gfc_get_errors (NULL, &errors);
+ if (errors == 0)
+ gfc_internal_error ("gfc_caf_attr(): Bad array reference");
+ }
+
+ break;
+
+ case REF_COMPONENT:
+ comp = ref->u.c.component;
+
+ if (comp->ts.type == BT_CLASS)
+ {
+ codimension |= CLASS_DATA (comp)->attr.codimension;
+ pointer = CLASS_DATA (comp)->attr.class_pointer;
+ allocatable = CLASS_DATA (comp)->attr.allocatable;
+ coarray_comp |= CLASS_DATA (comp)->attr.coarray_comp;
+ }
+ else
+ {
+ codimension |= comp->attr.codimension;
+ pointer = comp->attr.pointer;
+ allocatable = comp->attr.allocatable;
+ coarray_comp |= comp->attr.coarray_comp;
+ }
+
+ if (pointer || attr.proc_pointer)
+ target = 1;
+
+ break;
+
+ case REF_SUBSTRING:
+ allocatable = pointer = 0;
+ break;
+ }
+
+ attr.dimension = dimension;
+ attr.codimension = codimension;
+ attr.pointer = pointer;
+ attr.allocatable = allocatable;
+ attr.target = target;
+ attr.save = sym->attr.save;
+ attr.coarray_comp = coarray_comp;
+ attr.alloc_comp = alloc_comp;
+
+ return attr;
+}
+
+
+symbol_attribute
+gfc_caf_attr (gfc_expr *e, bool in_allocate)
+{
+ symbol_attribute attr;
+
+ switch (e->expr_type)
+ {
+ case EXPR_VARIABLE:
+ attr = caf_variable_attr (e, in_allocate);
+ break;
+
+ case EXPR_FUNCTION:
+ gfc_clear_attr (&attr);
+
+ if (e->value.function.esym && e->value.function.esym->result)
+ {
+ gfc_symbol *sym = e->value.function.esym->result;
+ attr = sym->attr;
+ if (sym->ts.type == BT_CLASS)
+ {
+ attr.dimension = CLASS_DATA (sym)->attr.dimension;
+ attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
+ attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
+ attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
+ }
+ }
+ else if (e->symtree)
+ attr = caf_variable_attr (e, in_allocate);
+ else
+ gfc_clear_attr (&attr);
+ break;
+
+ default:
+ gfc_clear_attr (&attr);
+ break;
+ }
+
+ return attr;
+}
+
+
/* Match a structure constructor. The initial symbol has already been
seen. */
===================================================================
@@ -9839,13 +9839,22 @@
return false;
}
- gfc_check_assign (lhs, rhs, 1);
-
/* Assign the 'data' of a class object to a derived type. */
if (lhs->ts.type == BT_DERIVED
&& rhs->ts.type == BT_CLASS)
gfc_add_data_component (rhs);
+ bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
+ && (lhs_coindexed
+ || (code->expr2->expr_type == EXPR_FUNCTION
+ && code->expr2->value.function.isym
+ && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
+ && (code->expr1->rank == 0 || code->expr2->rank != 0)
+ && !gfc_expr_attr (rhs).allocatable
+ && !gfc_has_vector_subscript (rhs)));
+
+ gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send);
+
/* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
Additionally, insert this code when the RHS is a CAF as we then use the
GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
@@ -9852,14 +9861,7 @@
the LHS is (re)allocatable or has a vector subscript. If the LHS is a
noncoindexed array and the RHS is a coindexed scalar, use the normal code
path. */
- if (flag_coarray == GFC_FCOARRAY_LIB
- && (lhs_coindexed
- || (code->expr2->expr_type == EXPR_FUNCTION
- && code->expr2->value.function.isym
- && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
- && (code->expr1->rank == 0 || code->expr2->rank != 0)
- && !gfc_expr_attr (rhs).allocatable
- && !gfc_has_vector_subscript (rhs))))
+ if (caf_convert_to_send)
{
if (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
===================================================================
@@ -5083,19 +5083,19 @@
stride = gfc_index_one_node;
offset = gfc_index_zero_node;
- /* Set the dtype. */
+ /* Set the dtype before the alloc, because registration of coarrays needs
+ it initialized. */
if (expr->ts.type == BT_CHARACTER && expr->ts.deferred
&& TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL)
{
type = gfc_typenode_for_spec (&expr->ts);
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (descriptor_block, tmp,
- gfc_get_dtype_rank_type (rank, type));
+ gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type));
+ gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
}
or_expr = boolean_false_node;
@@ -5404,7 +5404,8 @@
stmtblock_t elseblock;
gfc_expr **lower;
gfc_expr **upper;
- gfc_ref *ref, *prev_ref = NULL;
+ gfc_ref *ref, *prev_ref = NULL, *coref;
+ gfc_se caf_se;
bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
@@ -5418,16 +5419,25 @@
if (!prev_ref)
{
allocatable = expr->symtree->n.sym->attr.allocatable;
- coarray = expr->symtree->n.sym->attr.codimension;
dimension = expr->symtree->n.sym->attr.dimension;
}
else
{
allocatable = prev_ref->u.c.component->attr.allocatable;
- coarray = prev_ref->u.c.component->attr.codimension;
dimension = prev_ref->u.c.component->attr.dimension;
}
+ /* For allocatable/pointer arrays in derived types, one of the refs has to be
+ a coarray. In this case it does not matter whether we are on this_image
+ or not. */
+ coarray = false;
+ for (coref = expr->ref; coref; coref = coref->next)
+ if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0)
+ {
+ coarray = true;
+ break;
+ }
+
if (!dimension)
gcc_assert (coarray);
@@ -5482,6 +5492,9 @@
overflow = integer_zero_node;
gfc_init_block (&set_descriptor_block);
+ /* Take the corank only from the actual ref and not from the coref. The
+ later will mislead the generation of the array dimensions for allocatable/
+ pointer components in derived types. */
size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
: ref->u.ar.as->rank,
coarray ? ref->u.ar.as->corank : 0,
@@ -5517,6 +5530,7 @@
}
}
+ gfc_init_se (&caf_se, NULL);
gfc_start_block (&elseblock);
/* Allocate memory to store the data. */
@@ -5527,16 +5541,22 @@
STRIP_NOPS (pointer);
if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
- token = gfc_build_addr_expr (NULL_TREE,
- gfc_conv_descriptor_token (se->expr));
+ {
+ tmp = gfc_get_tree_for_caf_expr (expr);
+ gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE, expr);
+ gfc_add_block_to_block (&elseblock, &caf_se.pre);
+ token = gfc_build_addr_expr (NULL_TREE, token);
+ }
/* The allocatable variant takes the old pointer as first argument. */
if (allocatable)
gfc_allocate_allocatable (&elseblock, pointer, size, token,
- status, errmsg, errlen, label_finish, expr);
+ status, errmsg, errlen, label_finish, expr,
+ coref != NULL ? coref->u.ar.as->corank : 0);
else
gfc_allocate_using_malloc (&elseblock, pointer, size, status);
+ gfc_add_block_to_block (&elseblock, &caf_se.post);
if (dimension)
{
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
@@ -5592,7 +5612,7 @@
tree var;
tree tmp;
stmtblock_t block;
- bool coarray = gfc_is_coarray (expr);
+ bool coarray = gfc_caf_attr (expr).codimension;
gfc_start_block (&block);
@@ -8659,6 +8679,10 @@
int n;
int dim;
gfc_array_spec * as;
+ bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
+ && gfc_caf_attr (expr1, true).codimension);
+ tree token;
+ gfc_se caf_se;
/* x = f(...) with x allocatable. In this case, expr1 is the rhs.
Find the lhs expression in the loop chain and set expr1 and
@@ -8973,11 +8997,30 @@
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr1->rank,type));
}
+ else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (TREE_TYPE (desc)));
+ }
/* Realloc expression. Note that the scalarizer uses desc.data
in the array reference - (*desc.data)[<element>]. */
gfc_init_block (&realloc_block);
+ gfc_init_se (&caf_se, NULL);
+ if (coarray)
+ {
+ token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
+ if (token == NULL_TREE)
+ {
+ tmp = gfc_get_tree_for_caf_expr (expr1);
+ gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
+ expr1);
+ token = gfc_build_addr_expr (NULL_TREE, token);
+ }
+
+ gfc_add_block_to_block (&realloc_block, &caf_se.pre);
+ }
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
{
@@ -8986,12 +9029,32 @@
gfc_add_expr_to_block (&realloc_block, tmp);
}
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- fold_convert (pvoid_type_node, array1),
- size2);
- gfc_conv_descriptor_data_set (&realloc_block,
- desc, tmp);
+ if (!coarray)
+ {
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
+ fold_convert (pvoid_type_node, array1),
+ size2);
+ gfc_conv_descriptor_data_set (&realloc_block,
+ desc, tmp);
+ }
+ else
+ {
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_deregister,
+ 4, token, null_pointer_node,
+ null_pointer_node, integer_zero_node);
+ gfc_add_expr_to_block (&realloc_block, tmp);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_register,
+ 7, size2,
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_ALLOC),
+ token, gfc_build_addr_expr (NULL_TREE, desc),
+ null_pointer_node, null_pointer_node,
+ integer_zero_node);
+ gfc_add_expr_to_block (&realloc_block, tmp);
+ }
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
@@ -9001,6 +9064,7 @@
gfc_add_expr_to_block (&realloc_block, tmp);
}
+ gfc_add_block_to_block (&realloc_block, &caf_se.post);
realloc_expr = gfc_finish_block (&realloc_block);
/* Only reallocate if sizes are different. */
@@ -9011,16 +9075,33 @@
/* Malloc expression. */
gfc_init_block (&alloc_block);
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MALLOC),
- 1, size2);
- gfc_conv_descriptor_data_set (&alloc_block,
- desc, tmp);
+ if (!coarray)
+ {
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size2);
+ gfc_conv_descriptor_data_set (&alloc_block,
+ desc, tmp);
+ }
+ else
+ {
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_register,
+ 7, size2,
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_ALLOC),
+ token, gfc_build_addr_expr (NULL_TREE, desc),
+ null_pointer_node, null_pointer_node,
+ integer_zero_node);
+ gfc_add_expr_to_block (&alloc_block, tmp);
+ }
+
/* We already set the dtype in the case of deferred character
length arrays. */
if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
- && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
+ && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ || coarray)))
{
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
===================================================================
@@ -135,6 +135,9 @@
tree gfor_fndecl_caf_get;
tree gfor_fndecl_caf_send;
tree gfor_fndecl_caf_sendget;
+tree gfor_fndecl_caf_get_by_ref;
+tree gfor_fndecl_caf_send_by_ref;
+tree gfor_fndecl_caf_sendget_by_ref;
tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_memory;
tree gfor_fndecl_caf_sync_images;
@@ -3560,12 +3563,12 @@
2, integer_type_node, integer_type_node);
gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
- size_type_node, integer_type_node, ppvoid_type_node, pint_type,
- pchar_type_node, integer_type_node);
+ get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node, 7,
+ size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node,
+ pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
+ get_identifier (PREFIX("caf_deregister")), "WWWR", void_type_node, 4,
ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
@@ -3581,12 +3584,32 @@
boolean_type_node, pint_type);
gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node,
- 13, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
- pvoid_type_node, pvoid_type_node, size_type_node, integer_type_node,
- pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
- boolean_type_node);
+ get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR",
+ 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_get_by_ref = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRW", void_type_node,
+ 9, 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);
+
+ gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRW", void_type_node,
+ 9, 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);
+
+ gfor_fndecl_caf_sendget_by_ref
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWW",
+ void_type_node, 11, 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);
+
gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3, pint_type, pchar_type_node, integer_type_node);
@@ -5002,9 +5025,11 @@
static void
generate_coarray_sym_init (gfc_symbol *sym)
{
- tree tmp, size, decl, token;
+ tree tmp, size, decl, token, desc;
bool is_lock_type, is_event_type;
int reg_type;
+ gfc_se se;
+ symbol_attribute attr;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
|| sym->attr.use_assoc || !sym->attr.referenced
@@ -5055,12 +5080,20 @@
reg_type = GFC_CAF_EVENT_STATIC;
else
reg_type = GFC_CAF_COARRAY_STATIC;
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
+
+ gfc_init_se (&se, NULL);
+ desc = gfc_conv_scalar_to_descriptor (&se, decl, attr);
+ gfc_add_block_to_block (&caf_init_block, &se.pre);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
build_int_cst (integer_type_node, reg_type),
- token, null_pointer_node, /* token, stat. */
+ token, gfc_build_addr_expr (pvoid_type_node, desc),
+ null_pointer_node, /* stat. */
null_pointer_node, /* errgmsg, errmsg_len. */
build_int_cst (integer_type_node, 0));
- gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
+ gfc_add_expr_to_block (&caf_init_block, tmp);
+ gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
+ gfc_conv_descriptor_data_get (desc)));
/* Handle "static" initializer. */
if (sym->value)
===================================================================
@@ -72,6 +72,13 @@
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
+ if (CONSTANT_CLASS_P (scalar))
+ {
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (&se->pre, tmp, scalar);
+ scalar = tmp;
+ }
if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
scalar = gfc_build_addr_expr (NULL_TREE, scalar);
gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
@@ -88,6 +95,56 @@
}
+/* Get the coarray token from the ultimate array or component ref.
+ Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
+
+tree
+gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
+{
+ gfc_symbol *sym = expr->symtree->n.sym;
+ bool is_coarray = sym->attr.codimension;
+ gfc_expr *caf_expr = gfc_copy_expr (expr);
+ gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
+
+ while (ref)
+ {
+ if (ref->type == REF_COMPONENT
+ && (ref->u.c.component->attr.allocatable
+ || ref->u.c.component->attr.pointer)
+ && (is_coarray || ref->u.c.component->attr.codimension))
+ last_caf_ref = ref;
+ ref = ref->next;
+ }
+
+ if (last_caf_ref == NULL)
+ return NULL_TREE;
+
+ tree comp = last_caf_ref->u.c.component->caf_token, caf;
+ gfc_se se;
+ bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
+ if (comp == NULL_TREE && comp_ref)
+ return NULL_TREE;
+ gfc_init_se (&se, outerse);
+ gfc_free_ref_list (last_caf_ref->next);
+ last_caf_ref->next = NULL;
+ caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
+ se.want_pointer = comp_ref;
+ gfc_conv_expr (&se, caf_expr);
+ gfc_add_block_to_block (&outerse->pre, &se.pre);
+
+ if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
+ se.expr = TREE_OPERAND (se.expr, 0);
+ gfc_free_expr (caf_expr);
+
+ if (comp_ref)
+ caf = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (comp), se.expr, comp, NULL_TREE);
+ else
+ caf = gfc_conv_descriptor_token (se.expr);
+ return gfc_build_addr_expr (NULL_TREE, caf);
+}
+
+
/* This is the seed for an eventual trans-class.c
The following parameters should not be used directly since they might
@@ -1827,69 +1884,51 @@
{
tree caf_decl;
bool found = false;
- gfc_ref *ref, *comp_ref = NULL;
+ gfc_ref *ref;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
/* Not-implemented diagnostic. */
+ if (expr->symtree->n.sym->ts.type == BT_CLASS
+ && UNLIMITED_POLY (expr->symtree->n.sym)
+ && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+ gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
+ "%L is not supported", &expr->where);
+
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
{
- comp_ref = ref;
- if ((ref->u.c.component->ts.type == BT_CLASS
- && !CLASS_DATA (ref->u.c.component)->attr.codimension
- && (CLASS_DATA (ref->u.c.component)->attr.pointer
- || CLASS_DATA (ref->u.c.component)->attr.allocatable))
- || (ref->u.c.component->ts.type != BT_CLASS
- && !ref->u.c.component->attr.codimension
- && (ref->u.c.component->attr.pointer
- || ref->u.c.component->attr.allocatable)))
- gfc_error ("Sorry, coindexed access to a pointer or allocatable "
- "component of the coindexed coarray at %L is not yet "
- "supported", &expr->where);
+ if (ref->u.c.component->ts.type == BT_CLASS
+ && UNLIMITED_POLY (ref->u.c.component)
+ && CLASS_DATA (ref->u.c.component)->attr.codimension)
+ gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
+ "component at %L is not supported", &expr->where);
}
- if ((!comp_ref
- && ((expr->symtree->n.sym->ts.type == BT_CLASS
- && CLASS_DATA (expr->symtree->n.sym)->attr.alloc_comp)
- || (expr->symtree->n.sym->ts.type == BT_DERIVED
- && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)))
- || (comp_ref
- && ((comp_ref->u.c.component->ts.type == BT_CLASS
- && CLASS_DATA (comp_ref->u.c.component)->attr.alloc_comp)
- || (comp_ref->u.c.component->ts.type == BT_DERIVED
- && comp_ref->u.c.component->ts.u.derived->attr.alloc_comp))))
- gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
- "not yet supported", &expr->where);
- if (expr->rank)
+ caf_decl = expr->symtree->n.sym->backend_decl;
+ gcc_assert (caf_decl);
+ if (expr->symtree->n.sym->ts.type == BT_CLASS)
{
- /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
- general not possible as the required stride multiplier might be not
- a multiple of c_sizeof(b). In case of noncoindexed access, the
- scalarizer often takes care of it - for coarrays, it always fails. */
+ if (expr->ref && expr->ref->type == REF_ARRAY)
+ {
+ caf_decl = gfc_class_data_get (caf_decl);
+ if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+ return caf_decl;
+ }
for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT
- && ((ref->u.c.component->ts.type == BT_CLASS
- && CLASS_DATA (ref->u.c.component)->attr.codimension)
- || (ref->u.c.component->ts.type != BT_CLASS
- && ref->u.c.component->attr.codimension)))
- break;
- if (ref == NULL)
- ref = expr->ref;
- for ( ; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.dimen)
- break;
- for ( ; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- gfc_error ("Sorry, coindexed access at %L to a scalar component "
- "with an array partref is not yet supported",
- &expr->where);
+ {
+ if (ref->type == REF_COMPONENT
+ && strcmp (ref->u.c.component->name, "_data") != 0)
+ {
+ caf_decl = gfc_class_data_get (caf_decl);
+ if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+ return caf_decl;
+ break;
+ }
+ else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
+ break;
+ }
}
-
- caf_decl = expr->symtree->n.sym->backend_decl;
- gcc_assert (caf_decl);
- if (expr->symtree->n.sym->ts.type == BT_CLASS)
- caf_decl = gfc_class_data_get (caf_decl);
if (expr->symtree->n.sym->attr.codimension)
return caf_decl;
@@ -1907,7 +1946,14 @@
TREE_TYPE (comp->backend_decl), caf_decl,
comp->backend_decl, NULL_TREE);
if (comp->ts.type == BT_CLASS)
- caf_decl = gfc_class_data_get (caf_decl);
+ {
+ caf_decl = gfc_class_data_get (caf_decl);
+ if (CLASS_DATA (comp)->attr.codimension)
+ {
+ found = true;
+ break;
+ }
+ }
if (comp->attr.codimension)
{
found = true;
@@ -1922,8 +1968,8 @@
/* Obtain the Coarray token - and optionally also the offset. */
void
-gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr,
- gfc_expr *expr)
+gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
+ tree se_expr, gfc_expr *expr)
{
tree tmp;
@@ -1978,7 +2024,47 @@
*offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
*offset, fold_convert (gfc_array_index_type, tmp));
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
+ if (expr->symtree->n.sym->ts.type == BT_DERIVED
+ && expr->symtree->n.sym->attr.codimension
+ && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+ {
+ gfc_expr *base_expr = gfc_copy_expr (expr);
+ gfc_ref *ref = base_expr->ref;
+ gfc_se base_se;
+
+ // Iterate through the refs until the last one.
+ while (ref->next)
+ ref = ref->next;
+
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type != AR_FULL)
+ {
+ const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
+ int i;
+ for (i = 0; i < ranksum; ++i)
+ {
+ ref->u.ar.start[i] = NULL;
+ ref->u.ar.end[i] = NULL;
+ }
+ ref->u.ar.type = AR_FULL;
+ }
+ gfc_init_se (&base_se, NULL);
+ if (gfc_caf_attr (base_expr).dimension)
+ {
+ gfc_conv_expr_descriptor (&base_se, base_expr);
+ tmp = gfc_conv_descriptor_data_get (base_se.expr);
+ }
+ else
+ {
+ gfc_conv_expr (&base_se, base_expr);
+ tmp = base_se.expr;
+ }
+
+ gfc_free_expr (base_expr);
+ gfc_add_block_to_block (&se->pre, &base_se.pre);
+ gfc_add_block_to_block (&se->post, &base_se.post);
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
tmp = gfc_conv_descriptor_data_get (caf_decl);
else
{
@@ -2009,6 +2095,12 @@
break;
gcc_assert (ref != NULL);
+ if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
+ {
+ return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
+ integer_zero_node);
+ }
+
img_idx = integer_zero_node;
extent = integer_one_node;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
@@ -4647,10 +4739,11 @@
{
gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
- if ((proc_ifc->result->ts.type == BT_CLASS
- && proc_ifc->result->ts.u.derived->attr.is_class
- && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
- || proc_ifc->result->attr.pointer)
+ if (proc_ifc->result != NULL
+ && ((proc_ifc->result->ts.type == BT_CLASS
+ && proc_ifc->result->ts.u.derived->attr.is_class
+ && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
+ || proc_ifc->result->attr.pointer))
return true;
else
return false;
@@ -9064,8 +9157,26 @@
size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
size_in_bytes, size_one_node);
- if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
+ if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
{
+ tree caf_decl, token;
+ gfc_se caf_se;
+ symbol_attribute attr;
+
+ gfc_clear_attr (&attr);
+ gfc_init_se (&caf_se, NULL);
+
+ caf_decl = gfc_get_tree_for_caf_expr (expr1);
+ gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
+ NULL);
+ gfc_add_block_to_block (block, &caf_se.pre);
+ gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
+ gfc_build_addr_expr (NULL_TREE, token),
+ NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
+ expr1, 1);
+ }
+ else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
+ {
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_CALLOC),
2, build_one_cst (size_type_node),
@@ -9242,6 +9353,7 @@
tree string_length;
int n;
bool maybe_workshare = false;
+ symbol_attribute lhs_caf_attr, rhs_caf_attr;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -9262,6 +9374,9 @@
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
+ lhs_caf_attr = gfc_caf_attr (expr1);
+ rhs_caf_attr = gfc_caf_attr (expr2);
+
if (lss != gfc_ss_terminator)
{
/* The assignment needs scalarization. */
@@ -9440,10 +9555,26 @@
gfc_add_block_to_block (&loop.post, &rse.post);
}
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- gfc_expr_is_variable (expr2) || scalar_to_array
- || expr2->expr_type == EXPR_ARRAY,
- !(l_is_temp || init_flag) && dealloc);
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && lhs_caf_attr.codimension && rhs_caf_attr.codimension
+ && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
+ {
+ gfc_code code;
+ gfc_actual_arglist a1, a2;
+ a1.expr = expr1;
+ a1.next = &a2;
+ a2.expr = expr2;
+ a2.next = NULL;
+ code.ext.actual = &a1;
+ code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
+ tmp = gfc_conv_intrinsic_subroutine (&code);
+ }
+ else
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ gfc_expr_is_variable (expr2)
+ || scalar_to_array
+ || expr2->expr_type == EXPR_ARRAY,
+ !(l_is_temp || init_flag) && dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
@@ -9490,11 +9621,9 @@
/* F2003: Allocate or reallocate lhs of allocatable array. */
if (flag_realloc_lhs
- && gfc_is_reallocatable_lhs (expr1)
- && !gfc_expr_attr (expr1).codimension
- && !gfc_is_coindexed (expr1)
- && expr2->rank
- && !is_runtime_conformable (expr1, expr2))
+ && gfc_is_reallocatable_lhs (expr1)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2))
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
===================================================================
@@ -982,7 +982,7 @@
if (vector != NULL_TREE)
{
- /* Set dim.lower/upper/stride. */
+ /* 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);
@@ -994,7 +994,7 @@
}
else
{
- /* Set vector and kind. */
+ /* 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);
@@ -1094,16 +1094,481 @@
}
+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;
+ 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;
+ }
+
+ /* Prevent uninit-warning. */
+ reference_type = NULL_TREE;
+ 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.dimension)
+ {
+ tree arr_desc_token_offset;
+ /* Get the token from the descriptor. */
+ arr_desc_token_offset = gfc_advance_chain (
+ TYPE_FIELDS (TREE_TYPE (ref->u.c.component->backend_decl)),
+ 4 /* CAF_TOKEN_FIELD */);
+ 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 (ref->u.c.component->caf_token,
+ 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;
+ 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 can not 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;
+
+ /* Intentionally 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;
+}
+
/* Get data from a remote coarray. */
static void
gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
- tree may_require_tmp)
+ tree may_require_tmp, bool may_realloc,
+ symbol_attribute *caf_attr)
{
gfc_expr *array_expr, *tmp_stat;
gfc_se argse;
tree caf_decl, token, offset, image_index, tmp;
tree res_var, dst_var, type, kind, vec, stat;
+ tree caf_reference;
+ symbol_attribute caf_attr_store;
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
@@ -1118,6 +1583,12 @@
array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
type = gfc_typenode_for_spec (&array_expr->ts);
+ if (caf_attr == NULL)
+ {
+ caf_attr_store = gfc_caf_attr (array_expr);
+ caf_attr = &caf_attr_store;
+ }
+
res_var = lhs;
dst_var = lhs;
@@ -1136,6 +1607,108 @@
else
stat = null_pointer_node;
+ /* Always use the new get_by_ref (). When no allocatable components are
+ present and the lhs does not reallocation then the "old" get () might
+ suffice. */
+ if (true) //caf_attr->alloc_comp && !may_realloc)
+ {
+ /* Get using caf_get_by_ref. */
+ caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
+
+ if (caf_reference != NULL_TREE)
+ {
+ if (lhs == NULL_TREE)
+ {
+ if (array_expr->ts.type == BT_CHARACTER)
+ gfc_init_se (&argse, NULL);
+ if (array_expr->rank == 0)
+ {
+ symbol_attribute attr;
+ gfc_clear_attr (&attr);
+ if (array_expr->ts.type == BT_CHARACTER)
+ {
+ res_var = gfc_conv_string_tmp (se,
+ build_pointer_type (type),
+ array_expr->ts.u.cl->backend_decl);
+ argse.string_length = array_expr->ts.u.cl->backend_decl;
+ }
+ else
+ res_var = gfc_create_var (type, "caf_res");
+ dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
+ dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
+ }
+ else
+ {
+ /* Create temporary. */
+ if (array_expr->ts.type == BT_CHARACTER)
+ gfc_conv_expr_descriptor (&argse, array_expr);
+ may_realloc = gfc_trans_create_temp_array (&se->pre,
+ &se->post,
+ se->ss, type,
+ NULL_TREE, false,
+ false, false,
+ &array_expr->where)
+ == NULL_TREE;
+ res_var = se->ss->info->data.array.descriptor;
+ dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
+ if (may_realloc)
+ {
+ tmp = gfc_conv_descriptor_data_get (res_var);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
+ NULL_TREE, NULL_TREE,
+ NULL_TREE, true,
+ NULL, false);
+ gfc_add_expr_to_block (&se->post, tmp);
+ }
+ }
+ }
+
+ kind = build_int_cst (integer_type_node, expr->ts.kind);
+ if (lhs_kind == NULL_TREE)
+ lhs_kind = kind;
+
+ caf_decl = gfc_get_tree_for_caf_expr (array_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 (&se->pre, array_expr,
+ caf_decl);
+ gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
+ array_expr);
+
+ /* No overlap possible as we have generated a temporary. */
+ if (lhs == NULL_TREE)
+ may_require_tmp = boolean_false_node;
+
+ /* 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 (&se->pre, tmp);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
+ 9, token, image_index, dst_var,
+ caf_reference, lhs_kind, kind,
+ may_require_tmp,
+ may_realloc ? boolean_true_node :
+ boolean_false_node,
+ stat);
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ if (se->ss)
+ gfc_advance_se_ss_chain (se);
+
+ se->expr = res_var;
+ if (array_expr->ts.type == BT_CHARACTER)
+ se->string_length = argse.string_length;
+
+ return;
+ }
+ }
+
gfc_init_se (&argse, NULL);
if (array_expr->rank == 0)
{
@@ -1176,9 +1749,9 @@
}
gfc_conv_expr_descriptor (&argse, array_expr);
/* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
- has the wrong type if component references are done. */
+ has the wrong type if component references are done. */
gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
- gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+ gfc_get_dtype_rank_type (has_vector ? ar2.dimen
: array_expr->rank,
type));
if (has_vector)
@@ -1193,10 +1766,10 @@
for (int n = 0; n < se->ss->loop->dimen; n++)
if (se->loop->to[n] == NULL_TREE)
{
- se->loop->from[n] =
- gfc_conv_descriptor_lbound_get (argse.expr, gfc_rank_cst[n]);
- se->loop->to[n] =
- gfc_conv_descriptor_ubound_get (argse.expr, gfc_rank_cst[n]);
+ se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
+ gfc_rank_cst[n]);
+ se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
+ gfc_rank_cst[n]);
}
gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
NULL_TREE, false, true, false,
@@ -1218,14 +1791,15 @@
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 (&se->pre, array_expr, caf_decl);
- gfc_get_caf_token_offset (&token, &offset, caf_decl, argse.expr, array_expr);
+ gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
+ array_expr);
/* No overlap possible as we have generated a temporary. */
if (lhs == NULL_TREE)
may_require_tmp = boolean_false_node;
- /* It guarantees memory consistency within the same segment */
- tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"),
+ /* 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);
@@ -1235,6 +1809,7 @@
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
token, offset, image_index, argse.expr, vec,
dst_var, kind, lhs_kind, may_require_tmp, stat);
+
gfc_add_expr_to_block (&se->pre, tmp);
if (se->ss)
@@ -1246,7 +1821,7 @@
}
-/* Send data to a remove coarray. */
+/* Send data to a remote coarray. */
static tree
conv_caf_send (gfc_code *code) {
@@ -1254,9 +1829,10 @@
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, stat;
+ tree may_require_tmp, src_stat, dst_stat;
tree lhs_type = NULL_TREE;
tree vec = null_pointer_node, rhs_vec = null_pointer_node;
+ symbol_attribute lhs_caf_attr, rhs_caf_attr;
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
@@ -1266,7 +1842,9 @@
? boolean_false_node : boolean_true_node;
gfc_init_block (&block);
- stat = null_pointer_node;
+ lhs_caf_attr = gfc_caf_attr (lhs_expr);
+ rhs_caf_attr = gfc_caf_attr (rhs_expr);
+ src_stat = dst_stat = null_pointer_node;
/* LHS. */
gfc_init_se (&lhs_se, NULL);
@@ -1279,6 +1857,21 @@
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.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
{
/* If has_vector, pass descriptor for whole array and the
@@ -1313,16 +1906,41 @@
}
lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
- gfc_add_block_to_block (&block, &lhs_se.pre);
/* Special case: RHS is a coarray but LHS is not; this code path avoids a
temporary and a loop. */
- if (!gfc_is_coindexed (lhs_expr))
+ if (!gfc_is_coindexed (lhs_expr) && !lhs_caf_attr.codimension)
{
+ bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
gcc_assert (gfc_is_coindexed (rhs_expr));
gfc_init_se (&rhs_se, NULL);
+ if (lhs_expr->rank == 0 && gfc_expr_attr (lhs_expr).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, boolean_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, rhs_expr, lhs_se.expr, lhs_kind,
- may_require_tmp);
+ may_require_tmp, lhs_may_realloc,
+ &lhs_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);
@@ -1329,13 +1947,21 @@
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);
- gfc_get_caf_token_offset (&token, &offset, caf_decl, lhs_se.expr, lhs_expr);
+ 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);
@@ -1347,11 +1973,25 @@
symbol_attribute attr;
gfc_clear_attr (&attr);
gfc_conv_expr (&rhs_se, rhs_expr);
- if (!gfc_is_coindexed (rhs_expr) && rhs_expr->ts.type != BT_CHARACTER)
- rhs_se.expr = fold_convert (lhs_type , rhs_se.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.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
@@ -1397,24 +2037,37 @@
gfc_se stat_se;
gfc_init_se (&stat_se, NULL);
gfc_conv_expr_reference (&stat_se, tmp_stat);
- stat = stat_se.expr;
+ dst_stat = stat_se.expr;
gfc_add_block_to_block (&block, &stat_se.pre);
gfc_add_block_to_block (&block, &stat_se.post);
}
- else
- stat = null_pointer_node;
- if (!gfc_is_coindexed (rhs_expr))
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10, token,
- offset, image_index, lhs_se.expr, vec,
- rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp,
- stat);
+ if (!gfc_is_coindexed (rhs_expr) && !rhs_caf_attr.codimension)
+ {
+ if (lhs_caf_attr.alloc_comp)
+ {
+ 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,
+ 9, token, image_index, rhs_se.expr,
+ reference, lhs_kind, rhs_kind,
+ may_require_tmp, dst_realloc, src_stat);
+ }
+ else
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10,
+ token, offset, image_index, lhs_se.expr, vec,
+ rhs_se.expr, lhs_kind, rhs_kind,
+ may_require_tmp, src_stat);
+ }
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"),
+ /* 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);
@@ -1425,20 +2078,50 @@
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);
- gfc_get_caf_token_offset (&rhs_token, &rhs_offset, caf_decl, rhs_se.expr,
- rhs_expr);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, 13,
- token, offset, image_index, lhs_se.expr, vec,
- rhs_token, rhs_offset, rhs_image_index,
- rhs_se.expr, rhs_vec, lhs_kind, rhs_kind,
- may_require_tmp);
+ tmp = rhs_se.expr;
+ if (rhs_caf_attr.alloc_comp)
+ {
+ 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, 11,
+ token, image_index, lhs_reference,
+ rhs_token, rhs_image_index, rhs_reference,
+ lhs_kind, rhs_kind, may_require_tmp,
+ dst_stat, src_stat);
+ }
+ 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"),
+ /* 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);
@@ -7962,7 +8645,8 @@
break;
case GFC_ISYM_CAF_GET:
- gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE);
+ gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
+ false, NULL);
break;
case GFC_ISYM_CMPLX:
@@ -9033,8 +9717,11 @@
value = gfc_build_addr_expr (NULL_TREE, tmp);
}
- gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
+ gfc_init_se (&argse, NULL);
+ gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
+ atom_expr);
+ gfc_add_block_to_block (&block, &argse.pre);
if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
token, offset, image_index, value, stat,
@@ -9052,6 +9739,7 @@
(int) atom_expr->ts.kind));
gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &argse.post);
gfc_add_block_to_block (&block, &post_block);
return gfc_finish_block (&block);
}
@@ -9179,7 +9867,10 @@
else
image_index = integer_zero_node;
- gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
+ gfc_init_se (&argse, NULL);
+ gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
+ atom_expr);
+ gfc_add_block_to_block (&block, &argse.pre);
/* Different type, need type conversion. */
if (!POINTER_TYPE_P (TREE_TYPE (value)))
@@ -9199,6 +9890,7 @@
if (vardecl != NULL_TREE)
gfc_add_modify (&block, orig_value,
fold_convert (TREE_TYPE (orig_value), vardecl));
+ gfc_add_block_to_block (&block, &argse.post);
gfc_add_block_to_block (&block, &post_block);
return gfc_finish_block (&block);
}
@@ -9312,7 +10004,10 @@
comp = gfc_build_addr_expr (NULL_TREE, tmp);
}
- gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
+ gfc_init_se (&argse, NULL);
+ gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
+ atom_expr);
+ gfc_add_block_to_block (&block, &argse.pre);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
token, offset, image_index, old, comp, new_val,
@@ -9321,6 +10016,7 @@
build_int_cst (integer_type_node,
(int) atom_expr->ts.kind));
gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &argse.post);
gfc_add_block_to_block (&block, &post_block);
return gfc_finish_block (&block);
}
@@ -9407,7 +10103,8 @@
image_index = integer_zero_node;
- gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, event_expr);
+ gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
+ event_expr);
/* For arrays, obtain the array index. */
if (gfc_expr_attr (event_expr).dimension)
===================================================================
@@ -725,7 +725,8 @@
return NULL_TREE;
}
- gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, code->expr1);
+ gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
+ code->expr1);
if (gfc_is_coindexed (code->expr1))
image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
@@ -921,7 +922,10 @@
return NULL_TREE;
}
- gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, code->expr1);
+ gfc_init_se (&argse, NULL);
+ gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE,
+ code->expr1);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
if (gfc_is_coindexed (code->expr1))
image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
@@ -5876,11 +5880,30 @@
/* Handle size computation of the type declared to alloc. */
memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+ if (gfc_caf_attr (expr).codimension
+ && flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ /* Scalar allocatable components in coarray'ed derived types make
+ it here and are treated now. */
+ tree caf_decl, token;
+ gfc_se caf_se;
+
+ gfc_init_se (&caf_se, NULL);
+
+ caf_decl = gfc_get_tree_for_caf_expr (expr);
+ gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl,
+ NULL_TREE, NULL);
+ gfc_add_block_to_block (&se.pre, &caf_se.pre);
+ gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+ gfc_build_addr_expr (NULL_TREE, token),
+ NULL_TREE, NULL_TREE, NULL_TREE,
+ label_finish, expr, 1);
+ }
/* Allocate - for non-pointers with re-alloc checking. */
- if (gfc_expr_attr (expr).allocatable)
- gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
- stat, errmsg, errlen, label_finish,
- expr);
+ else if (gfc_expr_attr (expr).allocatable)
+ gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+ NULL_TREE, stat, errmsg, errlen,
+ label_finish, expr, 0);
else
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
@@ -6147,10 +6170,12 @@
/* Switch off automatic reallocation since we have just
done the ALLOCATE. */
int realloc_lhs = flag_realloc_lhs;
+ gfc_expr *init_expr = gfc_expr_to_initialize (expr);
flag_realloc_lhs = 0;
- tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
- e3rhs, false, false);
+ tmp = gfc_trans_assignment (init_expr, e3rhs, false, false);
flag_realloc_lhs = realloc_lhs;
+ /* Free the expression allocated for init_expr. */
+ gfc_free_expr (init_expr);
}
gfc_add_expr_to_block (&block, tmp);
}
@@ -6298,7 +6323,7 @@
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->rank || gfc_is_coarray (expr))
+ if (expr->rank || gfc_caf_attr (expr).codimension)
{
gfc_ref *ref;
===================================================================
@@ -1054,7 +1054,7 @@
/* Convert a basic type. This will be an array for character types. */
tree
-gfc_typenode_for_spec (gfc_typespec * spec)
+gfc_typenode_for_spec (gfc_typespec * spec, bool in_coarray)
{
tree basetype;
@@ -1107,7 +1107,7 @@
case BT_DERIVED:
case BT_CLASS:
- basetype = gfc_get_derived_type (spec->u.derived);
+ basetype = gfc_get_derived_type (spec->u.derived, in_coarray);
if (spec->type == BT_CLASS)
GFC_CLASS_TYPE_P (basetype) = 1;
@@ -1311,7 +1311,7 @@
static tree
gfc_build_array_type (tree type, gfc_array_spec * as,
enum gfc_array_kind akind, bool restricted,
- bool contiguous)
+ bool contiguous, bool in_coarray)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
@@ -1361,7 +1361,7 @@
return gfc_get_array_type_bounds (type, as->rank == -1
? GFC_MAX_DIMENSIONS : as->rank,
corank, lbound,
- ubound, 0, akind, restricted);
+ ubound, 0, akind, restricted, in_coarray);
}
/* Returns the struct descriptor_dimension type. */
@@ -1724,7 +1724,7 @@
static tree
gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
- enum gfc_array_kind akind)
+ enum gfc_array_kind akind, bool in_coarray)
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
@@ -1786,7 +1786,7 @@
TREE_NO_WARNING (decl) = 1;
}
- if (flag_coarray == GFC_FCOARRAY_LIB && codimen
+ if (flag_coarray == GFC_FCOARRAY_LIB && (codimen || in_coarray)
&& akind == GFC_ARRAY_ALLOCATABLE)
{
decl = gfc_add_field_to_struct_1 (fat_type,
@@ -1814,7 +1814,8 @@
tree
gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
tree * ubound, int packed,
- enum gfc_array_kind akind, bool restricted)
+ enum gfc_array_kind akind, bool restricted,
+ bool in_coarray)
{
char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
@@ -1821,11 +1822,13 @@
const char *type_name;
int n;
- base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind);
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind,
+ in_coarray);
fat_type = build_distinct_type_copy (base_type);
/* Make sure that nontarget and target array type have the same canonical
type (and same stub decl for debug info). */
- base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind);
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind,
+ in_coarray);
TYPE_CANONICAL (fat_type) = base_type;
TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
@@ -2161,7 +2164,7 @@
|| !sym->ts.u.cl->backend_decl))))
type = gfc_character1_type_node;
else
- type = gfc_typenode_for_spec (&sym->ts);
+ type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
byref = 1;
@@ -2199,7 +2202,7 @@
else if (sym->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
type = gfc_build_array_type (type, sym->as, akind, restricted,
- sym->attr.contiguous);
+ sym->attr.contiguous, false);
}
}
else
@@ -2417,7 +2420,7 @@
in a parent namespace, this is used. */
tree
-gfc_get_derived_type (gfc_symbol * derived)
+gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
{
tree typenode = NULL, field = NULL, field_type = NULL;
tree canonical = NULL_TREE;
@@ -2561,7 +2564,8 @@
if ((!c->attr.pointer && !c->attr.proc_pointer)
|| c->ts.u.derived->backend_decl == NULL)
- c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
+ c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
+ in_coarray);
if (c->ts.u.derived->attr.is_iso_c)
{
@@ -2618,7 +2622,7 @@
c->ts.u.cl->backend_decl
= build_int_cst (gfc_charlen_type_node, 0);
- field_type = gfc_typenode_for_spec (&c->ts);
+ field_type = gfc_typenode_for_spec (&c->ts, in_coarray);
}
/* This returns an array descriptor type. Initialization may be
@@ -2638,7 +2642,8 @@
field_type = gfc_build_array_type (field_type, c->as, akind,
!c->attr.target
&& !c->attr.pointer,
- c->attr.contiguous);
+ c->attr.contiguous,
+ in_coarray);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as,
@@ -2683,6 +2688,19 @@
gcc_assert (field);
if (!c->backend_decl)
c->backend_decl = field;
+
+ /* Do not add a caf_token field for classes' data components. */
+ if (in_coarray && !c->attr.dimension && !c->attr.codimension
+ && c->attr.allocatable && c->caf_token == NULL_TREE
+ && strcmp ("_data", c->name) != 0)
+ {
+ char caf_name[GFC_MAX_SYMBOL_LEN];
+ snprintf (caf_name, GFC_MAX_SYMBOL_LEN, "_caf_%s", c->name);
+ c->caf_token = gfc_add_field_to_struct (typenode,
+ get_identifier (caf_name),
+ pvoid_type_node, &chain);
+ TREE_NO_WARNING (c->caf_token) = 1;
+ }
}
/* Now lay out the derived type, including the fields. */
@@ -3324,4 +3342,121 @@
return vector_types[dim-1];
}
+
+tree
+gfc_get_caf_reference_type ()
+{
+ static tree reference_type = NULL_TREE;
+ tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type,
+ a_struct_type, u_union_type, tmp, *chain;
+
+ if (reference_type != NULL_TREE)
+ return reference_type;
+
+ chain = 0;
+ c_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (c_struct_type,
+ get_identifier ("offset"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (c_struct_type,
+ get_identifier ("caf_token_offset"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (c_struct_type);
+
+ chain = 0;
+ s_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (s_struct_type,
+ get_identifier ("start"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (s_struct_type,
+ get_identifier ("end"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (s_struct_type,
+ get_identifier ("stride"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (s_struct_type);
+
+ chain = 0;
+ v_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (v_struct_type,
+ get_identifier ("vector"),
+ pvoid_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (v_struct_type,
+ get_identifier ("nvec"),
+ size_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (v_struct_type,
+ get_identifier ("kind"),
+ integer_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (v_struct_type);
+
+ chain = 0;
+ union_type = make_node (UNION_TYPE);
+ tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"),
+ s_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
+ v_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (union_type);
+
+ tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]);
+ dim_union_type = build_array_type (union_type, tmp);
+
+ chain = 0;
+ a_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"),
+ build_array_type (unsigned_char_type_node,
+ build_range_type (gfc_array_index_type,
+ gfc_index_zero_node,
+ gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])),
+ &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (a_struct_type,
+ get_identifier ("static_array_type"),
+ integer_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"),
+ dim_union_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (a_struct_type);
+
+ chain = 0;
+ u_union_type = make_node (UNION_TYPE);
+ tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"),
+ c_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"),
+ a_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (u_union_type);
+
+ chain = 0;
+ reference_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"),
+ build_pointer_type (reference_type), &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"),
+ integer_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"),
+ size_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"),
+ u_union_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (reference_type);
+ TYPE_NAME (reference_type) = get_identifier ("caf_reference_t");
+
+ return reference_type;
+}
+
#include "gt-fortran-trans-types.h"
===================================================================
@@ -70,7 +70,7 @@
tree gfc_get_character_type_len_for_eltype (tree, tree);
tree gfc_sym_type (gfc_symbol *);
-tree gfc_typenode_for_spec (gfc_typespec *);
+tree gfc_typenode_for_spec (gfc_typespec *, bool in_coarray = false);
int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
tree gfc_get_function_type (gfc_symbol *);
@@ -81,7 +81,8 @@
tree gfc_get_element_type (tree);
tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int,
- enum gfc_array_kind, bool);
+ enum gfc_array_kind, bool,
+ bool in_coarray = false);
tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
/* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE. */
@@ -102,5 +103,6 @@
tree gfc_get_ppc_type (gfc_component *);
tree gfc_get_caf_vector_type (int dim);
+tree gfc_get_caf_reference_type ();
#endif
===================================================================
@@ -734,7 +734,7 @@
size = fold_convert (size_type_node, size);
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_register, 6,
+ gfor_fndecl_caf_register, 7,
fold_build2_loc (input_location,
MAX_EXPR, size_type_node, size,
build_int_cst (size_type_node, 1)),
@@ -742,11 +742,9 @@
lock_var ? GFC_CAF_LOCK_ALLOC
: event_var ? GFC_CAF_EVENT_ALLOC
: GFC_CAF_COARRAY_ALLOC),
- token, pstat, errmsg, errlen);
+ token, gfc_build_addr_expr (pvoid_type_node, pointer),
+ pstat, errmsg, errlen);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- TREE_TYPE (pointer), pointer,
- fold_convert ( TREE_TYPE (pointer), tmp));
gfc_add_expr_to_block (block, tmp);
/* It guarantees memory consistency within the same segment */
@@ -782,13 +780,15 @@
expr must be set to the original expression being allocated for its locus
and variable name in case a runtime error has to be printed. */
void
-gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
- tree status, tree errmsg, tree errlen, tree label_finish,
- gfc_expr* expr)
+gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
+ tree token, tree status, tree errmsg, tree errlen,
+ tree label_finish, gfc_expr* expr, int corank)
{
stmtblock_t alloc_block;
tree tmp, null_mem, alloc, error;
tree type = TREE_TYPE (mem);
+ symbol_attribute caf_attr;
+ bool need_assign = false;
size = fold_convert (size_type_node, size);
null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
@@ -800,8 +800,11 @@
gfc_allocate_using_lib. */
gfc_start_block (&alloc_block);
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ caf_attr = gfc_caf_attr (expr, true);
+
if (flag_coarray == GFC_FCOARRAY_LIB
- && gfc_expr_attr (expr).codimension)
+ && (corank > 0 || caf_attr.codimension))
{
tree cond;
bool lock_var = expr->ts.type == BT_DERIVED
@@ -814,6 +817,33 @@
== INTMOD_ISO_FORTRAN_ENV
&& expr->ts.u.derived->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE;
+ gfc_se se;
+ gfc_init_se (&se, NULL);
+
+ tree sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se,
+ expr);
+ if (sub_caf_tree == NULL_TREE)
+ sub_caf_tree = token;
+
+ /* When mem is an array ref, then strip the .data-ref. */
+ if (TREE_CODE (mem) == COMPONENT_REF
+ && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem))))
+ tmp = TREE_OPERAND (mem, 0);
+ else
+ tmp = mem;
+
+ if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp))
+ && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0)
+ && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ symbol_attribute attr;
+
+ gfc_clear_attr (&attr);
+ tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr);
+ need_assign = true;
+ }
+ gfc_add_block_to_block (&alloc_block, &se.pre);
+
/* In the front end, we represent the lock variable as pointer. However,
the FE only passes the pointer around and leaves the actual
representation to the library. Hence, we have to convert back to the
@@ -822,9 +852,11 @@
size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
size, TYPE_SIZE_UNIT (ptr_type_node));
- gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
- errmsg, errlen, lock_var, event_var);
-
+ gfc_allocate_using_lib (&alloc_block, tmp, size, sub_caf_tree,
+ status, errmsg, errlen, lock_var, event_var);
+ if (need_assign)
+ gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem),
+ gfc_conv_descriptor_data_get (tmp)));
if (status != NULL_TREE)
{
TREE_USED (label_finish) = 1;
@@ -1362,8 +1394,8 @@
token = gfc_build_addr_expr (NULL_TREE, token);
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_deregister, 4,
- token, pstat, errmsg, errlen);
+ gfor_fndecl_caf_deregister, 4,
+ token, pstat, errmsg, errlen);
gfc_add_expr_to_block (&non_null, tmp);
/* It guarantees memory consistency within the same segment */
===================================================================
@@ -119,6 +119,27 @@
};
+/* Specify the type of ref handed to the caf communication functions.
+ Please keep in sync with libgfortran/caf/libcaf.h. */
+enum gfc_caf_ref_type_t {
+ GFC_CAF_REF_COMPONENT,
+ GFC_CAF_REF_ARRAY,
+ GFC_CAF_REF_STATIC_ARRAY
+};
+
+
+/* Give the reference type of an array ref.
+ Please keep in sync with libgfortran/caf/libcaf.h. */
+enum gfc_caf_array_ref_t {
+ GFC_CAF_ARR_REF_NONE = 0,
+ GFC_CAF_ARR_REF_VECTOR,
+ GFC_CAF_ARR_REF_FULL,
+ GFC_CAF_ARR_REF_RANGE,
+ GFC_CAF_ARR_REF_SINGLE,
+ GFC_CAF_ARR_REF_OPEN_END,
+ GFC_CAF_ARR_REF_OPEN_START
+};
+
/* The array-specific scalarization information. The array members of
this struct are indexed by actual array index, and thus can be sparse. */
@@ -441,14 +462,14 @@
void gfc_conv_expr_reference (gfc_se * se, gfc_expr *);
void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
-tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
-
/* trans-expr.c */
+tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
+tree gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *, gfc_expr *);
void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
tree gfc_string_to_single_character (tree len, tree str, int kind);
tree gfc_get_tree_for_caf_expr (gfc_expr *);
-void gfc_get_caf_token_offset (tree *, tree *, tree, tree, gfc_expr *);
+void gfc_get_caf_token_offset (gfc_se*, tree *, tree *, tree, tree, gfc_expr *);
tree gfc_caf_get_image_index (stmtblock_t *, gfc_expr *, tree);
/* Find the decl containing the auxiliary variables for assigned variables. */
@@ -661,7 +682,7 @@
/* Allocate memory for allocatable variables, with optional status variable. */
void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree,
- tree, tree, tree, gfc_expr*);
+ tree, tree, tree, gfc_expr*, int);
/* Allocate memory, with optional status variable. */
void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
@@ -760,6 +781,9 @@
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_get_by_ref;
+extern GTY(()) tree gfor_fndecl_caf_send_by_ref;
+extern GTY(()) tree gfor_fndecl_caf_sendget_by_ref;
extern GTY(()) tree gfor_fndecl_caf_sync_all;
extern GTY(()) tree gfor_fndecl_caf_sync_memory;
extern GTY(()) tree gfor_fndecl_caf_sync_images;
===================================================================
@@ -1,3 +1,26 @@
+2016-09-19 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ * gfortran.dg/coarray/alloc_comp_4.f90: New test.
+ * gfortran.dg/coarray_38.f90:
+ * gfortran.dg/coarray_alloc_comp_1.f08: New test.
+ * gfortran.dg/coarray_alloc_comp_2.f08: New test.
+ * gfortran.dg/coarray_allocate_7.f08: New test.
+ * gfortran.dg/coarray_allocate_8.f08: New test.
+ * gfortran.dg/coarray_allocate_9.f08: New test.
+ * gfortran.dg/coarray_lib_alloc_1.f90: Adapted scan-tree-dumps to expect
+ new caf_register.
+ * gfortran.dg/coarray_lib_alloc_2.f90: Same.
+ * gfortran.dg/coarray_lib_alloc_3.f90: Same.
+ * gfortran.dg/coarray_lib_comm_1.f90: Adapted scan-tree-dumps to expect
+ get_by_refs.
+ * gfortran.dg/coarray_lib_token_3.f90: Same as for coarray_lib_alloc2.
+ * gfortran.dg/coarray_lock_7.f90: Same.
+ * gfortran.dg/coarray_poly_5.f90: Same.
+ * gfortran.dg/coarray_poly_6.f90: Same.
+ * gfortran.dg/coarray_poly_7.f90: Same.
+ * gfortran.dg/coarray_poly_8.f90: Same.
+ * gfortran.dg/coindexed_1.f90: Changed errors expected.
+
2016-09-19 Fritz Reese <fritzoreese@gmail.com>
PR fortran/77584
===================================================================
@@ -0,0 +1,21 @@
+! { dg-do run }
+
+! Contributed by Damian Rouson
+
+program main
+
+ implicit none
+
+ type mytype
+ integer, allocatable :: indices(:)
+ end type
+
+ type(mytype), save :: object[*]
+ integer :: me
+
+ me=this_image()
+ allocate(object%indices(me))
+ object%indices = 42
+
+ if ( any( object[me]%indices(:) /= 42 ) ) call abort()
+end program
===================================================================
@@ -15,11 +15,11 @@
type(t), save :: caf[*],x
type(t2) :: y
-x = caf[4] ! { dg-error "Sorry, coindexed coarray at \\(1\\) with allocatable component is not yet supported" }
-x%a = caf[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x = caf[4] ! OK, now
+x%a = caf[4]%a ! OK, now
x%b = caf[4]%b ! OK
-x = y%caf2[5] ! { dg-error "Sorry, coindexed coarray at \\(1\\) with allocatable component is not yet supported" }
-x%a = y%caf2[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x = y%caf2[5] ! OK, now
+x%a = y%caf2[4]%a ! OK, now
x%b = y%caf2[4]%b ! OK
end subroutine one
@@ -36,10 +36,10 @@
type(t2) :: y
x = caf[4] ! OK
-x%a = caf[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x%a = caf[4]%a ! OK, now
x%b = caf[4]%b ! OK
x = y%caf2[5] ! OK
-x%a = y%caf2[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x%a = y%caf2[4]%a ! OK, now
x%b = y%caf2[4]%b ! OK
end subroutine two
@@ -56,10 +56,10 @@
type(t2) :: y
x(1) = caf(2)[4]%b ! OK
-x(:) = caf(:)[4]%b ! { dg-error "Sorry, coindexed access at \\(1\\) to a scalar component with an array partref is not yet supported" }
+x(:) = caf(:)[4]%b ! OK now
x(1) = y%caf2(2)[4]%b ! OK
-x(:) = y%caf2(:)[4]%b ! { dg-error "Sorry, coindexed access at \\(1\\) to a scalar component with an array partref is not yet supported" }
+x(:) = y%caf2(:)[4]%b ! OK now
end subroutine three
subroutine four
@@ -76,10 +76,10 @@
type(t2) :: y
!x = caf[4] ! Unsupported - and ICEs in resolve_ordinary_assign, cf. PR fortran/65397
-x%a = caf[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x%a = caf[4]%a ! OK, now
x%b = caf[4]%b ! OK
!x = y%caf2[5] ! Unsupported - and ICEs in resolve_ordinary_assign, cf. PR fortran/65397
-x%a = y%caf2[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x%a = y%caf2[4]%a ! Ok, now
x%b = y%caf2[4]%b ! OK
end subroutine four
@@ -97,10 +97,10 @@
type(t2) :: y
!x = caf[4] ! OK - but ICEs in resolve_ordinary_assign, cf. PR fortran/65397
-x%a = caf[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x%a = caf[4]%a ! OK, now
x%b = caf[4]%b ! OK
!x = y%caf2[5] ! OK - but ICEs in resolve_ordinary_assign, cf. PR fortran/65397
-x%a = y%caf2[4]%a ! { dg-error "Sorry, coindexed access to a pointer or allocatable component of the coindexed coarray at \\(1\\) is not yet supported" }
+x%a = y%caf2[4]%a ! OK, now
x%b = y%caf2[4]%b ! OK
end subroutine five
@@ -117,8 +117,16 @@
type(t2) :: y
x(1) = caf(2)[4]%b ! OK
-x(:) = caf(:)[4]%b ! { dg-error "Sorry, coindexed access at \\(1\\) to a scalar component with an array partref is not yet supported" }
+x(:) = caf(:)[4]%b ! OK now
x(1) = y%caf2(2)[4]%b ! OK
-x(:) = y%caf2(:)[4]%b ! { dg-error "Sorry, coindexed access at \\(1\\) to a scalar component with an array partref is not yet supported" }
+x(:) = y%caf2(:)[4]%b ! OK now
end subroutine six
+
+call one()
+call two()
+call three()
+call four()
+call five()
+call six()
+end
===================================================================
@@ -0,0 +1,92 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+
+! Contributed by Damian Rouson
+! Check the new _caf_get_by_ref()-routine.
+
+program main
+
+implicit none
+
+type :: mytype
+ integer :: i
+ integer, allocatable :: indices(:)
+ real, dimension(2,5,3) :: volume
+ integer, allocatable :: scalar
+ integer :: j
+ integer, allocatable :: matrix(:,:)
+ real, allocatable :: dynvol(:,:,:)
+end type
+
+type arrtype
+ type(mytype), allocatable :: vec(:)
+ type(mytype), allocatable :: mat(:,:)
+end type arrtype
+
+type(mytype), save :: object[*]
+type(arrtype), save :: bar[*]
+integer :: i,j,me,neighbor
+integer :: idx(5)
+real, allocatable :: volume(:,:,:), vol2(:,:,:)
+real :: vol_static(2,5,3)
+
+idx = (/ 1,2,1,7,5 /)
+
+me=this_image()
+object%indices=[(i,i=1,5)]
+allocate(object%scalar, object%matrix(10,7))
+object%i = 37
+object%scalar = 42
+vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
+object%volume = vol_static
+object%matrix = reshape([(i, i=1, 70)], [10, 7])
+object%dynvol = vol_static
+sync all
+neighbor = merge(1,neighbor,me==num_images())
+if (object[neighbor]%scalar /= 42) call abort()
+if (object[neighbor]%indices(4) /= 4) call abort()
+if (object[neighbor]%matrix(3,6) /= 53) call abort()
+if (any( object[neighbor]%indices(:) /= [1,2,3,4,5] )) call abort()
+if (any( object[neighbor]%matrix(:,:) /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
+if (any( object[neighbor]%matrix(3,:) /= [(i * 10 + 3, i=0, 6)])) call abort()
+if (any( object[neighbor]%matrix(:,2) /= [(i + 10, i=1, 10)])) call abort()
+if (any( object[neighbor]%matrix(idx,2) /= [11, 12, 11, 17, 15])) call abort()
+if (any( object[neighbor]%matrix(3,idx) /= [3, 13, 3, 63, 43])) call abort()
+if (any( object[neighbor]%matrix(2:8:4, 5:1:-1) /= reshape([42, 46, 32, 36, 22, 26, 12, 16, 2, 6], [2,5]))) call abort()
+if (any( object[neighbor]%matrix(:8:4, 2::2) /= reshape([11, 15, 31, 35, 51, 55], [2,3]))) call abort()
+if (any( object[neighbor]%volume /= vol_static)) call abort()
+if (any( object[neighbor]%dynvol /= vol_static)) call abort()
+if (any( object[neighbor]%volume(:, 2:4, :) /= vol_static(:, 2:4, :))) call abort()
+if (any( object[neighbor]%dynvol(:, 2:4, :) /= vol_static(:, 2:4, :))) call abort()
+
+vol2 = vol_static(:, ::2, :)
+if (any( object[neighbor]%volume(:, ::2, :) /= vol2)) call abort()
+if (any( object[neighbor]%dynvol(:, ::2, :) /= vol2)) call abort()
+
+allocate(bar%vec(-2:2))
+
+bar%vec(1)%volume = vol_static
+if (any(bar[neighbor]%vec(1)%volume /= vol_static)) call abort()
+
+i = 15
+bar%vec(1)%scalar = i
+if (.not. allocated(bar%vec(1)%scalar)) call abort()
+if (bar[neighbor]%vec(1)%scalar /= 15) call abort()
+
+bar%vec(0)%scalar = 27
+if (.not. allocated(bar%vec(0)%scalar)) call abort()
+if (bar[neighbor]%vec(0)%scalar /= 27) call abort()
+
+bar%vec(1)%indices = [ 3, 4, 15 ]
+allocate(bar%vec(2)%indices(5))
+bar%vec(2)%indices = 89
+
+if (.not. allocated(bar%vec(1)%indices)) call abort()
+if (allocated(bar%vec(-2)%indices)) call abort()
+if (allocated(bar%vec(-1)%indices)) call abort()
+if (allocated(bar%vec( 0)%indices)) call abort()
+if (.not. allocated(bar%vec( 2)%indices)) call abort()
+if (any(bar[me]%vec(2)%indices /= 89)) call abort()
+
+if (any (bar[neighbor]%vec(1)%indices /= [ 3,4,15])) call abort()
+end program
===================================================================
@@ -0,0 +1,27 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" }
+
+! Contributed by Damian Rouson
+! Checking whether (de-)registering of coarrays works.
+
+program main
+
+ implicit none
+
+ type mytype
+ integer, allocatable :: indices(:)
+ end type
+
+ type(mytype), save :: object[*]
+ integer :: i,me
+
+ me=this_image() ! me is always 1 here
+ object%indices=[(i,i=1,me)]
+ if ( size(object%indices) /= 1 ) call abort()
+ ! therefore no array is present here and no array test needed.
+ if ( object%indices(1) /= 1 ) call abort()
+end program
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]{4}, 1, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct mytype\\) \\*object\\).indices.token, 0B, 0B, 0\\);" 1 "original" } }
+
===================================================================
@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" }
+
+program alloc_comp
+ implicit none
+
+ type coords
+ real,allocatable :: x(:)
+ real,allocatable :: y(:)
+ real,allocatable :: z(:)
+ end type
+
+ integer :: me,np,n,i
+ type(coords) :: coo[*]
+
+ ! with caf_single num_images is always == 1
+ me = this_image(); np = num_images()
+ n = 100
+
+ allocate(coo%x(n),coo%y(n),coo%z(n))
+
+ coo%y = me
+
+ do i=1, n
+ coo%y(i) = coo%y(i) + i
+ end do
+
+ sync all
+
+ ! Check the caf_get()-offset is computed correctly.
+ if(me == 1 .and. coo[np]%y(10) /= 11 ) call abort()
+
+ ! Check the whole array is correct.
+ if (me == 1 .and. any( coo[np]%y /= [(i, i=2, 101)] ) ) call abort()
+
+ deallocate(coo%x)
+
+end program
===================================================================
@@ -0,0 +1,31 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+
+! Contributed by Damian Rouson
+
+program main
+ implicit none
+
+ type particles
+ real x(2)
+ end type
+
+ type vector
+ type(particles), allocatable :: v(:)
+ end type
+
+ type(vector) :: outbox[*]
+ type(particles), allocatable :: object(:)[:]
+
+ allocate(outbox%v(1), source=particles(this_image()))
+
+ if (any( outbox[1]%v(1)%x(1:2) /= [ 1.0, 1.0] )) call abort()
+ if (any( outbox[1]%v(1)%x(:) /= [ 1.0, 1.0] )) call abort()
+ if (any( outbox[1]%v(1)%x /= [ 1.0, 1.0] )) call abort()
+
+ allocate(object(1)[*], source=particles(this_image()))
+
+ if (any( object(1)[1]%x(1:2) /= [ 1.0, 1.0] )) call abort()
+ if (any( object(1)[1]%x(:) /= [ 1.0, 1.0] )) call abort()
+ if (any( object(1)[1]%x /= [ 1.0, 1.0] )) call abort()
+end program
===================================================================
@@ -13,8 +13,8 @@
deallocate(xx,yy,stat=stat, errmsg=errmsg)
end
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register .4, 1, &xx.token, &stat.., &errmsg, 200.;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register .8, 1, &yy.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &xx.token, \\(void \\*\\) &xx, &stat.., &errmsg, 200\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(8, 1, &yy.token, \\(void \\*\\) &yy, &stat.., &errmsg, 200\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, &stat.., &errmsg, 200.;" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, &stat.., &errmsg, 200.;" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0B, 0B, 0.;" 1 "original" } }
===================================================================
@@ -15,8 +15,8 @@
deallocate(xx,yy,stat=stat, errmsg=errmsg)
end
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } }
===================================================================
@@ -16,8 +16,8 @@
deallocate(xx,yy,stat=stat, errmsg=errmsg)
end
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } }
===================================================================
@@ -38,8 +38,9 @@
if (any (A-B /= 0)) call abort
end
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 1, 0B\\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &p, 4, 4, 0, 0B\\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, _gfortran_caf_this_image \\\(0\\\), &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, _gfortran_caf_this_image \\\(0\\\), &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 1, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get_by_ref \\\(caf_token.0, 1, &p, &caf_ref.\[0-9\]+, 4, 4, 1, 0, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get_by_ref \\\(caf_token.1, 1, &p, &caf_ref.\[0-9\]+, 4, 4, 0, 0, 0B\\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 0, 0B\\\);" 1 "original" } }
+
===================================================================
@@ -8,5 +8,5 @@
allocate(CAF_SCALAR[*])
end
-! { dg-final { scan-tree-dump-times "caf.data = \\(void . restrict\\) _gfortran_caf_register \\(4, 1, &caf.token, 0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "caf_scalar.data = \\(void . restrict\\) _gfortran_caf_register \\(4, 1, &caf_scalar.token, 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &caf.token, \\(void \\*\\) &caf, 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &caf_scalar.token, \\(void \\*\\) &caf_scalar, 0B, 0B, 0\\);" 1 "original" } }
===================================================================
@@ -27,10 +27,10 @@
unlock(four(2)[7])
end
-! { dg-final { scan-tree-dump-times "one = \\(void \\* \\* restrict\\) _gfortran_caf_register \\(1, 2, \\(void \\* \\*\\) &caf_token.., 0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "two = \\(void \\*\\\[25\\\] \\* restrict\\) _gfortran_caf_register \\(25, 2, \\(void \\* \\*\\) &caf_token.., 0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "three.data = \\(void \\* restrict\\) _gfortran_caf_register \\(1, 3, &three.token, &stat.., 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "four.data = \\(void \\* restrict\\) _gfortran_caf_register \\(7, 3, &four.token, &stat.., 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 2, \\(void \\* \\*\\) &caf_token.., \\(void \\*\\) &desc.., 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(25, 2, \\(void \\* \\*\\) &caf_token.., \\(void \\*\\) &desc.., 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 3, &three.token, \\(void \\*\\) &three, &stat.., 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(7, 3, &four.token, \\(void \\*\\) &four, &stat.., 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., 0, 0, 0B, 0B, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., 0, 0, 0B, 0B, 0\\);" 1 "original" } }
@@ -38,9 +38,9 @@
! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lbound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lbound\\), 0, 0B, &ii, 0B, 0\\);|_gfortran_caf_lock \\(caf_token.1, \\(3 - parm...dim\\\[0\\\].lbound\\) \\+ MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lbound\\), 0, 0B, &ii, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., \\(2 - \\(integer\\(kind=4\\)\\) parm...dim\\\[0\\\].lbound\\) \\+ \\(integer\\(kind=4\\)\\) MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - \\(integer\\(kind=4\\)\\) parm...dim\\\[1\\\].lbound\\), 0, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(caf_token.., \\(2 - parm...dim\\\[0\\\].lbound\\) \\+ MAX_EXPR <\\(parm...dim\\\[0\\\].ubound - parm...dim\\\[0\\\].lbound\\) \\+ 1, 0> \\* \\(3 - parm...dim\\\[1\\\].lbound\\), 0, &ii, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(three.token, 0, 5 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lbound, &acquired.8, 0B, 0B, 0\\);|_gfortran_caf_lock \\(three.token, 0, 5 - three.dim\\\[0\\\].lbound, &acquired.., 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(three.token, 0, 5 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lbound, &acquired.\[0-9\]+, 0B, 0B, 0\\);|_gfortran_caf_lock \\(three.token, 0, 5 - three.dim\\\[0\\\].lbound, &acquired.\[0-9\]+, 0B, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(three.token, 0, 8 - \\(integer\\(kind=4\\)\\) three.dim\\\[0\\\].lbound, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(three.token, 0, 8 - three.dim\\\[0\\\].lbound, &ii, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(four.token, 1 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lbound, 7 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lbound, &acquired.., &ii, 0B, 0\\);|_gfortran_caf_lock \\(four.token, 1 - four.dim\\\[0\\\].lbound, 7 - four.dim\\\[1\\\].lbound, &acquired.., &ii, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(four.token, 1 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lbound, 7 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lbound, &acquired.\[0-9\]+, &ii, 0B, 0\\);|_gfortran_caf_lock \\(four.token, 1 - four.dim\\\[0\\\].lbound, 7 - four.dim\\\[1\\\].lbound, &acquired.\[0-9\]+, &ii, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(four.token, 2 - \\(integer\\(kind=4\\)\\) four.dim\\\[0\\\].lbound, 8 - \\(integer\\(kind=4\\)\\) four.dim\\\[1\\\].lbound, 0B, 0B, 0\\);|_gfortran_caf_unlock \\(four.token, 2 - four.dim\\\[0\\\].lbound, 8 - four.dim\\\[1\\\].lbound, 0B, 0B, 0\\);" 1 "original" } }
===================================================================
@@ -10,4 +10,4 @@
allocate(x%x[*])
end subroutine test
-! { dg-final { scan-tree-dump-times "x->_data->x.data = _gfortran_caf_register \\(4, 1, &x->_data->x.token, 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &x->_data->x.token, \\(void \\*\\) &x->_data->x, 0B, 0B, 0\\);" 1 "original" } }
===================================================================
@@ -18,4 +18,4 @@
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } }
===================================================================
@@ -18,4 +18,4 @@
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } }
===================================================================
@@ -18,4 +18,4 @@
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } }
===================================================================
@@ -14,7 +14,7 @@
integer :: ii
!! --- ONE ---
- allocate(real :: a(3)[*])
+ allocate(real :: a(3)[*]) ! { dg-error "Sorry, coindexed access to an unlimited polymorphic object at" }
IF (this_image() == num_images()) THEN
SELECT TYPE (a)
TYPE IS (real)
@@ -43,11 +43,11 @@
!! --- TWO ---
deallocate(a)
- allocate(t :: a(3)[*])
+ allocate(t :: a(3)[*]) ! { dg-error "Sorry, coindexed access to an unlimited polymorphic object at" }
IF (this_image() == num_images()) THEN
SELECT TYPE (a)
- TYPE IS (t) ! FIXME: When implemented, turn into "do-do run"
- a(:)[1]%a = 4.0 ! { dg-error "Sorry, coindexed access at \\(1\\) to a scalar component with an array partref is not yet supported" }
+ TYPE IS (t)
+ a(:)[1]%a = 4.0
END SELECT
END IF
SYNC ALL
@@ -57,8 +57,8 @@
TYPE IS (real)
ii = a(1)[1]
call abort()
- TYPE IS (t) ! FIXME: When implemented, turn into "do-do run"
- IF (ALL(A(:)[1]%a == 4.0)) THEN ! { dg-error "Sorry, coindexed access at \\(1\\) to a scalar component with an array partref is not yet supported" }
+ TYPE IS (t)
+ IF (ALL(A(:)[1]%a == 4.0)) THEN
!WRITE(*,*) 'OK'
ELSE
WRITE(*,*) 'FAIL'
===================================================================
@@ -1,3 +1,37 @@
+2016-09-19 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ * caf/libcaf.h: Add caf_reference_type.
+ * caf/mpi.c: Adapted signature of caf_register().
+ * caf/single.c (struct caf_single_token): Added to keep the pointer
+ to the memory registered and array descriptor.
+ (caf_internal_error): Added convenience interface.
+ (_gfortran_caf_register): Adapted to work with caf_single_token and
+ return memory in the array descriptor.
+ (_gfortran_caf_deregister): Same.
+ (assign_char1_from_char4): Fixed style.
+ (convert_type): Fixed incorrect conversion.
+ (_gfortran_caf_get): Adapted to work with caf_single_token.
+ (_gfortran_caf_send): Same.
+ (_gfortran_caf_sendget): Same.
+ (copy_data): Added to stop repeating it in all _by_ref functions.
+ (get_for_ref): Recursive getting of coarray data using a chain of
+ references.
+ (_gfortran_caf_get_by_ref): Driver for computing the memory needed for
+ the get and checking properties of the operation.
+ (send_by_ref): Same as get_for_ref but for sending data.
+ (_gfortran_caf_send_by_ref): Same like caf_get_by_ref but for sending.
+ (_gfortran_caf_sendget_by_ref): Uses get_by_ref and send_by_ref to
+ implement sendget for reference chains.
+ (_gfortran_caf_atomic_define): Adapted to work with caf_single_token.
+ (_gfortran_caf_atomic_ref): Likewise.
+ (_gfortran_caf_atomic_cas): Likewise.
+ (_gfortran_caf_atomic_op): Likewise.
+ (_gfortran_caf_event_post): Likewise.
+ (_gfortran_caf_event_wait): Likewise.
+ (_gfortran_caf_event_query): Likewise.
+ (_gfortran_caf_lock): Likewise.
+ (_gfortran_caf_unlock): Likewise.
+
2016-09-09 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/77507
===================================================================
@@ -90,7 +90,82 @@
}
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);
@@ -97,8 +172,8 @@
int _gfortran_caf_this_image (int);
int _gfortran_caf_num_images (int, int);
-void *_gfortran_caf_register (size_t, caf_register_t, caf_token_t *, int *,
- char *, int);
+void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *,
+ gfc_descriptor_t *, int *, char *, int);
void _gfortran_caf_deregister (caf_token_t *, int *, char *, int);
void _gfortran_caf_sync_all (int *, char *, int);
@@ -130,6 +205,18 @@
caf_vector_t *, caf_token_t, size_t, int,
gfc_descriptor_t *, caf_vector_t *, int, int, bool);
+void _gfortran_caf_get_by_ref (caf_token_t token, int image_idx,
+ gfc_descriptor_t *dst, caf_reference_t *refs, int dst_kind,
+ int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat);
+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);
+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);
+
void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *,
int, int);
void _gfortran_caf_atomic_ref (caf_token_t, size_t, int, void *, int *,
===================================================================
@@ -131,7 +131,8 @@
void *
_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
- int *stat, char *errmsg, int errmsg_len)
+ int *stat, char *errmsg, int errmsg_len,
+ int num_alloc_comps __attribute__ ((unused)))
{
void *local;
int err;
===================================================================
@@ -33,9 +33,22 @@
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
-typedef void* single_token_t;
-#define TOKEN(X) ((single_token_t) (X))
+struct caf_single_token
+{
+ /* The pointer to the memory registered. For arrays this is the data member
+ in the descriptor. For components it's the pure data pointer. */
+ void *memptr;
+ /* The descriptor when this token is associated to an allocatable array. */
+ gfc_descriptor_t *desc;
+ /* Set when the caf lib has allocated the memory in memptr and is responsible
+ for freeing it on deregister. */
+ bool owning_memory;
+};
+typedef struct caf_single_token *caf_single_token_t;
+#define TOKEN(X) ((caf_single_token_t) (X))
+#define MEMTOK(X) ((caf_single_token_t) (X))->memptr
+
/* Single-image implementation of the CAF library.
Note: For performance reasons -fcoarry=single should be used
rather than this library. */
@@ -43,7 +56,6 @@
/* Global variables. */
caf_static_t *caf_static_list = NULL;
-
/* Keep in sync with mpi.c. */
static void
caf_runtime_error (const char *message, ...)
@@ -59,6 +71,30 @@
exit (EXIT_FAILURE);
}
+/* Error handling is similar everytime. */
+static void
+caf_internal_error (const char *msg, int *stat, char *errmsg,
+ int errmsg_len, ...)
+{
+ va_list args;
+ va_start (args, errmsg_len);
+ if (stat)
+ {
+ *stat = 1;
+ if (errmsg_len > 0)
+ {
+ size_t len = snprintf (errmsg, errmsg_len, msg, args);
+ if ((size_t)errmsg_len > len)
+ memset (&errmsg[len], ' ', errmsg_len - len);
+ }
+ return;
+ }
+ else
+ caf_runtime_error (msg, args);
+ va_end (args);
+}
+
+
void
_gfortran_caf_init (int *argc __attribute__ ((unused)),
char ***argv __attribute__ ((unused)))
@@ -94,11 +130,14 @@
}
-void *
+void
_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
- int *stat, char *errmsg, int errmsg_len)
+ gfc_descriptor_t *data, int *stat, char *errmsg,
+ int errmsg_len)
{
+ const char alloc_fail_msg[] = "Failed to allocate coarray";
void *local;
+ caf_single_token_t single_token;
if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
|| type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
@@ -106,30 +145,20 @@
local = calloc (size, sizeof (bool));
else
local = malloc (size);
- *token = malloc (sizeof (single_token_t));
+ *token = malloc (sizeof (struct caf_single_token));
- if (unlikely (local == NULL || token == NULL))
+ if (unlikely (local == NULL || *token == NULL))
{
- const char msg[] = "Failed to allocate coarray";
- if (stat)
- {
- *stat = 1;
- if (errmsg_len > 0)
- {
- int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
- : (int) sizeof (msg);
- memcpy (errmsg, msg, len);
- if (errmsg_len > len)
- memset (&errmsg[len], ' ', errmsg_len-len);
- }
- return NULL;
- }
- else
- caf_runtime_error (msg);
+ caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
+ return;
}
- *token = local;
+ single_token = TOKEN (*token);
+ single_token->memptr = local;
+ single_token->owning_memory = true;
+ single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
+
if (stat)
*stat = 0;
@@ -142,7 +171,7 @@
tmp->token = *token;
caf_static_list = tmp;
}
- return local;
+ GFC_DESCRIPTOR_DATA (data) = local;
}
@@ -151,8 +180,13 @@
char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
- free (TOKEN(*token));
+ caf_single_token_t single_token = TOKEN (*token);
+ if (single_token->owning_memory && single_token->memptr)
+ free (single_token->memptr);
+
+ free (TOKEN (*token));
+
if (stat)
*stat = 0;
}
@@ -322,7 +356,7 @@
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);
+ memset (&dst[n], ' ', dst_size - n);
}
@@ -465,7 +499,7 @@
}
else
goto error;
- break;
+ return;
case BT_REAL:
if (src_type == BT_INTEGER)
{
@@ -518,7 +552,7 @@
else
goto error;
}
- break;
+ return;
case BT_COMPLEX:
if (src_type == BT_INTEGER)
{
@@ -573,7 +607,7 @@
}
else
goto error;
- break;
+ return;
default:
goto error;
}
@@ -608,7 +642,7 @@
if (rank == 0)
{
- void *sr = (void *) ((char *) TOKEN (token) + offset);
+ void *sr = (void *) ((char *) MEMTOK (token) + offset);
if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
&& dst_kind == src_kind)
{
@@ -669,7 +703,7 @@
stride = src->dim[j]._stride;
}
array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
- void *sr = (void *)((char *) TOKEN (token) + offset
+ 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;
@@ -754,7 +788,7 @@
stride = src->dim[j]._stride;
}
array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
- void *sr = (void *)((char *) TOKEN (token) + offset
+ void *sr = (void *)((char *) MEMTOK (token) + offset
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
@@ -801,7 +835,7 @@
if (rank == 0)
{
- void *dst = (void *) ((char *) TOKEN (token) + offset);
+ void *dst = (void *) ((char *) MEMTOK (token) + offset);
if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
&& dst_kind == src_kind)
{
@@ -893,7 +927,7 @@
stride = dest->dim[j]._stride;
}
array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
- void *dst = (void *)((char *) TOKEN (token) + offset
+ 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)
@@ -941,7 +975,7 @@
stride = dest->dim[j]._stride;
}
array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
- void *dst = (void *)((char *) TOKEN (token) + offset
+ void *dst = (void *)((char *) MEMTOK (token) + offset
+ array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
void *sr;
if (GFC_DESCRIPTOR_RANK (src) != 0)
@@ -1004,7 +1038,8 @@
/* 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 *) TOKEN (src_token) + src_offset);
+ 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;
@@ -1011,7 +1046,1632 @@
}
+/* 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)
+{
+ 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);
+ int src_type = -1;
+
+ switch (ref->type)
+ {
+ case CAF_REF_COMPONENT:
+ /* Because the token is always registered after the component, its
+ offset is always greater zeor. */
+ if (ref->u.c.caf_token_offset > 0)
+ copy_data (ds, *(void **)(sr + ref->u.c.offset),
+ GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst),
+ dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
+ else
+ copy_data (ds, sr + ref->u.c.offset,
+ GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
+ ++(*i);
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ src_type = ref->u.a.static_array_type;
+ /* Intentionally fall through. */
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+ {
+ for (size_t d = 0; d < dst_rank; ++d)
+ array_offset_dst += dst_index[d];
+ copy_data (ds + array_offset_dst * dst_size, sr,
+ GFC_DESCRIPTOR_TYPE (dst),
+ src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type,
+ 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)
+ get_for_ref (ref->next, i, dst_index,
+ *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst,
+ (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc,
+ ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0,
+ 1, stat);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ return;
+ /* The OPEN_* are mapped to a RANGE and therefore can not 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_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)
+{
+ 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(): "
+ "can not 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;
+ 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 || (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;
+ src = (gfc_descriptor_t *)memptr;
+ }
+ 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;
+ }
+ /* 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
+ can not 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;
+ }
+ /* 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);
+ /* 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);
+}
+
+
+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)
+{
+ 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;;
+ int dst_type = -1;
+
+ 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 may be allocated now, because it is a
+ scalar. */
+ single_token = *(caf_single_token_t*)
+ (ds + ref->u.c.caf_token_offset);
+ _gfortran_caf_register (ref->item_size,
+ CAF_REGTYPE_COARRAY_ALLOC,
+ (caf_token_t *)&single_token,
+ &static_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;
+ /* 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
+ {
+ ds = GFC_DESCRIPTOR_DATA (dst);
+ dst_type = GFC_DESCRIPTOR_TYPE (dst);
+ }
+ copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, ref->item_size, src_size, 1, stat);
+ }
+ else
+ copy_data (ds + ref->u.c.offset, sr,
+ dst != NULL ? GFC_DESCRIPTOR_TYPE (dst)
+ : GFC_DESCRIPTOR_TYPE (src),
+ GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, ref->item_size, src_size, 1, stat);
+ ++(*i);
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ dst_type = ref->u.a.static_array_type;
+ /* Intentionally fall through. */
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
+ {
+ 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 * ref->item_size,
+ dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
+ : dst_type,
+ GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
+ ref->item_size, src_size, num, stat);
+ }
+ else
+ copy_data (ds, sr,
+ dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
+ : dst_type,
+ GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
+ ref->item_size, src_size, num, stat);
+ *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);
+ dst->offset = 0;
+ stride_dst = 1;
+ for (size_t d = 0; d < src_rank; ++d)
+ {
+ extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
+ GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
+ GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
+ GFC_DIMENSION_STRIDE (dst->dim[d]) = 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,
+ (void **)&single_token,
+ dst, stat, NULL, 0);
+ /* In case of an error in allocation return. When stat is
+ NULL, then register_component() terminates on error. */
+ if (stat != NULL && *stat)
+ return;
+ /* The memptr, descriptor and the token are set below. */
+ *(caf_single_token_t *)(ds + ref->u.c.caf_token_offset)
+ = single_token;
+ }
+ single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
+ send_by_ref (ref->next, i, src_index, single_token,
+ single_token->desc, src, ds + ref->u.c.offset, sr,
+ dst_kind, src_kind, 0, src_dim, 1, size, stat);
+ }
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ return;
+ /* The OPEN_* are mapped to a RANGE and therefore can not 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)
+{
+ 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(): "
+ "can not 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;
+ 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
+ can not 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);
+ 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)
+{
+ gfc_array_void temp;
+
+ _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs,
+ dst_kind, src_kind, may_require_tmp, true,
+ src_stat);
+
+ if (src_stat && *src_stat != 0)
+ return;
+
+ _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs,
+ dst_kind, src_kind, may_require_tmp, true,
+ dst_stat);
+ if (GFC_DESCRIPTOR_DATA (&temp))
+ free (GFC_DESCRIPTOR_DATA (&temp));
+}
+
+
+void
_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
void *value, int *stat,
@@ -1019,7 +2679,7 @@
{
assert(kind == 4);
- uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
__atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
@@ -1035,7 +2695,7 @@
{
assert(kind == 4);
- uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
__atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
@@ -1052,7 +2712,7 @@
{
assert(kind == 4);
- uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
*(uint32_t *) old = *(uint32_t *) compare;
(void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
@@ -1072,7 +2732,7 @@
assert(kind == 4);
uint32_t res;
- uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
+ uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
switch (op)
{
@@ -1106,7 +2766,8 @@
int errmsg_len __attribute__ ((unused)))
{
uint32_t value = 1;
- uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+ * sizeof (uint32_t));
__atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
if(stat)
@@ -1119,7 +2780,8 @@
char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
- uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+ * sizeof (uint32_t));
uint32_t value = (uint32_t)-until_count;
__atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
@@ -1132,7 +2794,8 @@
int image_index __attribute__ ((unused)),
int *count, int *stat)
{
- uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
+ uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
+ * sizeof (uint32_t));
__atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
if(stat)
@@ -1145,7 +2808,7 @@
int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
{
const char *msg = "Already locked";
- bool *lock = &((bool *) TOKEN (token))[index];
+ bool *lock = &((bool *) MEMTOK (token))[index];
if (!*lock)
{
@@ -1189,7 +2852,7 @@
int *stat, char *errmsg, int errmsg_len)
{
const char *msg = "Variable is not locked";
- bool *lock = &((bool *) TOKEN (token))[index];
+ bool *lock = &((bool *) MEMTOK (token))[index];
if (*lock)
{