OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

libcaf.h: Add caf_reference_type.

Browse Source 
libgfortran/ChangeLog:

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.


gcc/testsuite/ChangeLog:

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.

gcc/fortran/ChangeLog:

2016-09-19  Andre Vehreschild  <vehre@gcc.gnu.org>

	* 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.

From-SVN: r240231
This commit is contained in:
Andre Vehreschild 2016-09-19 15:45:40 +02:00
parent e79e6763c6
commit 3c9f5092c6
37 changed files with 4048 additions and 318 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
gcc/fortran/ChangeLog
View File

@ -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

13
gcc/fortran/expr.c
View File

@ -3128,10 +3128,14 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, .
/* 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 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
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);
}

7
gcc/fortran/gfortran.h
View File

@ -1043,6 +1043,8 @@ typedef struct gfc_component
/* 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_validate_kind (bt, int, bool);
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_numeric_ts (gfc_typespec *);
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 @@ const char *gfc_dt_upper_string (const char *);
/* 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);

332
gcc/fortran/gfortran.texi
View File

@ -3571,6 +3571,7 @@ of such a type
@menu
* caf_token_t::
* caf_register_t::
* caf_reference_t::
@end menu
@node caf_token_t
@ -3597,6 +3598,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
@ -3611,6 +3720,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
@ -3742,19 +3854,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
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 @@ 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
@ -3772,6 +3889,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
@ -3787,12 +3905,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
@ -3800,7 +3918,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
@ -3809,14 +3926,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
@ -3997,6 +4117,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

157
gcc/fortran/primary.c
View File

@ -2376,6 +2376,163 @@ gfc_expr_attr (gfc_expr *e)
}
/* 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. */

22
gcc/fortran/resolve.c
View File

@ -9839,27 +9839,29 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
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
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

127
gcc/fortran/trans-array.c
View File

