This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[accaf, fortran, 3/4] Allocatable components support in derived typed coarrays
- From: Andre Vehreschild <vehre at gmx dot de>
- To: GCC-Fortran-ML <fortran at gcc dot gnu dot org>
- Cc: Damian Rouson <damian at sourceryinstitute dot org>, Tobias Burnus <burnus at net-b dot de>
- Date: Tue, 30 Aug 2016 17:50:25 +0200
- Subject: [accaf, fortran, 3/4] Allocatable components support in derived typed coarrays
- Authentication-results: sourceware.org; auth=none
Hi all,
this is the runtime part of the patch set for allocatable components of
derived type coarrays. The patch changes the signature of the
caf_register() function to take an array descriptor and to no longer
return the memory allocated as return value. The memory allocated is
supplied in the array descriptor's data field. The function now truely
does as it is named: It may register already allocated memory, which
can be supplied in the data field of the array descriptor (gfortran
does not yet make use of it, but I see use cases to come).
Furthermore implements this patch the get_by_ref and send_by_ref
functions (sendget_by_ref is implemented by calling the first two).
Both get/send_by_ref functions at first analyze the chain of references
supplied to figure whether the memory described by the destination is
sufficient. When that is not the case and reallocation of the
destination is allowed, than this is done, else the evaluation is
terminated by a runtime error.
The next step of the get/send_by_ref routines is to recursively
evaluate the references given. At the moment component refs (both
allocatable and non-allocatable), array refs to descriptor arrays (both
allocatable and non-allocatable) and array refs to descriptor-less
arrays are fully supported.
This patch also provides the changes to the gfortran.texi documentation
giving the changes to the _caf_register() function and the new _by_ref
function while also documenting caf_reference_t.
Comments welcome.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index b34ae86..3aa724b 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -3570,6 +3570,7 @@ of such a type
@menu
* caf_token_t::
* caf_register_t::
+* caf_reference_t::
@end menu
@node caf_token_t
@@ -3596,6 +3597,114 @@ typedef enum caf_register_t {
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
@@ -3610,6 +3719,9 @@ caf_register_t;
* _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
@@ -3741,19 +3853,24 @@ the the compiler passes @code{distance=0} and @code{failed=-1} to the function.
@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
+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},
@@ -3762,8 +3879,8 @@ size or one for a scalar.
@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
@@ -3771,6 +3888,7 @@ int *stat, char *errmsg, int errmsg_len)}
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
@@ -3786,12 +3904,12 @@ GCC does such that also nonallocatable coarrays the memory is allocated and no
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
@@ -3799,7 +3917,6 @@ section) such as the value false; for event types, the initial state should
be no event, e.g. zero.
@end table
-
@node _gfortran_caf_deregister
@subsection @code{_gfortran_caf_deregister} --- Deregistering coarrays
@cindex Coarray, _gfortran_caf_deregister
@@ -3808,14 +3925,17 @@ be no event, e.g. zero.
@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
@@ -3996,6 +4116,186 @@ the library has to handle numeric-type conversion and for strings, padding and
different character kinds.
@end table
+@node _gfortran_caf_send_by_ref
+@subsection @code{_gfortran_caf_send_by_ref} --- Sending data from a local image to a remote image with enhanced referencing options
+@cindex Coarray, _gfortran_caf_send_by_ref
+
+@table @asis
+@item @emph{Description}:
+Called to send a scalar, an array section or 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
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 863b5b4..aad0f62 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -90,6 +90,81 @@ typedef struct caf_vector_t {
}
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 @@ void _gfortran_caf_finalize (void);
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 @@ void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, caf_token_t, size_t, int,
gfc_descriptor_t *, caf_vector_t *, int, int, bool);
+void _gfortran_caf_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 *,
diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c
index d7a21fe..1e9a477 100644
--- a/libgfortran/caf/mpi.c
+++ b/libgfortran/caf/mpi.c
@@ -131,7 +131,8 @@ _gfortran_caf_num_images (int distance __attribute__ ((unused)),
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;
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 21916d3..35f2ef6 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -33,8 +33,21 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
/* 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
@@ -43,7 +56,6 @@ typedef void* single_token_t;
/* 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 @@ caf_runtime_error (const char *message, ...)
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 @@ _gfortran_caf_num_images (int distance __attribute__ ((unused)),
}
-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,29 +145,19 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
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 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
tmp->token = *token;
caf_static_list = tmp;
}
- return local;
+ GFC_DESCRIPTOR_DATA (data) = local;
}
@@ -151,6 +180,11 @@ _gfortran_caf_deregister (caf_token_t *token, int *stat,
char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
+ 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)
@@ -465,7 +499,7 @@ convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
}
else
goto error;
- break;
+ return;
case BT_REAL:
if (src_type == BT_INTEGER)
{
@@ -518,7 +552,7 @@ convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
else
goto error;
}
- break;
+ return;
case BT_COMPLEX:
if (src_type == BT_INTEGER)
{
@@ -573,7 +607,7 @@ convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
}
else
goto error;
- break;
+ return;
default:
goto error;
}
@@ -608,7 +642,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
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 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
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 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
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 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
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 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
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 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
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,13 +1038,1636 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
/* 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;
}
+/* 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)),
@@ -1019,7 +2676,7 @@ _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
{
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 +2692,7 @@ _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
{
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 +2709,7 @@ _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
{
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 +2729,7 @@ _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
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 +2763,7 @@ _gfortran_caf_event_post (caf_token_t token, size_t index,
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 +2776,7 @@ _gfortran_caf_event_wait (caf_token_t token, size_t index,
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 +2789,7 @@ _gfortran_caf_event_query (caf_token_t token, size_t index,
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 +2802,7 @@ _gfortran_caf_lock (caf_token_t token, size_t index,
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 +2846,7 @@ _gfortran_caf_unlock (caf_token_t token, size_t index,
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)
{