diff options
25 files changed, 1142 insertions, 252 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1043686..278c08f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,85 @@ +2016-11-30 Andre Vehreschild <vehre@gcc.gnu.org> + + * check.c (gfc_check_allocated): By pass the caf_get call and check on + the array. + * gfortran.h: Add optional flag to gfc_caf_attr. + * gfortran.texi: Document new enum values and _caf_is_present function. + * primary.c (caf_variable_attr): Add optional flag to indicate that the + expression is reffing a component. + (gfc_caf_attr): Likewise. + * trans-array.c (gfc_array_deallocate): Handle deallocation mode for + coarray deregistration. + (gfc_trans_dealloc_allocated): Likewise. + (duplicate_allocatable): Use constants instead of + creating custom constant tree node of zero or one. Use gfc_add_modify + convenience function. + (duplicate_allocatable_coarray): This function is similar to + duplicate_allocatable but tailored to handle coarrays. + (caf_enabled): Check whether in-derived-type coarray processing is + enabled. + (caf_in_coarray): Check that in-derived-type coarray processing is + enabled and currently in a derived-typed coarray. + (gfc_caf_is_dealloc_only): Return true, when deallocate only is + desired for components in derived typed coarrays. + (structure_alloc_comps): A mode for handling coarrays, that is no + longer encode in the purpose. This makes the use cases of the + routine more flexible without repeating. Allocatable components in + derived type coarrays are now registered only when nullifying an + object and allocated before copying data into them. + (gfc_nullify_alloc_comp): Use the caf_mode of structure_alloc_comps + now. + (gfc_deallocate_alloc_comp): Likewise. + (gfc_deallocate_alloc_comp_no_caf): Likewise. + (gfc_reassign_alloc_comp_caf): Likewise. + (gfc_copy_alloc_comp): Likewise. + (gfc_copy_only_alloc_comp): Likewise. + (gfc_alloc_allocatable_for_assignment): Make use to the cheaper way of + reallocating a coarray without deregistering and reregistering it. + (gfc_trans_deferred_array): Initialize the coarray token correctly for + deferred variables and tear them down on exit. + * trans-array.h: Change some prototypes to add the coarray (de-) + registration modes. Add prototype for checking if deallocate only is + selected for components in derived typed coarrays. + * trans-decl.c (gfc_build_builtin_function_decls): Generate the + declarations for the changed/new caf-lib routines. + (gfc_trans_deferred_vars): Ensure deferred variables are (de-) + registered correctly on procedure entry/exit. + (generate_coarray_sym_init): Use constants. + * trans-expr.c (gfc_conv_procedure_call): Propagate coarray allocation + modes accordingly. + (gfc_trans_alloc_subarray_assign): Likewise. + (gfc_trans_subcomponent_assign): Likewise. + (gfc_trans_structure_assign): Generate code to register the components + of a derived type coarray prior to initialization. + (gfc_conv_structure): Set flag that the structure is in a coarray. + (gfc_trans_scalar_assign): Add flag to indicate being in a coarray and + set the structure_alloc_comps modes correctly. + (gfc_trans_assignment_1): Figure being in a coarray expression. + * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Adapt to new + structure_alloc_comps interface. + (conv_caf_send): Use the old API as long as possible. + (trans_caf_is_present): Generate code to check whether an allocatable + component in a derived typed coarray is allocated on a remote image. + (caf_this_image_ref): Return true, when only reffing this image. + (gfc_conv_allocated): Convert allocated queries on allocatable + components to the library API. + (conv_intrinsic_move_alloc): Adapt to new interface of + structure_alloc_comps. + * trans-openmp.c (gfc_walk_alloc_comps): Likewise. + (gfc_omp_clause_assign_op): Likewise. + (gfc_omp_clause_dtor): Likewise. + * trans-stmt.c (gfc_trans_deallocate): Figure which mode to use when + deallocating allocatable components in derived type coarras. + * trans.c (gfc_allocate_using_lib): Renamed to + gfc_allcate_using_caf_lib. + (gfc_allocate_allocatable): Set the registration mode/type of caf- + register calls adapting to all the possible allocatable objects. + (gfc_deallocate_with_status): Add deregistration mode for allocatable + components in derived type coarrays. + (gfc_deallocate_scalar_with_status): Likewise. + * trans.h (enum gfc_coarray_type): Renamed to gfc_coarray_regtype to + avoid collision with gfc_coarray_deregtype. + 2016-11-30 Janus Weil <janus@gcc.gnu.org> PR fortran/78593 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 265fe22..3b80156 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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)) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7956630..370b2a0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 6d8805c..5e2a750 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -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 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 2b20f8c..eb2d780 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1708f7c..803462a4 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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. */ @@ -7855,9 +7859,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) { - tmp = null_pointer_node; - tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp); - gfc_add_expr_to_block (&block, tmp); + gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); null_data = gfc_finish_block (&block); gfc_init_block (&block); @@ -7869,9 +7871,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, if (!no_malloc) { tmp = gfc_call_malloc (&block, type, size); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - dest, fold_convert (type, tmp)); - gfc_add_expr_to_block (&block, tmp); + gfc_add_modify (&block, dest, fold_convert (type, tmp)); } if (!no_memcpy) @@ -7967,17 +7967,152 @@ 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); +} + + +/* Helper function to abstract whether coarray processing is enabled. */ + +static bool +caf_enabled (int caf_mode) +{ + return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) + == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY; +} + + +/* Helper function to abstract whether coarray processing is enabled + and we are in a derived type coarray. */ + +static bool +caf_in_coarray (int caf_mode) +{ + static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY; + return (caf_mode & pat) == pat; +} + + +/* Helper function to abstract whether coarray is to deallocate only. */ + +bool +gfc_caf_is_dealloc_only (int caf_mode) +{ + return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) + == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY; +} + + /* 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 +8146,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 +8191,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_enabled (caf_mode)) + { 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 +8248,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 +8264,57 @@ 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_enabled (caf_mode)); } 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_enabled (caf_mode) + && (caf_in_coarray (caf_mode) || c->attr.codimension)))) { + /* Allocatable arrays or coarray'ed components (scalar or + array). */ + int caf_dereg_mode + = (caf_in_coarray (caf_mode) || c->attr.codimension) + ? (gfc_caf_is_dealloc_only (caf_mode) + ? 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 +8324,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 +8341,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 +8362,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 +8372,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 +8420,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_enabled (caf_mode))) { /* Allocatable CLASS components. */ @@ -8257,11 +8430,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 +8494,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 +8503,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 +8537,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 +8555,92 @@ 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_in_coarray (caf_mode) || 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_enabled (caf_mode) + && (c->attr.codimension + || (c->ts.type == BT_CLASS + && (CLASS_DATA (c)->attr.coarray_comp + || caf_in_coarray (caf_mode))) + || (c->ts.type == BT_DERIVED + && (c->ts.u.derived->attr.coarray_comp + || caf_in_coarray (caf_mode)))) + && !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 +8733,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 +8761,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_in_coarray (caf_mode))) { 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_in_coarray (caf_mode)) + { + 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 +8806,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 +8815,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 +8833,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 +8849,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 +8863,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 +9456,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 +9651,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 +9698,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); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index d0309b2..0a6621b 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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); @@ -52,13 +52,15 @@ tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank); tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int); +bool gfc_caf_is_dealloc_only (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); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ba71a21..2e6ef2a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); } } @@ -5093,8 +5103,8 @@ generate_coarray_sym_init (gfc_symbol *sym) build_int_cst (integer_type_node, reg_type), 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)); + null_pointer_node, /* errgmsg. */ + integer_zero_node); /* errmsg_len. */ 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))); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1c2d5e1..78bff87 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 463bb58..d7612f6 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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); } diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 59fd6b3..d460048 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -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); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 19ecf68..514db28 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -6409,6 +6409,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) @@ -6421,11 +6424,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; @@ -6439,16 +6463,34 @@ 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 = gfc_caf_is_dealloc_only (caf_mode) + ? GFC_CAF_COARRAY_DEALLOCATE_ONLY + : GFC_CAF_COARRAY_DEREGISTER; + 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 @@ -6491,8 +6533,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. */ diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index aaec1c22..6a1d481 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 02a8a56..ae1f156 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2c8b3a0..a9cfb56 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2016-11-30 Andre Vehreschild <vehre@gcc.gnu.org> + + * gfortran.dg/coarray/alloc_comp_1.f90: Fix tree-dump scans to adhere + to the changed interfaces. + * gfortran.dg/coarray_alloc_comp_1.f08: Likewise. + * gfortran.dg/coarray_allocate_7.f08: Likewise. + * gfortran.dg/coarray_lib_alloc_1.f90: Likewise. + * gfortran.dg/coarray_lib_alloc_2.f90: Likewise. + * gfortran.dg/coarray_lib_alloc_3.f90: Likewise. + * gfortran.dg/coarray_lib_comm_1.f90: Likewise. + * gfortran.dg/coarray_lib_alloc_4.f90: New test. + 2016-11-30 Janus Weil <janus@gcc.gnu.org> PR fortran/78593 diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 index 6baeabf..f1136e3 100644 --- a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 index 659fd48..8c35fc8 100644 --- a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_1.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 b/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 index 4b08941..d924176 100644 --- a/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 +++ b/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 index 31e4cf5..4f90bdf 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 index a83963c..90998ee 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 index 33cda92..17f800f 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 index a17feab..8ad6b08 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 @@ -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" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index affc7f0..97dda7b 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,17 @@ +2016-11-30 Andre Vehreschild <vehre@gcc.gnu.org> + + * caf/libcaf.h: Add new action types for (de-)registration of + allocatable components in derived type coarrays. Add _caf_is_present + prototype. + * caf/single.c (_gfortran_caf_register): Add support for registration + only and allocation of already registered allocatable components in + derived type coarrays. + (_gfortran_caf_deregister): Add mode to deallocate but not deregister + an allocatable component in a derived type coarray. + (_gfortran_caf_is_present): New function. Query whether an + allocatable component in a derived type coarray on a remote image is + allocated. + 2016-11-16 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libgfortran/51119 diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index aad0f62..1bb5176 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -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 */ diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 00b7120..5e2932c 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -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; +} |