@ -5083,19 +5083,19 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
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 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
}
}
gfc_init_se (&caf_se, NULL);
gfc_start_block (&elseblock);
/* Allocate memory to store the data. */
@ -5527,16 +5541,22 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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 @@ gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
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 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
/* 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)));

59
gcc/fortran/trans-decl.c
View File

@ -135,6 +135,9 @@ tree gfor_fndecl_caf_deregister;
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 @@ gfc_build_builtin_function_decls (void)
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,11 +3584,31 @@ gfc_build_builtin_function_decls (void)
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,
@ -5002,9 +5025,11 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
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 @@ generate_coarray_sym_init (gfc_symbol *sym)
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)

267
gcc/fortran/trans-expr.c
View File

@ -72,6 +72,13 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
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 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
}
/* 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 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
{
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)
{
/* 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. */
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);
}
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->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
&& 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;
}
}
if (expr->symtree->n.sym->attr.codimension)
return caf_decl;
@ -1907,7 +1946,14 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
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 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
/* 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 @@ gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr
*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 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
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 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
{
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,7 +9157,25 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
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),
@ -9242,6 +9353,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
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_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| 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_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
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 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* 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;

789
gcc/fortran/trans-intrinsic.c
View File

@ -982,7 +982,7 @@ conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
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 @@ conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
}
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 @@ conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
}
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 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
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 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
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_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
}
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 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
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 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
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 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
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 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
}
/* Send data to a remove coarray. */
/* Send data to a remote coarray. */
static tree
conv_caf_send (gfc_code *code) {
@ -1254,9 +1829,10 @@ conv_caf_send (gfc_code *code) {
gfc_se lhs_se, rhs_se;
stmtblock_t block;
tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
tree may_require_tmp, 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 @@ conv_caf_send (gfc_code *code) {
? 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 @@ conv_caf_send (gfc_code *code) {
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,29 +1906,62 @@ conv_caf_send (gfc_code *code) {
}
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);
return gfc_finish_block (&block);
}
/* Obtain token, offset and image index for the LHS. */
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 @@ conv_caf_send (gfc_code *code) {
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 @@ conv_caf_send (gfc_code *code) {
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 @@ conv_caf_send (gfc_code *code) {
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 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_CAF_GET:
gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, 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 @@ conv_intrinsic_atomic_op (gfc_code *code)
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 @@ conv_intrinsic_atomic_op (gfc_code *code)
(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 @@ conv_intrinsic_atomic_ref (gfc_code *code)
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 @@ conv_intrinsic_atomic_ref (gfc_code *code)
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 @@ conv_intrinsic_atomic_cas (gfc_code *code)
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 @@ conv_intrinsic_atomic_cas (gfc_code *code)
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 @@ conv_intrinsic_event_query (gfc_code *code)
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)

43
gcc/fortran/trans-stmt.c
View File

@ -725,7 +725,8 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
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 @@ gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
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 @@ gfc_trans_allocate (gfc_code * code)
/* 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 @@ gfc_trans_allocate (gfc_code * code)
/* 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 @@ gfc_trans_deallocate (gfc_code *code)
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;

165
gcc/fortran/trans-types.c
View File

@ -1054,7 +1054,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
/* 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 @@ gfc_typenode_for_spec (gfc_typespec * spec)
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 @@ gfc_is_nodesc_array (gfc_symbol * sym)
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 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
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 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
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 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
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,18 +1814,21 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
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;
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 @@ gfc_sym_type (gfc_symbol * sym)
|| !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 @@ gfc_sym_type (gfc_symbol * sym)
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 @@ gfc_get_union_type (gfc_symbol *un)
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 @@ gfc_get_derived_type (gfc_symbol * derived)
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 @@ gfc_get_derived_type (gfc_symbol * derived)
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 @@ gfc_get_derived_type (gfc_symbol * derived)
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 @@ gfc_get_derived_type (gfc_symbol * derived)
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 @@ gfc_get_caf_vector_type (int dim)
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"

6
gcc/fortran/trans-types.h
View File

@ -70,7 +70,7 @@ tree gfc_get_character_type_len (int, tree);
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_build_uint_type (int);
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_dtype (tree);
tree gfc_get_ppc_type (gfc_component *);
tree gfc_get_caf_vector_type (int dim);
tree gfc_get_caf_reference_type ();
#endif

60
gcc/fortran/trans.c
View File

@ -734,7 +734,7 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
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 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
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 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
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_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
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 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
== 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 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
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 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
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 */

32
gcc/fortran/trans.h
View File

@ -119,6 +119,27 @@ enum gfc_coarray_type
};
/* 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_lhs (gfc_se * se, gfc_expr * expr);
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 @@ tree gfc_build_memcpy_call (tree, tree, tree);
/* 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_deregister;
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;

23
gcc/testsuite/ChangeLog
View File

@ -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

21
gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 Normal file
View File

@ -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

36
gcc/testsuite/gfortran.dg/coarray_38.f90
View File

@ -15,11 +15,11 @@ end type t2
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(t), save :: caf[*],x
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 @@ integer :: x(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(t) :: x
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(t) :: x
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 @@ integer :: x(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 six
call one()
call two()
call three()
call four()
call five()
call six()
end

92
gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 Normal file
View File

@ -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

27
gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 Normal file
View File

@ -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" } }

38
gcc/testsuite/gfortran.dg/coarray_allocate_8.f08 Normal file
View File

@ -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

31
gcc/testsuite/gfortran.dg/coarray_allocate_9.f08 Normal file
View File

@ -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

4
gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
View File

@ -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" } }

4
gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
View File

@ -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" } }

4
gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90
View File

@ -16,8 +16,8 @@ subroutine test
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" } }

11
gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90
View File

@ -38,8 +38,9 @@ B(1:5) = B(3:7)
if (any (A-B /= 0)) call abort
end
! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 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" } }

4
gcc/testsuite/gfortran.dg/coarray_lib_token_3.f90
View File

@ -8,5 +8,5 @@ allocate(CAF(1)[*])
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" } }

12
gcc/testsuite/gfortran.dg/coarray_lock_7.f90
View File

@ -27,10 +27,10 @@ lock(four(1)[6], acquired_lock=ll, stat=ii)
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 @@ end
! { 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" } }

2
gcc/testsuite/gfortran.dg/coarray_poly_5.f90
View File

@ -10,4 +10,4 @@ class(t) :: x
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" } }

2
gcc/testsuite/gfortran.dg/coarray_poly_6.f90
View File

@ -18,4 +18,4 @@ end
! { 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" } }

2
gcc/testsuite/gfortran.dg/coarray_poly_7.f90
View File

@ -18,4 +18,4 @@ end
! { 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" } }

2
gcc/testsuite/gfortran.dg/coarray_poly_8.f90
View File

@ -18,4 +18,4 @@ end
! { 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" } }

12
gcc/testsuite/gfortran.dg/coindexed_1.f90
View File

@ -14,7 +14,7 @@ program pmup
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 @@ program pmup
!! --- 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 @@ program pmup
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'

34
libgfortran/ChangeLog
View File

@ -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

91
libgfortran/caf/libcaf.h
View File

@ -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 *,

3
libgfortran/caf/mpi.c
View File

@ -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;

1755
libgfortran/caf/single.c
View File

File diff suppressed because it is too large Load Diff