From: Thomas Koenig Date: Wed, 23 Dec 2020 10:40:00 +0000 (+0100) Subject: Add offset to allocatable shared coarrays. X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=fe0069ed4d6e61dfcd8e66e227690635ba317d1a;p=thirdparty%2Fgcc.git Add offset to allocatable shared coarrays. This adds the calculation of the offset for allocatable coarrays, which was missing before, and fixes the resulting fallout for ALLOCATED. Additionally, it prepares the way for STAT and ERRMSG for ALLOCATE of coarrays, but that still needs changes to gfc_trans_allocate. gcc/fortran/ChangeLog: * trans-array.c (gfc_conv_array_ref): If se->address_only is set, throw away all the offset calculation. (gfc_allocate_shared_coarray): Add arguments stat, errmsg and errlen to call to allocate. Calculate offset for allocatable coarrays. (gfc_array_allocate): Adjust call to gfc_allocate_shared_coarray. * trans-array.h (gfc_allocate_shared_coarray): Change prototype of cas_coarray_alloc. * trans-decl.c (gfc_build_builtin_function_decls): Adjust cas_coarray_alloc to changed prototypes. (gfc_trans_shared_coarray): Adjust call to gfc_allocate_shared_coarray. * trans-intrinsic.c (gfc_conv_allocated): Set address_only on se. * trans.h: Add flag address_only to gfc_se. libgfortran/ChangeLog: * caf_shared/wrapper.c (cas_coarray_alloc): Add status, error and errmsg arguments and their checking. --- diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 39e6b6d9051d..35afff5845e5 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3865,8 +3865,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, add_to_offset (&cst_offset, &offset, tmp); } - if (flag_coarray == GFC_FCOARRAY_SHARED && need_impl_this_image - && !se->no_impl_this_image) + if (flag_coarray == GFC_FCOARRAY_SHARED && need_impl_this_image) { tree off; tree co_stride = gfc_conv_array_stride (decl, eff_dimen + 1); @@ -3934,6 +3933,15 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, decl = NULL_TREE; } + /* Early return - only taken for ALLOCATED for shared coarrays. + FIXME - this could probably be done more elegantly. */ + if (se->address_only) + { + se->expr = build_array_ref (se->expr, build_int_cst (TREE_TYPE (offset), 0), + decl, se->class_vptr); + return; + } + se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); } @@ -5975,15 +5983,41 @@ gfc_cas_get_allocation_type (gfc_symbol * sym) } void -gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int corank, - int alloc_type) +gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank, + int corank, int alloc_type, tree status, + tree errmsg, tree errlen, bool calc_offset) { + tree st, err, elen; + + if (status == NULL_TREE) + st = null_pointer_node; + else + st = gfc_build_addr_expr (NULL, status); + + err = errmsg == NULL_TREE ? null_pointer_node : errmsg; + elen = errlen == NULL_TREE ? build_int_cst (gfc_charlen_type_node, 0) : errlen; gfc_add_expr_to_block (b, build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_allocate, - 4, gfc_build_addr_expr (pvoid_type_node, decl), - size, build_int_cst (integer_type_node, corank), - build_int_cst (integer_type_node, alloc_type))); - + 7, gfc_build_addr_expr (pvoid_type_node, decl), + size, build_int_cst (integer_type_node, corank), + build_int_cst (integer_type_node, alloc_type), + st, err, elen)); + if (calc_offset) + { + int i; + tree offset, stride, lbound, mult; + offset = build_int_cst (gfc_array_index_type, 0); + for (i = 0; i < rank + corank; i++) + { + stride = gfc_conv_array_stride (decl, i); + lbound = gfc_conv_array_lbound (decl, i); + mult = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, lbound); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, mult); + } + gfc_conv_descriptor_offset_set (b, decl, offset); + } } /* Initializes the descriptor and generates a call to _gfor_allocate. Does @@ -6193,7 +6227,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, int alloc_type = gfc_cas_get_allocation_type (expr->symtree->n.sym); gfc_allocate_shared_coarray (&elseblock, se->expr, elem_size, - ref->u.ar.as->corank, alloc_type); + ref->u.ar.as->rank, ref->u.ar.as->corank, + alloc_type, status, errmsg, errlen, + true); } /* The allocatable variant takes the old pointer as first argument. */ else if (allocatable) diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 66f59bb068ba..2168e9dc9015 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -31,7 +31,8 @@ enum gfc_coarray_allocation_type { int gfc_cas_get_allocation_type (gfc_symbol *); -void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int); +void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int, int, + tree, tree, tree, bool); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 91a5dca0c7f0..f3526db7ea63 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4118,9 +4118,15 @@ gfc_build_builtin_function_decls (void) get_identifier (PREFIX("cas_master")), ". r ", integer_type_node, 1, build_pointer_type (build_function_type_list (void_type_node, NULL_TREE))); gfor_fndecl_cas_coarray_allocate = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R ", integer_type_node, 4, - pvoid_type_node, integer_type_node, integer_type_node, integer_type_node, - NULL_TREE); + get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R W W . ", integer_type_node, 7, + pvoid_type_node, /* desc. */ + size_type_node, /* elem_size. */ + integer_type_node, /* corank. */ + integer_type_node, /* alloc_type. */ + pvoid_type_node, /* stat. */ + pvoid_type_node, /* errmsg. */ + gfc_charlen_type_node, /* errmsg_len. */ + NULL_TREE); gfor_fndecl_cas_coarray_free = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("cas_coarray_free")), ". . R ", integer_type_node, 2, pvoid_type_node, /* Pointer to the descriptor to be deallocated. */ @@ -4689,10 +4695,13 @@ gfc_trans_shared_coarray (stmtblock_t * init, stmtblock_t *cleanup, gfc_symbol * init, &overflow, NULL_TREE, &nelems, NULL, NULL_TREE, true, NULL, &element_size); - gfc_conv_descriptor_offset_set (init, decl, offset); elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(decl))); - gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->corank, - alloc_type); + gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->rank, + sym->as->corank, alloc_type, null_pointer_node, + null_pointer_node, + build_int_cst (gfc_charlen_type_node, 0), + false); + gfc_conv_descriptor_offset_set (init, decl, offset); } if (cleanup) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e93cd3a12c7f..912c9b03a749 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8832,7 +8832,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) { /* Allocatable scalar. */ arg1se.want_pointer = 1; - arg1se.no_impl_this_image = 1; + arg1se.address_only = 1; gfc_conv_expr (&arg1se, arg1->expr); tmp = arg1se.expr; } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index f3cf33b342f4..d3340b302ad8 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -98,10 +98,9 @@ typedef struct gfc_se arrays in gfc_conv_expr_descriptor. */ unsigned use_offset:1; - /* For shared coarrays, do not add the offset for the implied - this_image(). */ - - unsigned no_impl_this_image:1; + /* Set if an array reference should be converted to an address of + its data pointer only. */ + unsigned address_only:1; unsigned want_coarray:1; diff --git a/gcc/testsuite/gfortran.dg/caf-shared/coarray_allocate_3.f08 b/gcc/testsuite/gfortran.dg/caf-shared/coarray_allocate_3.f08 new file mode 100644 index 000000000000..bb9b5f106966 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/caf-shared/coarray_allocate_3.f08 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" } +! Contributed by Ian Harvey +! Extended by Andre Vehreschild +! to test that coarray references in allocate work now +! PR fortran/67451 + + program main + implicit none + type foo + integer :: bar = 99 + end type + class(foo), dimension(:), allocatable :: foobar[:] + class(foo), dimension(:), allocatable :: some_local_object + allocate(foobar(10)[*]) + + allocate(some_local_object, source=foobar) + + if (.not. allocated(foobar)) STOP 1 + if (lbound(foobar, 1) /= 1 .OR. ubound(foobar, 1) /= 10) STOP 2 + if (.not. allocated(some_local_object)) STOP 3 + if (any(some_local_object(:)%bar /= [99, 99, 99, 99, 99, 99, 99, 99, 99, 99])) STOP 4 + + deallocate(some_local_object) + deallocate(foobar) + end program + diff --git a/libgfortran/caf_shared/wrapper.c b/libgfortran/caf_shared/wrapper.c index 471619441c0c..a3d88660f01e 100644 --- a/libgfortran/caf_shared/wrapper.c +++ b/libgfortran/caf_shared/wrapper.c @@ -44,7 +44,8 @@ enum gfc_coarray_allocation_type GFC_NCA_EVENT_COARRAY, }; -void cas_coarray_alloc (gfc_array_void *, int, int, int); +void cas_coarray_alloc (gfc_array_void *, size_t, int, int, int *, + char *, size_t); export_proto (cas_coarray_alloc); void cas_coarray_free (gfc_array_void *, int); @@ -85,8 +86,8 @@ void cas_collsub_broadcast_scalar (void *restrict, size_t, int, int *, char *, export_proto (cas_collsub_broadcast_scalar); void -cas_coarray_alloc (gfc_array_void *desc, int elem_size, int corank, - int alloc_type) +cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank, + int alloc_type, int *status, char *errmsg, size_t errmsg_len) { int i, last_rank_index; int num_coarray_elems, num_elems; /* Excludes the last dimension, because it @@ -98,6 +99,7 @@ cas_coarray_alloc (gfc_array_void *desc, int elem_size, int corank, ensure_initialization (); /* This function might be the first one to be called, if it is called in a constructor. */ + STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len); if (alloc_type == GFC_NCA_LOCK_COARRAY) elem_size = sizeof (pthread_mutex_t); else if (alloc_type == GFC_NCA_EVENT_COARRAY)