@@ -851,6 +851,17 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
bool
gfc_check_allocated (gfc_expr *array)
{
+ /* Tests on allocated components of coarrays need to detour the check to
+ argument of the _caf_get. */
+ if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION
+ && array->value.function.isym
+ && array->value.function.isym->id == GFC_ISYM_CAF_GET)
+ {
+ array = array->value.function.actual->expr;
+ if (!array->ref)
+ return false;
+ }
+
if (!variable_check (array, 0, false))
return false;
if (!allocatable_check (array, 0))
@@ -3274,7 +3274,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);
+symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool, bool);
int gfc_check_digit (char, int);
@@ -3871,6 +3871,7 @@ of such a type
@menu
* caf_token_t::
* caf_register_t::
+* caf_deregister_t::
* caf_reference_t::
@end menu
@@ -3893,11 +3894,39 @@ typedef enum caf_register_t {
CAF_REGTYPE_LOCK_ALLOC,
CAF_REGTYPE_CRITICAL,
CAF_REGTYPE_EVENT_STATIC,
- CAF_REGTYPE_EVENT_ALLOC
+ CAF_REGTYPE_EVENT_ALLOC,
+ CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY,
+ CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
}
caf_register_t;
@end verbatim
+The values @code{CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY} and
+@code{CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY} are for allocatable components
+in derived type coarrays only. The first one sets up the token without
+allocating memory for allocatable component. The latter one only allocates the
+memory for an allocatable component in a derived type coarray. The token
+needs to be setup previously by the REGISTER_ONLY. This allows to have
+allocatable components un-allocated on some images. The status whether an
+allocatable component is allocated on a remote image can be queried by
+@code{_caf_is_present} which used internally by the @code{ALLOCATED}
+intrinsic.
+
+@node caf_deregister_t
+@subsection @code{caf_deregister_t}
+
+@verbatim
+typedef enum caf_deregister_t {
+ CAF_DEREGTYPE_COARRAY_DEREGISTER,
+ CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY
+}
+caf_deregister_t;
+@end verbatim
+
+Allows to specifiy the type of deregistration of a coarray object. The
+@code{CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY} flag is only allowed for
+allocatable components in derived type coarrays.
+
@node caf_reference_t
@subsection @code{caf_reference_t}
@@ -4017,6 +4046,7 @@ descriptor-less arrays. The library caf_single has untested support for it.
* _gfortran_caf_num_images:: Querying the maximal number of images
* _gfortran_caf_register:: Registering coarrays
* _gfortran_caf_deregister:: Deregistering coarrays
+* _gfortran_caf_is_present:: Query whether an allocatable component in a derived type coarray is allocated
* _gfortran_caf_send:: Sending data from a local image to a remote image
* _gfortran_caf_get:: Getting data from a remote image
* _gfortran_caf_sendget:: Sending data between remote images
@@ -4218,6 +4248,7 @@ 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
@@ -4231,12 +4262,16 @@ 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 (caf_token_t *token, int *stat, char *errmsg,
-int errmsg_len)}
+@code{void caf_deregister (caf_token_t *token, caf_deregister_t type,
+int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{token} @tab the token to free.
+@item @var{type} @tab the type of action to take for the coarray. A
+@code{CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY} is allowed only for allocatable
+components of derived type coarrays. The action only deallocates the local
+memory without deleting the token.
@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
@@ -4250,6 +4285,31 @@ and via destructors.
@end table
+@node _gfortran_caf_is_present
+@subsection @code{_gfortran_caf_is_present} --- Query whether an allocatable component in a derived type coarray is allocated
+@cindex Coarray, _gfortran_caf_is_present
+
+@table @asis
+@item @emph{Description}:
+Used to query the coarray library whether an allocatable component in a derived
+type coarray is allocated on a remote image.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_is_present (caf_token_t token, int image_index,
+gfc_reference_t *ref)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{token} @tab An opaque pointer identifying the coarray.
+@item @var{image_index} @tab The ID of the remote image; must be a positive
+number.
+@item @var{ref} @tab A chain of references to address the allocatable component
+in the derived type coarray. The object reffed needs to be a scalar or a full
+array ref, respectively.
+@end multitable
+
+@end table
+
@node _gfortran_caf_send
@subsection @code{_gfortran_caf_send} --- Sending data from a local image to a remote image
@cindex Coarray, _gfortran_caf_send
@@ -2418,10 +2418,15 @@ gfc_expr_attr (gfc_expr *e)
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. */
+ "infectious" being propagated once set and never cleared.
+ The coarray_comp is only set, when the expression refs a coarray
+ component. REFS_COMP is set when present to true only, when this EXPR
+ refs a (non-_data) component. To check whether EXPR refs an allocatable
+ component in a derived type coarray *refs_comp needs to be set and
+ coarray_comp has to false. */
static symbol_attribute
-caf_variable_attr (gfc_expr *expr, bool in_allocate)
+caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
{
int dimension, codimension, pointer, allocatable, target, coarray_comp,
alloc_comp;
@@ -2436,13 +2441,15 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
sym = expr->symtree->n.sym;
gfc_clear_attr (&attr);
+ if (refs_comp)
+ *refs_comp = 0;
+
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
@@ -2451,12 +2458,11 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
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;
+ target = coarray_comp = 0;
if (pointer || attr.proc_pointer)
target = 1;
@@ -2494,19 +2500,26 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
if (comp->ts.type == BT_CLASS)
{
+ /* Set coarray_comp only, when this component introduces the
+ coarray. */
+ coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
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
{
+ /* Set coarray_comp only, when this component introduces the
+ coarray. */
+ coarray_comp = !codimension && comp->attr.codimension;
codimension |= comp->attr.codimension;
pointer = comp->attr.pointer;
allocatable = comp->attr.allocatable;
- coarray_comp |= comp->attr.coarray_comp;
}
+ if (refs_comp && strcmp (comp->name, "_data") != 0)
+ *refs_comp = 1;
+
if (pointer || attr.proc_pointer)
target = 1;
@@ -2531,14 +2544,14 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
symbol_attribute
-gfc_caf_attr (gfc_expr *e, bool in_allocate)
+gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
{
symbol_attribute attr;
switch (e->expr_type)
{
case EXPR_VARIABLE:
- attr = caf_variable_attr (e, in_allocate);
+ attr = caf_variable_attr (e, in_allocate, refs_comp);
break;
case EXPR_FUNCTION:
@@ -2557,7 +2570,7 @@ gfc_caf_attr (gfc_expr *e, bool in_allocate)
}
}
else if (e->symtree)
- attr = caf_variable_attr (e, in_allocate);
+ attr = caf_variable_attr (e, in_allocate, refs_comp);
else
gfc_clear_attr (&attr);
break;
@@ -5633,12 +5633,13 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree
gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
- tree label_finish, gfc_expr* expr)
+ tree label_finish, gfc_expr* expr,
+ int coarray_dealloc_mode)
{
tree var;
tree tmp;
stmtblock_t block;
- bool coarray = gfc_caf_attr (expr).codimension;
+ bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY;
gfc_start_block (&block);
@@ -5648,7 +5649,8 @@ gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
/* Parameter is the address of the data component. */
tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
- errlen, label_finish, false, expr, coarray);
+ errlen, label_finish, false, expr,
+ coarray_dealloc_mode);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer; only for coarrays an error can occur and then
@@ -7782,11 +7784,13 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* Generate code to deallocate an array, if it is allocated. */
tree
-gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
+gfc_trans_dealloc_allocated (tree descriptor, gfc_expr *expr,
+ int coarray_dealloc_mode)
{
tree tmp;
tree var;
stmtblock_t block;
+ bool coarray = coarray_dealloc_mode != GFC_CAF_COARRAY_NOCOARRAY;
gfc_start_block (&block);
@@ -7797,8 +7801,8 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
- NULL_TREE, NULL_TREE, NULL_TREE, true,
- expr, coarray);
+ NULL_TREE, NULL_TREE, NULL_TREE, true, expr,
+ coarray_dealloc_mode);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
@@ -7967,17 +7967,119 @@ gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
}
+static tree
+duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
+ tree type, int rank)
+{
+ tree tmp;
+ tree size;
+ tree nelems;
+ tree null_cond;
+ tree null_data;
+ stmtblock_t block, globalblock;
+
+ /* If the source is null, set the destination to null. Then,
+ allocate memory to the destination. */
+ gfc_init_block (&block);
+ gfc_init_block (&globalblock);
+
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+ {
+ gfc_se se;
+ symbol_attribute attr;
+ tree dummy_desc;
+
+ gfc_init_se (&se, NULL);
+ dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
+ gfc_add_block_to_block (&globalblock, &se.pre);
+ size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+
+ gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
+ gfc_allocate_using_caf_lib (&block, dummy_desc, size,
+ gfc_build_addr_expr (NULL_TREE, dest_tok),
+ NULL_TREE, NULL_TREE, NULL_TREE,
+ GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+
+ gfc_allocate_using_caf_lib (&block, dummy_desc,
+ fold_convert (size_type_node, size),
+ gfc_build_addr_expr (NULL_TREE, dest_tok),
+ NULL_TREE, NULL_TREE, NULL_TREE,
+ GFC_CAF_COARRAY_ALLOC);
+
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+ fold_convert (size_type_node, size));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ {
+ /* Set the rank or unitialized memory access may be reported. */
+ tmp = gfc_conv_descriptor_dtype (dest);
+ gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
+
+ if (rank)
+ nelems = gfc_full_array_size (&block, src, rank);
+ else
+ nelems = integer_one_node;
+
+ tmp = fold_convert (size_type_node,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, nelems), tmp);
+
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
+ size),
+ gfc_build_addr_expr (NULL_TREE, dest_tok),
+ NULL_TREE, NULL_TREE, NULL_TREE,
+ GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ gfc_allocate_using_caf_lib (&block, dest,
+ fold_convert (size_type_node, size),
+ gfc_build_addr_expr (NULL_TREE, dest_tok),
+ NULL_TREE, NULL_TREE, NULL_TREE,
+ GFC_CAF_COARRAY_ALLOC);
+
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp = build_call_expr_loc (input_location, tmp, 3,
+ gfc_conv_descriptor_data_get (dest),
+ gfc_conv_descriptor_data_get (src),
+ fold_convert (size_type_node, size));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ tmp = gfc_finish_block (&block);
+
+ /* Null the destination if the source is null; otherwise do
+ the register and copy. */
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
+ null_cond = src;
+ else
+ null_cond = gfc_conv_descriptor_data_get (src);
+
+ null_cond = convert (pvoid_type_node, null_cond);
+ null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ null_cond, null_pointer_node);
+ gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
+ null_data));
+ return gfc_finish_block (&globalblock);
+}
+
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
-enum {DEALLOCATE_ALLOC_COMP = 1, DEALLOCATE_ALLOC_COMP_NO_CAF,
- NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP,
- COPY_ALLOC_COMP_CAF};
+enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
+ COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
- tree dest, int rank, int purpose)
+ tree dest, int rank, int purpose, int caf_mode)
{
gfc_component *c;
gfc_loopinfo loop;
@@ -8011,10 +8113,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Deref dest in sync with decl, but only when it is not NULL. */
if (dest)
dest = build_fold_indirect_ref_loc (input_location, dest);
- }
- /* Just in case it gets dereferenced. */
- decl_type = TREE_TYPE (decl);
+ /* Update the decl_type because it got dereferenced. */
+ decl_type = TREE_TYPE (decl);
+ }
/* If this is an array of derived types with allocatable components
build a loop and recursively call this function. */
@@ -8056,16 +8158,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
vref = gfc_build_array_ref (var, index, NULL);
- if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
- {
+ if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
+ && (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) == 0)
+ {
tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
- COPY_ALLOC_COMP);
+ COPY_ALLOC_COMP, 0);
}
else
- tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
+ tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
+ caf_mode);
gfc_add_expr_to_block (&loopbody, tmp);
@@ -8111,7 +8215,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
switch (purpose)
{
case DEALLOCATE_ALLOC_COMP:
- case DEALLOCATE_ALLOC_COMP_NO_CAF:
/* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
(i.e. this function) so generate all the calls and suppress the
@@ -8128,21 +8231,59 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* The finalizer frees allocatable components. */
called_dealloc_with_status
= gfc_add_comp_finalizer_call (&tmpblock, comp, c,
- purpose == DEALLOCATE_ALLOC_COMP);
+ purpose == DEALLOCATE_ALLOC_COMP
+ && (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0);
}
else
comp = NULL_TREE;
- if (c->attr.allocatable && !c->attr.proc_pointer
+ if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
&& (c->attr.dimension
- || (c->attr.codimension
- && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
- && !same_type)
+ || ((caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0
+ && ((caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0
+ || c->attr.codimension))))
{
+ /* Allocatable arrays or coarray'ed components (scalar or
+ array). */
+ int caf_dereg_mode
+ = ((caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0
+ || c->attr.codimension)
+ ? ((caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) != 0
+ ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
+ : GFC_CAF_COARRAY_DEREGISTER)
+ : GFC_CAF_COARRAY_NOCOARRAY;
if (comp == NULL_TREE)
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
+
+ if (c->attr.dimension || c->attr.codimension)
+ /* Deallocate array. */
+ tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_mode);
+ else
+ {
+ /* Deallocate scalar. */
+ tree cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, comp,
+ build_int_cst (TREE_TYPE (comp),
+ 0));
+
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ pvoid_type_node, decl, c->caf_token,
+ NULL_TREE);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_deregister, 5,
+ gfc_build_addr_expr (NULL_TREE,
+ tmp),
+ build_int_cst (integer_type_node,
+ caf_dereg_mode),
+ null_pointer_node,
+ null_pointer_node,
+ integer_zero_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
+ }
+
gfc_add_expr_to_block (&tmpblock, tmp);
}
else if (c->attr.allocatable && !c->attr.codimension && !same_type)
@@ -8152,7 +8293,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+ tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
+ NULL_TREE, true, NULL,
c->ts);
gfc_add_expr_to_block (&tmpblock, tmp);
called_dealloc_with_status = true;
@@ -8168,8 +8310,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree is_allocated;
tree ubound;
tree cdesc;
- tree zero = build_int_cst (gfc_array_index_type, 0);
- tree unity = build_int_cst (gfc_array_index_type, 1);
tree data;
stmtblock_t dealloc_block;
@@ -8191,8 +8331,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
ubound = build_int_cst (gfc_array_index_type, 1);
}
- cdesc = gfc_get_array_type_bounds (tmp, 1, 0,
- &unity, &ubound, 1,
+ cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+ &ubound, 1,
GFC_ARRAY_ALLOCATABLE, false);
cdesc = gfc_create_var (cdesc, "cdesc");
@@ -8201,11 +8341,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
gfc_get_dtype_rank_type (1, tmp));
gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
- zero, unity);
+ gfc_index_zero_node,
+ gfc_index_one_node);
gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
- zero, unity);
+ gfc_index_zero_node,
+ gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
- zero, ubound);
+ gfc_index_zero_node, ubound);
if (c->attr.dimension)
data = gfc_conv_descriptor_data_get (comp);
@@ -8247,7 +8389,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
&& (!CLASS_DATA (c)->attr.codimension
- || purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
+ || (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) == 0))
{
/* Allocatable CLASS components. */
@@ -8257,11 +8399,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
- tmp = gfc_trans_dealloc_allocated (comp,
- CLASS_DATA (c)->attr.codimension, NULL);
+ tmp = gfc_trans_dealloc_allocated (comp, NULL,
+ CLASS_DATA (c)->attr.codimension
+ ? GFC_CAF_COARRAY_DEREGISTER
+ : GFC_CAF_COARRAY_NOCOARRAY);
else
{
- tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
+ tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
+ NULL_TREE, true,
+ NULL,
CLASS_DATA (c)->ts);
gfc_add_expr_to_block (&tmpblock, tmp);
called_dealloc_with_status = true;
@@ -8317,7 +8463,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose);
+ rank, purpose, caf_mode);
gfc_add_expr_to_block (&fnblock, tmp);
}
@@ -8326,14 +8472,20 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
break;
case NULLIFY_ALLOC_COMP:
- if (c->attr.pointer || c->attr.proc_pointer)
+ if (c->attr.pointer || c->attr.proc_pointer
+ || !(c->attr.allocatable || (c->ts.type == BT_CLASS
+ && CLASS_DATA (c)->attr.allocatable)
+ || cmp_has_alloc_comps))
continue;
- else if (c->attr.allocatable
- && (c->attr.dimension|| c->attr.codimension))
+
+ /* Coarrays need the component to be initialized before the api-call
+ is made. */
+ if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension))
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+ cmp_has_alloc_comps = false;
}
else if (c->attr.allocatable)
{
@@ -8354,6 +8506,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
}
+ cmp_has_alloc_comps = false;
}
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
{
@@ -8371,46 +8524,98 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
}
+ cmp_has_alloc_comps = false;
+ }
+
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && ((caf_mode & (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+ | GFC_STRUCTURE_CAF_MODE_IN_COARRAY))
+ == (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+ | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
+ || c->attr.codimension))
+ {
+ /* Register the component with the coarray library. */
+ tree token;
+
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ if (c->attr.dimension || c->attr.codimension)
+ {
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ token = gfc_conv_descriptor_token (tmp);
+ }
+ else
+ {
+ gfc_se se;
+ symbol_attribute attr;
+
+ gfc_init_se (&se, NULL);
+ gfc_clear_attr (&attr);
+ token = fold_build3_loc (input_location, COMPONENT_REF,
+ pvoid_type_node, decl, c->caf_token,
+ NULL_TREE);
+ comp = gfc_conv_scalar_to_descriptor (&se, comp, attr);
+ gfc_add_block_to_block (&fnblock, &se.pre);
+ }
+
+ /* NULL the member-token before registering it or uninitialized
+ memory accesses may occur. */
+ gfc_add_modify (&fnblock, token, fold_convert (TREE_TYPE (token),
+ null_pointer_node));
+ gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
+ gfc_build_addr_expr (NULL_TREE,
+ token),
+ NULL_TREE, NULL_TREE, NULL_TREE,
+ GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
}
- else if (cmp_has_alloc_comps)
+
+ if (cmp_has_alloc_comps)
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose);
+ rank, purpose, caf_mode);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
- case COPY_ALLOC_COMP_CAF:
- if (!c->attr.codimension
- && (c->ts.type != BT_CLASS || CLASS_DATA (c)->attr.coarray_comp)
- && (c->ts.type != BT_DERIVED
- || !c->ts.u.derived->attr.coarray_comp))
- continue;
-
- comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
- cdecl, NULL_TREE);
- dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
- cdecl, NULL_TREE);
-
- if (c->attr.codimension)
+ case REASSIGN_CAF_COMP:
+ if ((caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0
+ && (c->attr.codimension
+ || (c->ts.type == BT_CLASS
+ && (CLASS_DATA (c)->attr.coarray_comp
+ || (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
+ != 0))
+ || (c->ts.type == BT_DERIVED
+ && (c->ts.u.derived->attr.coarray_comp
+ || (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
+ != 0)))
+ && !same_type)
{
- if (c->ts.type == BT_CLASS)
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ dest, cdecl, NULL_TREE);
+
+ if (c->attr.codimension)
{
- comp = gfc_class_data_get (comp);
- dcmp = gfc_class_data_get (dcmp);
- }
- gfc_conv_descriptor_data_set (&fnblock, dcmp,
+ if (c->ts.type == BT_CLASS)
+ {
+ comp = gfc_class_data_get (comp);
+ dcmp = gfc_class_data_get (dcmp);
+ }
+ gfc_conv_descriptor_data_set (&fnblock, dcmp,
gfc_conv_descriptor_data_get (comp));
- }
- else
- {
- tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
- rank, purpose);
- gfc_add_expr_to_block (&fnblock, tmp);
-
+ }
+ else
+ {
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
+ rank, purpose, caf_mode
+ | GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
break;
@@ -8503,7 +8708,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_add_modify (&fnblock, dcmp, tmp);
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, dcmp,
- rank, purpose);
+ rank, purpose,
+ caf_mode);
}
else
add_when_allocated = NULL_TREE;
@@ -8530,11 +8736,24 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
- && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension))
+ && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
+ || (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0))
{
rank = c->as ? c->as->rank : 0;
if (c->attr.codimension)
tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
+ else if (flag_coarray == GFC_FCOARRAY_LIB
+ && (caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0)
+ {
+ tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp)
+ : fold_build3_loc (input_location,
+ COMPONENT_REF,
+ pvoid_type_node, dest,
+ c->caf_token,
+ NULL_TREE);
+ tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
+ ctype, rank);
+ }
else
tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
add_when_allocated);
@@ -8562,7 +8781,8 @@ tree
gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- NULLIFY_ALLOC_COMP);
+ NULLIFY_ALLOC_COMP,
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
}
@@ -8570,10 +8790,12 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
deallocate allocatable components. */
tree
-gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
+gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
+ int caf_mode)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_ALLOC_COMP);
+ DEALLOCATE_ALLOC_COMP,
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
}
@@ -8586,14 +8808,15 @@ tree
gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_ALLOC_COMP_NO_CAF);
+ DEALLOCATE_ALLOC_COMP, 0);
}
tree
gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
{
- return structure_alloc_comps (der_type, decl, dest, 0, COPY_ALLOC_COMP_CAF);
+ return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
}
@@ -8601,9 +8824,11 @@ gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
copy it and its allocatable components. */
tree
-gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
+ int caf_mode)
{
- return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
+ return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
+ caf_mode);
}
@@ -8613,7 +8838,8 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
tree
gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
{
- return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
+ return structure_alloc_comps (der_type, decl, dest, rank,
+ COPY_ONLY_ALLOC_COMP, 0);
}
@@ -9205,15 +9431,17 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else
{
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_deregister,
- 4, token, null_pointer_node,
- null_pointer_node, integer_zero_node);
+ gfor_fndecl_caf_deregister, 5, token,
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_DEALLOCATE_ONLY),
+ 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),
+ GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
token, gfc_build_addr_expr (NULL_TREE, desc),
null_pointer_node, null_pointer_node,
integer_zero_node);
@@ -9398,7 +9626,20 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* NULLIFY the data pointer, for non-saved allocatables. */
if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
- gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
+ {
+ gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
+ if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+ {
+ /* Declare the variable static so its array descriptor stays present
+ after leaving the scope. It may still be accessed through another
+ image. This may happen, for example, with the caf_mpi
+ implementation. */
+ TREE_STATIC (descriptor) = 1;
+ tmp = gfc_conv_descriptor_token (descriptor);
+ gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ }
+ }
gfc_restore_backend_locus (&loc);
gfc_init_block (&cleanup);
@@ -9432,8 +9673,10 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
{
gfc_expr *e;
e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
- tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
- sym->attr.codimension, e);
+ tmp = gfc_trans_dealloc_allocated (sym->backend_decl, e,
+ sym->attr.codimension
+ ? GFC_CAF_COARRAY_DEREGISTER
+ : GFC_CAF_COARRAY_NOCOARRAY);
if (e)
gfc_free_expr (e);
gfc_add_expr_to_block (&cleanup, tmp);
@@ -19,7 +19,7 @@ along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* Generate code to free an array. */
-tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
+tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*, int c = -2);
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
@@ -42,7 +42,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
/* Generate entry and exit code for g77 calling convention arrays. */
void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate code to deallocate an array, if it is allocated. */
-tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
+tree gfc_trans_dealloc_allocated (tree, gfc_expr *, int);
tree gfc_full_array_size (stmtblock_t *, tree, int);
@@ -54,11 +54,11 @@ tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
-tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
-tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
+tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
@@ -159,6 +159,7 @@ tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
tree gfor_fndecl_co_reduce;
tree gfor_fndecl_co_sum;
+tree gfor_fndecl_caf_is_present;
/* Math functions. Many other math functions are handled in
@@ -3573,8 +3574,9 @@ gfc_build_builtin_function_decls (void)
pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_deregister")), "WWWR", void_type_node, 4,
- ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
+ get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5,
+ ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
+ integer_type_node);
gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10,
@@ -3726,6 +3728,11 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("caf_co_sum")), "W.WW",
void_type_node, 5, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
+
+ gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_is_present")), "RRR",
+ integer_type_node, 3, pvoid_type_node, integer_type_node,
+ pvoid_type_node);
}
gfc_build_intrinsic_function_decls ();
@@ -4447,12 +4454,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
NULL_TREE, NULL_TREE,
NULL_TREE, true, NULL,
- true);
+ GFC_CAF_COARRAY_ANALYZE);
else
{
gfc_expr *expr = gfc_lval_expr_from_sym (sym);
- tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE,
- true, expr, sym->ts);
+ tmp = gfc_deallocate_scalar_with_status (se.expr,
+ NULL_TREE,
+ NULL_TREE,
+ true, expr,
+ sym->ts);
gfc_free_expr (expr);
}
}
@@ -5208,7 +5208,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
ptr = gfc_class_data_get (ptr);
tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
- true, e, e->ts);
+ NULL_TREE, true,
+ e, e->ts);
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, ptr,
@@ -5317,7 +5318,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
NULL_TREE, NULL_TREE,
NULL_TREE, true, e,
- false);
+ GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, ptr,
@@ -5440,7 +5441,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
- tmp = gfc_trans_dealloc_allocated (tmp, false, e);
+ tmp = gfc_trans_dealloc_allocated (tmp, e,
+ GFC_CAF_COARRAY_NOCOARRAY);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
@@ -5552,7 +5554,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tree local_tmp;
local_tmp = gfc_evaluate_now (tmp, &se->pre);
- local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
+ local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
+ parm_rank, 0);
gfc_add_expr_to_block (&se->post, local_tmp);
}
@@ -6207,7 +6210,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
from being corrupted. */
tmp2 = gfc_evaluate_now (result, &se->pre);
tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
- result, tmp2, expr->rank);
+ result, tmp2, expr->rank, 0);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
expr->rank);
@@ -6217,7 +6220,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_conv_descriptor_data_get (tmp2);
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
NULL_TREE, NULL_TREE, true,
- NULL, false);
+ NULL, GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
@@ -6932,16 +6935,18 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
/* Deal with arrays of derived types with allocatable components. */
if (gfc_bt_struct (cm->ts.type)
&& cm->ts.u.derived->attr.alloc_comp)
+ // TODO: Fix caf_mode
tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
se.expr, dest,
- cm->as->rank);
+ cm->as->rank, 0);
else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
&& CLASS_DATA(cm)->attr.allocatable)
{
if (cm->ts.u.derived->attr.alloc_comp)
+ // TODO: Fix caf_mode
tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
se.expr, dest,
- expr->rank);
+ expr->rank, 0);
else
{
tmp = TREE_TYPE (dest);
@@ -7367,8 +7372,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
if (cm->ts.u.derived->attr.alloc_comp
&& expr->expr_type != EXPR_NULL)
{
+ // TODO: Fix caf_mode
tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
- dest, expr->rank);
+ dest, expr->rank, 0);
gfc_add_expr_to_block (&block, tmp);
if (dealloc != NULL_TREE)
gfc_add_expr_to_block (&block, dealloc);
@@ -7434,13 +7440,14 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
/* Assign a derived type constructor to a variable. */
tree
-gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
+gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
{
gfc_constructor *c;
gfc_component *cm;
stmtblock_t block;
tree field;
tree tmp;
+ gfc_se se;
gfc_start_block (&block);
cm = expr->ts.u.derived->components;
@@ -7449,7 +7456,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
&& (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
|| expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
{
- gfc_se se, lse;
+ gfc_se lse;
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
@@ -7461,6 +7468,9 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
return gfc_finish_block (&block);
}
+ if (coarray)
+ gfc_init_se (&se, NULL);
+
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next)
{
@@ -7468,6 +7478,62 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
if (!c->expr && !cm->attr.allocatable)
continue;
+ /* Register the component with the caf-lib before it is initialized.
+ Register only allocatable components, that are not coarray'ed
+ components (%comp[*]). Only register when the constructor is not the
+ null-expression. */
+ if (coarray && !cm->attr.codimension && cm->attr.allocatable
+ && (!c->expr || c->expr->expr_type == EXPR_NULL))
+ {
+ tree token, desc, size;
+ symbol_attribute attr;
+ bool is_array = cm->ts.type == BT_CLASS
+ ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
+
+ field = cm->backend_decl;
+ field = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field), dest, field, NULL_TREE);
+ if (cm->ts.type == BT_CLASS)
+ field = gfc_class_data_get (field);
+
+ token = is_array ? gfc_conv_descriptor_token (field)
+ : fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (cm->caf_token), dest,
+ cm->caf_token, NULL_TREE);
+
+ if (is_array)
+ {
+ /* The _caf_register routine looks at the rank of the array
+ descriptor to decide whether the data registered is an array
+ or not. */
+ int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
+ : cm->as->rank;
+ /* When the rank is not known just set a positive rank, which
+ suffices to recognize the data as array. */
+ if (rank < 0)
+ rank = 1;
+ size = integer_zero_node;
+ desc = field;
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
+ build_int_cst (gfc_array_index_type, rank));
+ }
+ else
+ {
+ desc = gfc_conv_scalar_to_descriptor (&se, field, attr);
+ size = TYPE_SIZE_UNIT (TREE_TYPE (field));
+ }
+ gfc_add_block_to_block (&block, &se.pre);
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
+ 7, size, build_int_cst (
+ integer_type_node,
+ GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
+ gfc_build_addr_expr (pvoid_type_node,
+ token),
+ gfc_build_addr_expr (NULL_TREE, desc),
+ null_pointer_node, null_pointer_node,
+ integer_zero_node);
+ gfc_add_expr_to_block (&block, tmp);
+ }
field = cm->backend_decl;
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
@@ -7546,7 +7612,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
se->expr = gfc_create_var (type, expr->ts.u.derived->name);
/* The symtree in expr is NULL, if the code to generate is for
initializing the static members only. */
- tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL);
+ tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
+ se->want_coarray);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
@@ -8540,7 +8607,7 @@ gfc_conv_string_parameter (gfc_se * se)
tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool deep_copy, bool dealloc)
+ bool deep_copy, bool dealloc, bool in_coarray)
{
stmtblock_t block;
tree tmp;
@@ -8617,7 +8684,10 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
same as the lhs. */
if (deep_copy)
{
- tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
+ int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+ | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
+ tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
+ caf_mode);
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
gfc_add_expr_to_block (&block, tmp);
@@ -9746,6 +9816,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
/* Translate the expression. */
+ rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
+ && lhs_caf_attr.codimension;
gfc_conv_expr (&rse, expr2);
/* Deal with the case of a scalar class function assigned to a derived type. */
@@ -9882,7 +9954,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_expr_is_variable (expr2)
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
- !(l_is_temp || init_flag) && dealloc);
+ !(l_is_temp || init_flag) && dealloc,
+ expr1->symtree->n.sym->attr.codimension);
/* Add the pre blocks to the body. */
gfc_add_block_to_block (&body, &rse.pre);
gfc_add_block_to_block (&body, &lse.pre);
@@ -1674,7 +1674,8 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
NULL_TREE, NULL_TREE,
NULL_TREE, true,
- NULL, false);
+ NULL,
+ GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&se->post, tmp);
}
}
@@ -1764,6 +1765,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
ar->as = ar2.as;
ar->type = AR_FULL;
}
+ // TODO: Check whether argse.want_coarray = 1 can help with the below.
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. */
@@ -1926,7 +1928,9 @@ conv_caf_send (gfc_code *code) {
/* 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) && !lhs_caf_attr.codimension)
+ if (!gfc_is_coindexed (lhs_expr)
+ && (!lhs_caf_attr.codimension
+ || !(lhs_expr->rank > 0 && lhs_caf_attr.allocatable)))
{
bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
gcc_assert (gfc_is_coindexed (rhs_expr));
@@ -1957,7 +1961,7 @@ conv_caf_send (gfc_code *code) {
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, lhs_may_realloc,
- &lhs_caf_attr);
+ &rhs_caf_attr);
gfc_add_block_to_block (&block, &rhs_se.pre);
gfc_add_block_to_block (&block, &rhs_se.post);
gfc_add_block_to_block (&block, &lhs_se.post);
@@ -2059,7 +2063,7 @@ conv_caf_send (gfc_code *code) {
gfc_add_block_to_block (&block, &stat_se.post);
}
- if (!gfc_is_coindexed (rhs_expr) && !rhs_caf_attr.codimension)
+ if (!gfc_is_coindexed (rhs_expr))
{
if (lhs_caf_attr.alloc_comp)
{
@@ -7318,6 +7322,42 @@ scalar_transfer:
}
+/* Generate a call to caf_is_present. */
+
+static tree
+trans_caf_is_present (gfc_se *se, gfc_expr *expr)
+{
+ tree caf_reference, caf_decl, token, image_index;
+
+ /* Compile the reference chain. */
+ caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
+ gcc_assert (caf_reference != NULL_TREE);
+
+ caf_decl = gfc_get_tree_for_caf_expr (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, expr, caf_decl);
+ gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
+ expr);
+
+ return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
+ 3, token, image_index, caf_reference);
+}
+
+
+/* Test whether this ref-chain refs this image only. */
+
+static bool
+caf_this_image_ref (gfc_ref *ref)
+{
+ for ( ; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
+
+ return false;
+}
+
+
/* Generate code for the ALLOCATED intrinsic.
Generate inline code that directly check the address of the argument. */
@@ -7327,6 +7367,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
gfc_actual_arglist *arg1;
gfc_se arg1se;
tree tmp;
+ symbol_attribute caf_attr;
gfc_init_se (&arg1se, NULL);
arg1 = expr->value.function.actual;
@@ -7342,23 +7383,37 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
gfc_add_data_component (arg1->expr);
}
- if (arg1->expr->rank == 0)
- {
- /* Allocatable scalar. */
- arg1se.want_pointer = 1;
- gfc_conv_expr (&arg1se, arg1->expr);
- tmp = arg1se.expr;
- }
+ /* When arg1 references an allocatable component in a coarray, then call
+ the caf-library function caf_is_present (). */
+ if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION
+ && arg1->expr->value.function.isym
+ && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+ caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr);
+ else
+ gfc_clear_attr (&caf_attr);
+ if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension
+ && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref))
+ tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr);
else
{
- /* Allocatable array. */
- arg1se.descriptor_only = 1;
- gfc_conv_expr_descriptor (&arg1se, arg1->expr);
- tmp = gfc_conv_descriptor_data_get (arg1se.expr);
- }
+ if (arg1->expr->rank == 0)
+ {
+ /* Allocatable scalar. */
+ arg1se.want_pointer = 1;
+ gfc_conv_expr (&arg1se, arg1->expr);
+ tmp = arg1se.expr;
+ }
+ else
+ {
+ /* Allocatable array. */
+ arg1se.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr);
+ tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+ }
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ }
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
}
@@ -10270,8 +10325,8 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_add_block_to_block (&block, &to_se.pre);
/* Deallocate "to". */
- tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
- to_expr, to_expr->ts);
+ tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
+ true, to_expr, to_expr->ts);
gfc_add_expr_to_block (&block, tmp);
/* Assign (_data) pointers. */
@@ -10429,7 +10484,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
NULL_TREE, NULL_TREE, true, to_expr,
- true);
+ GFC_CAF_COARRAY_DEALLOCATE_ONLY);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_conv_descriptor_data_get (to_se.expr);
@@ -10457,7 +10512,8 @@ conv_intrinsic_move_alloc (gfc_code *code)
tmp = gfc_conv_descriptor_data_get (to_se.expr);
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
- NULL_TREE, true, to_expr, false);
+ NULL_TREE, true, to_expr,
+ GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&block, tmp);
}
@@ -420,8 +420,8 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var,
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
{
- tem = gfc_trans_dealloc_allocated (unshare_expr (declf),
- false, NULL);
+ tem = gfc_trans_dealloc_allocated (unshare_expr (declf), NULL,
+ GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
}
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
@@ -812,7 +812,8 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
if (GFC_DESCRIPTOR_TYPE_P (type))
gfc_add_expr_to_block (&cond_block,
gfc_trans_dealloc_allocated (unshare_expr (dest),
- false, NULL));
+ NULL,
+ GFC_CAF_COARRAY_NOCOARRAY));
else
{
destptr = gfc_evaluate_now (destptr, &cond_block);
@@ -988,7 +989,7 @@ gfc_omp_clause_dtor (tree clause, tree decl)
if (GFC_DESCRIPTOR_TYPE_P (type))
/* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
to be deallocated if they were allocated. */
- tem = gfc_trans_dealloc_allocated (decl, false, NULL);
+ tem = gfc_trans_dealloc_allocated (decl, NULL, GFC_CAF_COARRAY_NOCOARRAY);
else
tem = gfc_call_free (decl);
tem = gfc_omp_unshare_expr (tem);
@@ -6406,6 +6406,9 @@ gfc_trans_deallocate (gfc_code *code)
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
gfc_expr *expr = gfc_copy_expr (al->expr);
+ bool is_coarray = false, is_coarray_array = false;
+ int caf_mode = 0;
+
gcc_assert (expr->expr_type == EXPR_VARIABLE);
if (expr->ts.type == BT_CLASS)
@@ -6418,11 +6421,32 @@ gfc_trans_deallocate (gfc_code *code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->rank || gfc_caf_attr (expr).codimension)
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ bool comp_ref;
+ symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
+ if (caf_attr.codimension)
+ {
+ is_coarray = true;
+ is_coarray_array = caf_attr.dimension || !comp_ref
+ || caf_attr.coarray_comp;
+
+ /* When the expression to deallocate is referencing a
+ component, then only deallocate it, but do not deregister. */
+ caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY
+ | (comp_ref && !caf_attr.coarray_comp
+ ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
+ }
+ }
+ else if (flag_coarray == GFC_FCOARRAY_SINGLE)
+ is_coarray = is_coarray_array = gfc_caf_attr (expr).codimension;
+
+ if (expr->rank || is_coarray_array)
{
gfc_ref *ref;
- if (gfc_bt_struct (expr->ts.type) && expr->ts.u.derived->attr.alloc_comp
+ if (gfc_bt_struct (expr->ts.type)
+ && expr->ts.u.derived->attr.alloc_comp
&& !gfc_is_finalizable (expr->ts.u.derived, NULL))
{
gfc_ref *last = NULL;
@@ -6436,16 +6460,35 @@ gfc_trans_deallocate (gfc_code *code)
if (!(last && last->u.c.component->attr.pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
- tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
- expr->rank);
+ if (is_coarray && expr->rank == 0
+ && (!last || !last->u.c.component->attr.dimension))
+ {
+ /* Add the ref to the data member only, when this is not
+ a regular array or deallocate_alloc_comp will try to
+ add another one. */
+ tmp = gfc_conv_descriptor_data_get (se.expr);
+ }
+ else
+ tmp = se.expr;
+ tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp,
+ expr->rank, caf_mode);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
{
+ gfc_coarray_deregtype caf_dtype;
+
+ if (is_coarray)
+ caf_dtype
+ = (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) == 0
+ ? GFC_CAF_COARRAY_DEREGISTER
+ : GFC_CAF_COARRAY_DEALLOCATE_ONLY;
+ else
+ caf_dtype = GFC_CAF_COARRAY_NOCOARRAY;
tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
- label_finish, expr);
+ label_finish, expr, caf_dtype);
gfc_add_expr_to_block (&se.pre, tmp);
}
else if (TREE_CODE (se.expr) == COMPONENT_REF
@@ -6488,8 +6531,9 @@ gfc_trans_deallocate (gfc_code *code)
}
else
{
- tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
- al->expr, al->expr->ts);
+ tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish,
+ false, al->expr,
+ al->expr->ts, is_coarray);
gfc_add_expr_to_block (&se.pre, tmp);
/* Set to zero after deallocation. */
@@ -709,10 +709,10 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
return newmem;
} */
-static void
-gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
- tree token, tree status, tree errmsg, tree errlen,
- bool lock_var, bool event_var)
+void
+gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size,
+ tree token, tree status, tree errmsg, tree errlen,
+ gfc_coarray_regtype alloc_type)
{
tree tmp, pstat;
@@ -735,12 +735,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
tmp = build_call_expr_loc (input_location,
gfor_fndecl_caf_register, 7,
fold_build2_loc (input_location,
- MAX_EXPR, size_type_node, size,
- build_int_cst (size_type_node, 1)),
- build_int_cst (integer_type_node,
- lock_var ? GFC_CAF_LOCK_ALLOC
- : event_var ? GFC_CAF_EVENT_ALLOC
- : GFC_CAF_COARRAY_ALLOC),
+ MAX_EXPR, size_type_node, size, size_one_node),
+ build_int_cst (integer_type_node, alloc_type),
token, gfc_build_addr_expr (pvoid_type_node, pointer),
pstat, errmsg, errlen);
@@ -787,7 +783,8 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
tree tmp, null_mem, alloc, error;
tree type = TREE_TYPE (mem);
symbol_attribute caf_attr;
- bool need_assign = false;
+ bool need_assign = false, refs_comp = false;
+ gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
size = fold_convert (size_type_node, size);
null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
@@ -800,27 +797,36 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
gfc_start_block (&alloc_block);
if (flag_coarray == GFC_FCOARRAY_LIB)
- caf_attr = gfc_caf_attr (expr, true);
+ caf_attr = gfc_caf_attr (expr, true, &refs_comp);
if (flag_coarray == GFC_FCOARRAY_LIB
&& (corank > 0 || caf_attr.codimension))
{
- tree cond;
- bool lock_var = expr->ts.type == BT_DERIVED
- && expr->ts.u.derived->from_intmod
- == INTMOD_ISO_FORTRAN_ENV
- && expr->ts.u.derived->intmod_sym_id
- == ISOFORTRAN_LOCK_TYPE;
- bool event_var = expr->ts.type == BT_DERIVED
- && expr->ts.u.derived->from_intmod
- == INTMOD_ISO_FORTRAN_ENV
- && expr->ts.u.derived->intmod_sym_id
- == ISOFORTRAN_EVENT_TYPE;
+ tree cond, sub_caf_tree;
gfc_se se;
- gfc_init_se (&se, NULL);
+ bool compute_special_caf_types_size = false;
- tree sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se,
- expr);
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ {
+ compute_special_caf_types_size = true;
+ caf_alloc_type = GFC_CAF_LOCK_ALLOC;
+ }
+ else if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ {
+ compute_special_caf_types_size = true;
+ caf_alloc_type = GFC_CAF_EVENT_ALLOC;
+ }
+ else if (!caf_attr.coarray_comp && refs_comp)
+ /* Only allocatable components in a derived type coarray can be
+ allocate only. */
+ caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
+
+ gfc_init_se (&se, NULL);
+ sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
if (sub_caf_tree == NULL_TREE)
sub_caf_tree = token;
@@ -847,12 +853,12 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
the FE only passes the pointer around and leaves the actual
representation to the library. Hence, we have to convert back to the
number of elements. */
- if (lock_var || event_var)
+ if (compute_special_caf_types_size)
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, tmp, size, sub_caf_tree,
- status, errmsg, errlen, lock_var, event_var);
+ gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree,
+ status, errmsg, errlen, caf_alloc_type);
if (need_assign)
gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem),
gfc_conv_descriptor_data_get (tmp)));
@@ -1265,23 +1271,40 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
expression being deallocated for its locus and variable name.
For coarrays, "pointer" must be the array descriptor and not its
- "data" component. */
+ "data" component.
+
+ COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
+ the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
+ analyzed and set by this routine, and -2 to indicate that a non-coarray is to
+ be deallocated. */
tree
gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
tree errlen, tree label_finish,
- bool can_fail, gfc_expr* expr, bool coarray)
+ bool can_fail, gfc_expr* expr,
+ int coarray_dealloc_mode)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
tree status_type = NULL_TREE;
tree caf_decl = NULL_TREE;
+ gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
- if (coarray)
+ if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
caf_decl = pointer;
pointer = gfc_conv_descriptor_data_get (caf_decl);
STRIP_NOPS (pointer);
+ if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+ {
+ bool comp_ref;
+ if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
+ && comp_ref)
+ caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
+ // else do a deregister as set by default.
+ }
+ else
+ caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
}
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
@@ -1326,7 +1349,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
gfc_add_finalizer_call (&non_null, expr);
- if (!coarray || flag_coarray != GFC_FCOARRAY_LIB)
+ if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
+ || flag_coarray != GFC_FCOARRAY_LIB)
{
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_FREE), 1,
@@ -1392,9 +1416,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
}
token = gfc_build_addr_expr (NULL_TREE, token);
+ gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_deregister, 4,
- token, pstat, errmsg, errlen);
+ gfor_fndecl_caf_deregister, 5,
+ token, build_int_cst (integer_type_node,
+ caf_dereg_type),
+ pstat, errmsg, errlen);
gfc_add_expr_to_block (&non_null, tmp);
/* It guarantees memory consistency within the same segment */
@@ -1431,12 +1458,18 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
subcomponents are being deallocated. */
tree
-gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
- gfc_expr* expr, gfc_typespec ts)
+gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
+ bool can_fail, gfc_expr* expr,
+ gfc_typespec ts, bool coarray)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
- bool finalizable;
+ bool finalizable, comp_ref;
+ gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
+
+ if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
+ && comp_ref)
+ caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
@@ -1474,7 +1507,6 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond2, tmp, error);
}
-
gfc_add_expr_to_block (&null, error);
/* When POINTER is not NULL, we free it. */
@@ -1484,31 +1516,84 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
finalizable = gfc_add_finalizer_call (&non_null, expr);
if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
- tmp = build_fold_indirect_ref_loc (input_location, pointer);
+ if (coarray)
+ tmp = gfc_conv_descriptor_data_get (pointer);
+ else
+ tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_FREE), 1,
- fold_convert (pvoid_type_node, pointer));
- gfc_add_expr_to_block (&non_null, tmp);
+ if (!coarray)
+ {
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_FREE), 1,
+ fold_convert (pvoid_type_node, pointer));
+ gfc_add_expr_to_block (&non_null, tmp);
- if (status != NULL_TREE && !integer_zerop (status))
+ if (status != NULL_TREE && !integer_zerop (status))
+ {
+ /* We set STATUS to zero if it is present. */
+ tree status_type = TREE_TYPE (TREE_TYPE (status));
+ tree cond2;
+
+ cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ status,
+ build_int_cst (TREE_TYPE (status), 0));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ fold_build1_loc (input_location, INDIRECT_REF,
+ status_type, status),
+ build_int_cst (status_type, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond2, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&non_null, tmp);
+ }
+ }
+ else
{
- /* We set STATUS to zero if it is present. */
- tree status_type = TREE_TYPE (TREE_TYPE (status));
- tree cond2;
+ tree token;
+ tree pstat = null_pointer_node;
+ gfc_se se;
- cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- status, build_int_cst (TREE_TYPE (status), 0));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
- tmp, build_empty_stmt (input_location));
+ gfc_init_se (&se, NULL);
+ token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
+ gcc_assert (token != NULL_TREE);
+
+ if (status != NULL_TREE && !integer_zerop (status))
+ {
+ gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
+ pstat = status;
+ }
+
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_deregister, 5,
+ token, build_int_cst (integer_type_node,
+ caf_dereg_type),
+ pstat, null_pointer_node, integer_zero_node);
gfc_add_expr_to_block (&non_null, tmp);
+
+ /* 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 (&non_null, tmp);
+
+ if (status != NULL_TREE)
+ {
+ tree stat = build_fold_indirect_ref_loc (input_location, status);
+ tree cond2;
+
+ TREE_USED (label_finish) = 1;
+ tmp = build1_v (GOTO_EXPR, label_finish);
+ cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ stat, build_zero_cst (TREE_TYPE (stat)));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
+ tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&non_null, tmp);
+ }
}
return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
@@ -1516,7 +1601,6 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
gfc_finish_block (&non_null));
}
-
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
following pseudo-code:
@@ -107,7 +107,7 @@ gfc_se;
/* Denotes different types of coarray.
Please keep in sync with libgfortran/caf/libcaf.h. */
-enum gfc_coarray_type
+enum gfc_coarray_regtype
{
GFC_CAF_COARRAY_STATIC,
GFC_CAF_COARRAY_ALLOC,
@@ -115,7 +115,22 @@ enum gfc_coarray_type
GFC_CAF_LOCK_ALLOC,
GFC_CAF_CRITICAL,
GFC_CAF_EVENT_STATIC,
- GFC_CAF_EVENT_ALLOC
+ GFC_CAF_EVENT_ALLOC,
+ GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY,
+ GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
+};
+
+
+/* Describes the action to take on _caf_deregister. Keep in sync with
+ gcc/fortran/trans.h. The negative values are not valid for the library and
+ are used by the drivers for building the correct call. */
+enum gfc_coarray_deregtype {
+ /* This is no coarray, i.e. build a call to a free (). */
+ GFC_CAF_COARRAY_NOCOARRAY = -2,
+ /* The driver is to analyze which _caf_deregister ()-call to generate. */
+ GFC_CAF_COARRAY_ANALYZE = -1,
+ GFC_CAF_COARRAY_DEREGISTER = 0,
+ GFC_CAF_COARRAY_DEALLOCATE_ONLY
};
@@ -140,6 +155,15 @@ enum gfc_caf_array_ref_t {
GFC_CAF_ARR_REF_OPEN_START
};
+
+/* trans-array (structure_alloc_comps) caf_mode bits. */
+enum gfc_structure_caf_mode_t {
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY = 1 << 0,
+ GFC_STRUCTURE_CAF_MODE_IN_COARRAY = 1 << 1,
+ GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY = 1 << 2
+};
+
+
/* The array-specific scalarization information. The array members of
this struct are indexed by actual array index, and thus can be sparse. */
@@ -506,7 +530,8 @@ int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool);
/* Generate code for a scalar assignment. */
-tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool);
+tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
+ bool c = false);
/* Translate COMMON blocks. */
void gfc_trans_common (gfc_namespace *);
@@ -681,6 +706,10 @@ tree gfc_call_malloc (stmtblock_t *, tree, tree);
/* Build a memcpy call. */
tree gfc_build_memcpy_call (tree, tree, tree);
+/* Register memory with the coarray library. */
+void gfc_allocate_using_caf_lib (stmtblock_t *, tree, tree, tree, tree, tree,
+ tree, gfc_coarray_regtype);
+
/* Allocate memory for allocatable variables, with optional status variable. */
void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree,
tree, tree, tree, gfc_expr*, int);
@@ -690,14 +719,15 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
- gfc_expr *, bool);
-tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec);
+ gfc_expr *, int);
+tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*,
+ gfc_typespec, bool c = false);
/* Generate code to call realloc(). */
tree gfc_call_realloc (stmtblock_t *, tree, tree);
/* Assign a derived type constructor to a variable. */
-tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
+tree gfc_trans_structure_assign (tree, gfc_expr *, bool, bool c = false);
/* Generate code for an assignment, includes scalarization. */
tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false,
@@ -808,7 +838,7 @@ extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
extern GTY(()) tree gfor_fndecl_co_reduce;
extern GTY(()) tree gfor_fndecl_co_sum;
-
+extern GTY(()) tree gfor_fndecl_caf_is_present;
/* Math functions. Many other math functions are handled in
trans-intrinsic.c. */
@@ -8,9 +8,9 @@ end type t
type(t) :: a
allocate (a%caf[3:*])
a%caf = 7
-!print *, a%caf
if (a%caf /= 7) call abort ()
if (any (lcobound (a%caf) /= [ 3 ]) &
.or. ucobound (a%caf, dim=1) /= this_image ()+2) &
call abort ()
+deallocate (a%caf)
end
@@ -90,4 +90,7 @@ 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()
+
+deallocate(bar%vec(2)%indices, object%scalar, object%matrix)
+deallocate(bar%vec)
end program
@@ -23,6 +23,7 @@ program main
if ( object%indices(1) /= 1 ) call abort()
end program
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 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" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 1, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 8, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct mytype\\) \\*object\\).indices.token, 1, 0B, 0B, 0\\);" 1 "original" } }
@@ -15,7 +15,7 @@
! { 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" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, 0B, 0B, 0.;" 1 "original" } }
@@ -17,7 +17,7 @@
! { 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" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } }
@@ -18,7 +18,7 @@ subroutine test
! { 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" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } }
new file mode 100644
@@ -0,0 +1,46 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" }
+!
+! Allocate/deallocate with libcaf.
+!
+
+program test_caf_alloc
+
+ type t
+ integer, allocatable :: i
+ real, allocatable :: r(:)
+ end type t
+
+ type(t), allocatable :: xx[:]
+
+ allocate (xx[*])
+
+ if (allocated(xx%i)) call abort()
+ if (allocated(xx[1]%i)) call abort()
+ if (allocated(xx[1]%r)) call abort()
+ allocate(xx%i)
+ if (.not. allocated(xx[1]%i)) call abort()
+ if (allocated(xx[1]%r)) call abort()
+
+ allocate(xx%r(5))
+ if (.not. allocated(xx[1]%i)) call abort()
+ if (.not. allocated(xx[1]%r)) call abort()
+
+ deallocate(xx%i)
+ if (allocated(xx[1]%i)) call abort()
+ if (.not. allocated(xx[1]%r)) call abort()
+
+ deallocate(xx%r)
+ if (allocated(xx[1]%i)) call abort()
+ if (allocated(xx[1]%r)) call abort()
+
+ deallocate(xx)
+end
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_is_present \\(xx\\.token, 2 - \\(integer\\(kind=4\\)\\) xx\\.dim\\\[0\\\]\\.lbound, &caf_ref\\.\[0-9\]+\\)" 10 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(72, 1, &xx\\.token, \\(void \\*\\) &xx, 0B, 0B, 0\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 7" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 8" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&xx\\.token, 0, 0B, 0B, 0\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct t \\* restrict\\) xx\\.data\\)->r\\.token, 1, 0B, 0B, 0\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct t \\* restrict\\) xx\\.data\\)->_caf_i, 1, 0B, 0B, 0\\)" 1 "original" } }
@@ -38,8 +38,8 @@ B(1:5) = B(3:7)
if (any (A-B /= 0)) call abort
end
-! { 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 \\\(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, 0B\\\);" 1 "original" } }
@@ -50,7 +50,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#define STAT_STOPPED_IMAGE 6000
#endif
-/* Describes what type of array we are registerring. Keep in sync with
+/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_STATIC,
@@ -59,10 +59,20 @@ typedef enum caf_register_t {
CAF_REGTYPE_LOCK_ALLOC,
CAF_REGTYPE_CRITICAL,
CAF_REGTYPE_EVENT_STATIC,
- CAF_REGTYPE_EVENT_ALLOC
+ CAF_REGTYPE_EVENT_ALLOC,
+ CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY,
+ CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
}
caf_register_t;
+/* Describes the action to take on _caf_deregister. Keep in sync with
+ gcc/fortran/trans.h. */
+typedef enum caf_deregister_t {
+ CAF_DEREGTYPE_COARRAY_DEREGISTER,
+ CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY
+}
+caf_deregister_t;
+
typedef void* caf_token_t;
typedef gfc_array_void gfc_descriptor_t;
@@ -174,7 +184,8 @@ int _gfortran_caf_num_images (int, 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_deregister (caf_token_t *, caf_deregister_t, int *, char *,
+ int);
void _gfortran_caf_sync_all (int *, char *, int);
void _gfortran_caf_sync_memory (int *, char *, int);
@@ -232,4 +243,6 @@ void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int);
void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int);
void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
+int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *);
+
#endif /* LIBCAF_H */
@@ -144,11 +144,17 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
|| type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
|| type == CAF_REGTYPE_EVENT_ALLOC)
local = calloc (size, sizeof (bool));
+ else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
+ local = NULL;
else
local = malloc (size);
- *token = malloc (sizeof (struct caf_single_token));
- if (unlikely (local == NULL || *token == NULL))
+ if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
+ *token = malloc (sizeof (struct caf_single_token));
+
+ if (unlikely (*token == NULL
+ || (local == NULL
+ && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
{
/* Freeing the memory conditionally seems pointless, but
caf_internal_error () may return, when a stat is given and then the
@@ -163,7 +169,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
single_token = TOKEN (*token);
single_token->memptr = local;
- single_token->owning_memory = true;
+ single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
@@ -184,7 +190,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
void
-_gfortran_caf_deregister (caf_token_t *token, int *stat,
+_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
@@ -193,7 +199,16 @@ _gfortran_caf_deregister (caf_token_t *token, int *stat,
if (single_token->owning_memory && single_token->memptr)
free (single_token->memptr);
- free (TOKEN (*token));
+ if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+ {
+ free (TOKEN (*token));
+ *token = NULL;
+ }
+ else
+ {
+ single_token->memptr = NULL;
+ single_token->owning_memory = false;
+ }
if (stat)
*stat = 0;
@@ -2882,3 +2897,102 @@ _gfortran_caf_unlock (caf_token_t token, size_t index,
}
_gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
}
+
+int
+_gfortran_caf_is_present (caf_token_t token,
+ int image_index __attribute__ ((unused)),
+ caf_reference_t *refs)
+{
+ const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
+ "only scalar indexes allowed.\n";
+ const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown reference type.\n";
+ const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown array reference type.\n";
+ size_t i;
+ caf_single_token_t single_token = TOKEN (token);
+ void *memptr = single_token->memptr;
+ gfc_descriptor_t *src = single_token->desc;
+ caf_reference_t *riter = refs;
+
+ while (riter)
+ {
+ switch (riter->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (riter->u.c.caf_token_offset)
+ {
+ single_token = *(caf_single_token_t*)
+ (memptr + riter->u.c.caf_token_offset);
+ memptr = single_token->memptr;
+ src = single_token->desc;
+ }
+ else
+ {
+ memptr += riter->u.c.offset;
+ src = (gfc_descriptor_t *)memptr;
+ }
+ break;
+ case CAF_REF_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_SINGLE:
+ memptr += (riter->u.a.dim[i].s.start
+ - GFC_DIMENSION_LBOUND (src->dim[i]))
+ * GFC_DIMENSION_STRIDE (src->dim[i])
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_FULL:
+ /* A full array ref is allowed on the last reference only. */
+ if (riter->next == NULL)
+ break;
+ /* else fall through reporting an error. */
+ case CAF_ARR_REF_VECTOR:
+ case CAF_ARR_REF_RANGE:
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+ return 0;
+ default:
+ caf_internal_error (unknownarrreftype, 0, NULL, 0);
+ return 0;
+ }
+ }
+ break;
+ case CAF_REF_STATIC_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_SINGLE:
+ memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_FULL:
+ /* A full array ref is allowed on the last reference only. */
+ if (riter->next == NULL)
+ break;
+ /* else fall through reporting an error. */
+ case CAF_ARR_REF_VECTOR:
+ case CAF_ARR_REF_RANGE:
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
+ return 0;
+ default:
+ caf_internal_error (unknownarrreftype, 0, NULL, 0);
+ return 0;
+ }
+ }
+ break;
+ default:
+ caf_internal_error (unknownreftype, 0, NULL, 0);
+ return 0;
+ }
+ riter = riter->next;
+ }
+ return memptr != NULL;
+}