From: Julian Brown Date: Fri, 20 Dec 2019 01:20:42 +0000 (+0000) Subject: OpenACC 2.6 deep copy: Fortran front-end parts X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=549188ea10757060b5de532d232813f09d64d9d1;p=gcc.git OpenACC 2.6 deep copy: Fortran front-end parts gcc/fortran/ * gfortran.h (gfc_omp_map_op): Add OMP_MAP_ATTACH, OMP_MAP_DETACH. * openmp.c (gfc_match_omp_variable_list): Add allow_derived parameter. Parse derived-type member accesses if true. (omp_mask2): Add OMP_CLAUSE_ATTACH and OMP_CLAUSE_DETACH. (gfc_match_omp_map_clause): Add allow_derived parameter. Pass to gfc_match_omp_variable_list. (gfc_match_omp_clauses): Support attach and detach. Support derived types for appropriate OpenACC directives. (OACC_PARALLEL_CLAUSES, OACC_SERIAL_CLAUSES, OACC_KERNELS_CLAUSES, OACC_DATA_CLAUSES, OACC_ENTER_DATA_CLAUSES): Add OMP_CLAUSE_ATTACH. (OACC_EXIT_DATA_CLAUSES): Add OMP_CLAUSE_DETACH. (check_symbol_not_pointer): Don't disallow pointer objects of derived type. (resolve_oacc_data_clauses): Don't disallow allocatable derived types. (resolve_omp_clauses): Perform duplicate checking only for non-derived type component accesses (plain variables and arrays or array sections). Support component refs. * trans-expr.c (gfc_conv_component_ref, conv_parent_component_references): Make global. (gfc_maybe_dereference_var): New function, broken out of... (gfc_conv_variable): ...here. Call above function. * trans-openmp.c (gfc_omp_privatize_by_reference): Support component refs. (gfc_trans_omp_array_section): New function, broken out of... (gfc_trans_omp_clauses): ...here. Support component refs/derived types, attach and detach clauses. * trans.h (gfc_conv_component_ref, conv_parent_component_references, gfc_maybe_dereference_var): Add prototypes. gcc/testsuite/ * gfortran.dg/goacc/derived-types.f90: New test. * gfortran.dg/goacc/derived-types-2.f90: New test. * gfortran.dg/goacc/derived-types-3.f90: New test. * gfortran.dg/goacc/data-clauses.f95: Adjust for expected errors. * gfortran.dg/goacc/enter-exit-data.f95: Likewise. From-SVN: r279628 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7a71c70a6e9..d87a107cc16 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,34 @@ +2019-12-19 Julian Brown + + * gfortran.h (gfc_omp_map_op): Add OMP_MAP_ATTACH, OMP_MAP_DETACH. + * openmp.c (gfc_match_omp_variable_list): Add allow_derived parameter. + Parse derived-type member accesses if true. + (omp_mask2): Add OMP_CLAUSE_ATTACH and OMP_CLAUSE_DETACH. + (gfc_match_omp_map_clause): Add allow_derived parameter. Pass to + gfc_match_omp_variable_list. + (gfc_match_omp_clauses): Support attach and detach. Support derived + types for appropriate OpenACC directives. + (OACC_PARALLEL_CLAUSES, OACC_SERIAL_CLAUSES, OACC_KERNELS_CLAUSES, + OACC_DATA_CLAUSES, OACC_ENTER_DATA_CLAUSES): Add OMP_CLAUSE_ATTACH. + (OACC_EXIT_DATA_CLAUSES): Add OMP_CLAUSE_DETACH. + (check_symbol_not_pointer): Don't disallow pointer objects of derived + type. + (resolve_oacc_data_clauses): Don't disallow allocatable derived types. + (resolve_omp_clauses): Perform duplicate checking only for non-derived + type component accesses (plain variables and arrays or array sections). + Support component refs. + * trans-expr.c (gfc_conv_component_ref, + conv_parent_component_references): Make global. + (gfc_maybe_dereference_var): New function, broken out of... + (gfc_conv_variable): ...here. Call above function. + * trans-openmp.c (gfc_omp_privatize_by_reference): Support component + refs. + (gfc_trans_omp_array_section): New function, broken out of... + (gfc_trans_omp_clauses): ...here. Support component refs/derived + types, attach and detach clauses. + * trans.h (gfc_conv_component_ref, conv_parent_component_references, + gfc_maybe_dereference_var): Add prototypes. + 2019-12-19 Mark Eggleston PR fortran/92896 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a266edb8ed8..7919b690ec0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1193,10 +1193,12 @@ enum gfc_omp_map_op { OMP_MAP_ALLOC, OMP_MAP_IF_PRESENT, + OMP_MAP_ATTACH, OMP_MAP_TO, OMP_MAP_FROM, OMP_MAP_TOFROM, OMP_MAP_DELETE, + OMP_MAP_DETACH, OMP_MAP_FORCE_ALLOC, OMP_MAP_FORCE_TO, OMP_MAP_FORCE_FROM, diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 576003d7ff8..97d90ef5582 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -233,7 +233,8 @@ static match gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, bool allow_common, bool *end_colon = NULL, gfc_omp_namelist ***headp = NULL, - bool allow_sections = false) + bool allow_sections = false, + bool allow_derived = false) { gfc_omp_namelist *head, *tail, *p; locus old_loc, cur_loc; @@ -259,7 +260,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, case MATCH_YES: gfc_expr *expr; expr = NULL; - if (allow_sections && gfc_peek_ascii_char () == '(') + if ((allow_sections && gfc_peek_ascii_char () == '(') + || (allow_derived && gfc_peek_ascii_char () == '%')) { gfc_current_locus = cur_loc; m = gfc_match_variable (&expr, 0); @@ -797,7 +799,7 @@ enum omp_mask1 OMP_MASK1_LAST }; -/* OpenACC 2.0 specific clauses. */ +/* OpenACC 2.0+ specific clauses. */ enum omp_mask2 { OMP_CLAUSE_ASYNC, @@ -824,6 +826,8 @@ enum omp_mask2 OMP_CLAUSE_TILE, OMP_CLAUSE_IF_PRESENT, OMP_CLAUSE_FINALIZE, + OMP_CLAUSE_ATTACH, + OMP_CLAUSE_DETACH, /* This must come last. */ OMP_MASK2_LAST }; @@ -928,10 +932,11 @@ omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) static bool gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, - bool allow_common) + bool allow_common, bool allow_derived) { gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true) + if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true, + allow_derived) == MATCH_YES) { gfc_omp_namelist *n; @@ -953,6 +958,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; + /* Determine whether we're dealing with an OpenACC directive that permits + derived type member accesses. This in particular disallows + "!$acc declare" from using such accesses, because it's not clear if/how + that should work. */ + bool allow_derived = (openacc + && ((mask & OMP_CLAUSE_ATTACH) + || (mask & OMP_CLAUSE_DETACH) + || (mask & OMP_CLAUSE_HOST_SELF))); gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); *cp = NULL; @@ -1026,6 +1039,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, needs_space = true; continue; } + if ((mask & OMP_CLAUSE_ATTACH) + && gfc_match ("attach ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_ATTACH, false, + allow_derived)) + continue; break; case 'c': if ((mask & OMP_CLAUSE_COLLAPSE) @@ -1053,7 +1072,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true)) + OMP_MAP_TOFROM, true, + allow_derived)) continue; if (mask & OMP_CLAUSE_COPYIN) { @@ -1061,7 +1081,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { if (gfc_match ("copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true)) + OMP_MAP_TO, true, + allow_derived)) continue; } else if (gfc_match_omp_variable_list ("copyin (", @@ -1072,7 +1093,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", @@ -1082,7 +1103,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true)) + OMP_MAP_ALLOC, true, allow_derived)) continue; break; case 'd': @@ -1118,7 +1139,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_DELETE) && gfc_match ("delete ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_RELEASE, true)) + OMP_MAP_RELEASE, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEPEND) && gfc_match ("depend ( ") == MATCH_YES) @@ -1161,6 +1183,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else gfc_current_locus = old_loc; } + if ((mask & OMP_CLAUSE_DETACH) + && gfc_match ("detach ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_DETACH, false, + allow_derived)) + continue; if ((mask & OMP_CLAUSE_DEVICE) && !openacc && c->device == NULL @@ -1170,12 +1198,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, && openacc && gfc_match ("device ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TO, true)) + OMP_MAP_FORCE_TO, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICEPTR) && gfc_match ("deviceptr ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_DEVICEPTR, false)) + OMP_MAP_FORCE_DEVICEPTR, false, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) && gfc_match_omp_variable_list @@ -1253,7 +1283,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("host ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM, true)) + OMP_MAP_FORCE_FROM, true, + allow_derived)) continue; break; case 'i': @@ -1449,7 +1480,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_NO_CREATE) && gfc_match ("no_create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_IF_PRESENT, true)) + OMP_MAP_IF_PRESENT, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_NOGROUP) && !c->nogroup @@ -1530,47 +1562,49 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPY) && gfc_match ("pcopy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true)) + OMP_MAP_TOFROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("pcopyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true)) + OMP_MAP_TO, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("pcopyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("pcreate ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true)) + OMP_MAP_ALLOC, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT) && gfc_match ("present ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_PRESENT, false)) + OMP_MAP_FORCE_PRESENT, false, + allow_derived)) continue; if ((mask & OMP_CLAUSE_COPY) && gfc_match ("present_or_copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true)) + OMP_MAP_TOFROM, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("present_or_copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true)) + OMP_MAP_TO, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("present_or_copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true)) + OMP_MAP_FROM, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("present_or_create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true)) + OMP_MAP_ALLOC, true, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRIORITY) && c->priority == NULL @@ -1688,8 +1722,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (gfc_match_omp_variable_list (" :", &c->lists[OMP_LIST_REDUCTION], - false, NULL, &head, - openacc) == MATCH_YES) + false, NULL, &head, openacc, + allow_derived) == MATCH_YES) { gfc_omp_namelist *n; if (rop == OMP_REDUCTION_NONE) @@ -1788,7 +1822,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("self ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM, true)) + OMP_MAP_FORCE_FROM, true, + allow_derived)) continue; if ((mask & OMP_CLAUSE_SEQ) && !c->seq @@ -1963,23 +1998,23 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT) + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) #define OACC_KERNELS_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT) + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) #define OACC_SERIAL_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \ | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT) + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) #define OACC_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ - | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT) + | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH) #define OACC_LOOP_CLAUSES \ (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ @@ -2002,10 +2037,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT) #define OACC_ENTER_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ - | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE) + | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH) #define OACC_EXIT_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ - | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE) + | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ + | OMP_CLAUSE_DETACH) #define OACC_WAIT_CLAUSES \ omp_mask (OMP_CLAUSE_ASYNC) #define OACC_ROUTINE_CLAUSES \ @@ -3853,9 +3889,6 @@ resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause) static void check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name) { - if (sym->ts.type == BT_DERIVED && sym->attr.pointer) - gfc_error ("POINTER object %qs of derived type in %s clause at %L", - sym->name, name, &loc); if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer) gfc_error ("Cray pointer object %qs of derived type in %s clause at %L", sym->name, name, &loc); @@ -3896,9 +3929,6 @@ check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name) static void resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) { - if (sym->ts.type == BT_DERIVED && sym->attr.allocatable) - gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L", - sym->name, name, &loc); if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable) || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.allocatable)) @@ -4281,11 +4311,26 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && (list != OMP_LIST_REDUCTION || !openacc)) for (n = omp_clauses->lists[list]; n; n = n->next) { - if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &n->where); - else - n->sym->mark = 1; + bool array_only_p = true; + /* Disallow duplicate bare variable references and multiple + subarrays of the same array here, but allow multiple components of + the same (e.g. derived-type) variable. For the latter, duplicate + components are detected elsewhere. */ + if (openacc && n->expr && n->expr->expr_type == EXPR_VARIABLE) + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type != REF_ARRAY) + { + array_only_p = false; + break; + } + if (array_only_p) + { + if (n->sym->mark) + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &n->where); + else + n->sym->mark = 1; + } } gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); @@ -4476,23 +4521,42 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "are allowed on ORDERED directive at %L", &n->where); } + gfc_ref *array_ref = NULL; + bool resolved = false; if (n->expr) { - if (!gfc_resolve_expr (n->expr) + array_ref = n->expr->ref; + resolved = gfc_resolve_expr (n->expr); + + /* Look through component refs to find last array + reference. */ + if (openacc && resolved) + while (array_ref + && (array_ref->type == REF_COMPONENT + || (array_ref->type == REF_ARRAY + && array_ref->next + && (array_ref->next->type + == REF_COMPONENT)))) + array_ref = array_ref->next; + } + if (array_ref + || (n->expr + && (!resolved || n->expr->expr_type != EXPR_VARIABLE))) + { + if (!resolved || n->expr->expr_type != EXPR_VARIABLE - || n->expr->ref == NULL - || n->expr->ref->next - || n->expr->ref->type != REF_ARRAY) + || array_ref->next + || array_ref->type != REF_ARRAY) gfc_error ("%qs in %s clause at %L is not a proper " "array section", n->sym->name, name, &n->where); - else if (n->expr->ref->u.ar.codimen) - gfc_error ("Coarrays not supported in %s clause at %L", - name, &n->where); + else if (gfc_is_coindexed (n->expr)) + gfc_error ("Entry shall not be coindexed in %s " + "clause at %L", name, &n->where); else { int i; - gfc_array_ref *ar = &n->expr->ref->u.ar; + gfc_array_ref *ar = &array_ref->u.ar; for (i = 0; i < ar->dimen; i++) if (ar->stride[i]) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index eb3250a6ab3..61ba4a6afc0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2423,7 +2423,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, /* Convert a derived type component reference. */ -static void +void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) { gfc_component *c; @@ -2513,7 +2513,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) /* This function deals with component references to components of the parent type for derived type extensions. */ -static void +void conv_parent_component_references (gfc_se * se, gfc_ref * ref) { gfc_component *c; @@ -2579,6 +2579,95 @@ conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts) se->expr = res; } +/* Dereference VAR where needed if it is a pointer, reference, etc. + according to Fortran semantics. */ + +tree +gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p, + bool is_classarray) +{ + /* Characters are entirely different from other types, they are treated + separately. */ + if (sym->ts.type == BT_CHARACTER) + { + /* Dereference character pointer dummy arguments + or results. */ + if ((sym->attr.pointer || sym->attr.allocatable) + && (sym->attr.dummy + || sym->attr.function + || sym->attr.result)) + var = build_fold_indirect_ref_loc (input_location, var); + } + else if (!sym->attr.value) + { + /* Dereference temporaries for class array dummy arguments. */ + if (sym->attr.dummy && is_classarray + && GFC_ARRAY_TYPE_P (TREE_TYPE (var))) + { + if (!descriptor_only_p) + var = GFC_DECL_SAVED_DESCRIPTOR (var); + + var = build_fold_indirect_ref_loc (input_location, var); + } + + /* Dereference non-character scalar dummy arguments. */ + if (sym->attr.dummy && !sym->attr.dimension + && !(sym->attr.codimension && sym->attr.allocatable) + && (sym->ts.type != BT_CLASS + || (!CLASS_DATA (sym)->attr.dimension + && !(CLASS_DATA (sym)->attr.codimension + && CLASS_DATA (sym)->attr.allocatable)))) + var = build_fold_indirect_ref_loc (input_location, var); + + /* Dereference scalar hidden result. */ + if (flag_f2c && sym->ts.type == BT_COMPLEX + && (sym->attr.function || sym->attr.result) + && !sym->attr.dimension && !sym->attr.pointer + && !sym->attr.always_explicit) + var = build_fold_indirect_ref_loc (input_location, var); + + /* Dereference non-character, non-class pointer variables. + These must be dummies, results, or scalars. */ + if (!is_classarray + && (sym->attr.pointer || sym->attr.allocatable + || gfc_is_associate_pointer (sym) + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) + && (sym->attr.dummy + || sym->attr.function + || sym->attr.result + || (!sym->attr.dimension + && (!sym->attr.codimension || !sym->attr.allocatable)))) + var = build_fold_indirect_ref_loc (input_location, var); + /* Now treat the class array pointer variables accordingly. */ + else if (sym->ts.type == BT_CLASS + && sym->attr.dummy + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && ((CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer)) + var = build_fold_indirect_ref_loc (input_location, var); + /* And the case where a non-dummy, non-result, non-function, + non-allotable and non-pointer classarray is present. This case was + previously covered by the first if, but with introducing the + condition !is_classarray there, that case has to be covered + explicitly. */ + else if (sym->ts.type == BT_CLASS + && !sym->attr.dummy + && !sym->attr.function + && !sym->attr.result + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension) + && (sym->assoc + || !CLASS_DATA (sym)->attr.allocatable) + && !CLASS_DATA (sym)->attr.class_pointer) + var = build_fold_indirect_ref_loc (input_location, var); + } + + return var; +} + /* Return the contents of a variable. Also handles reference/pointer variables (all Fortran pointer references are implicit). */ @@ -2685,94 +2774,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) return; } - - /* Dereference the expression, where needed. Since characters - are entirely different from other types, they are treated - separately. */ - if (sym->ts.type == BT_CHARACTER) - { - /* Dereference character pointer dummy arguments - or results. */ - if ((sym->attr.pointer || sym->attr.allocatable) - && (sym->attr.dummy - || sym->attr.function - || sym->attr.result)) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - - } - else if (!sym->attr.value) - { - /* Dereference temporaries for class array dummy arguments. */ - if (sym->attr.dummy && is_classarray - && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))) - { - if (!se->descriptor_only) - se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr); - - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - } - - /* Dereference non-character scalar dummy arguments. */ - if (sym->attr.dummy && !sym->attr.dimension - && !(sym->attr.codimension && sym->attr.allocatable) - && (sym->ts.type != BT_CLASS - || (!CLASS_DATA (sym)->attr.dimension - && !(CLASS_DATA (sym)->attr.codimension - && CLASS_DATA (sym)->attr.allocatable)))) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - - /* Dereference scalar hidden result. */ - if (flag_f2c && sym->ts.type == BT_COMPLEX - && (sym->attr.function || sym->attr.result) - && !sym->attr.dimension && !sym->attr.pointer - && !sym->attr.always_explicit) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - - /* Dereference non-character, non-class pointer variables. - These must be dummies, results, or scalars. */ - if (!is_classarray - && (sym->attr.pointer || sym->attr.allocatable - || gfc_is_associate_pointer (sym) - || (sym->as && sym->as->type == AS_ASSUMED_RANK)) - && (sym->attr.dummy - || sym->attr.function - || sym->attr.result - || (!sym->attr.dimension - && (!sym->attr.codimension || !sym->attr.allocatable)))) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - /* Now treat the class array pointer variables accordingly. */ - else if (sym->ts.type == BT_CLASS - && sym->attr.dummy - && (CLASS_DATA (sym)->attr.dimension - || CLASS_DATA (sym)->attr.codimension) - && ((CLASS_DATA (sym)->as - && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) - || CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.class_pointer)) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - /* And the case where a non-dummy, non-result, non-function, - non-allotable and non-pointer classarray is present. This case was - previously covered by the first if, but with introducing the - condition !is_classarray there, that case has to be covered - explicitly. */ - else if (sym->ts.type == BT_CLASS - && !sym->attr.dummy - && !sym->attr.function - && !sym->attr.result - && (CLASS_DATA (sym)->attr.dimension - || CLASS_DATA (sym)->attr.codimension) - && (sym->assoc - || !CLASS_DATA (sym)->attr.allocatable) - && !CLASS_DATA (sym)->attr.class_pointer) - se->expr = build_fold_indirect_ref_loc (input_location, - se->expr); - } + /* Dereference the expression, where needed. */ + se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only, + is_classarray); ref = expr->ref; } diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 7153491a460..c9f4bd29ced 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -174,6 +174,9 @@ gfc_omp_privatize_by_reference (const_tree decl) if (TREE_CODE (type) == POINTER_TYPE) { + while (TREE_CODE (decl) == COMPONENT_REF) + decl = TREE_OPERAND (decl, 1); + /* Array POINTER/ALLOCATABLE have aggregate types, all user variables that have POINTER_TYPE type and aren't scalar pointers, scalar allocatables, Cray pointees or C pointers are supposed to be @@ -2058,6 +2061,91 @@ gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr) static vec *doacross_steps; + +/* Translate an array section or array element. */ + +static void +gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, + tree decl, bool element, gomp_map_kind ptr_kind, + tree node, tree &node2, tree &node3, tree &node4) +{ + gfc_se se; + tree ptr, ptr2; + + gfc_init_se (&se, NULL); + + if (element) + { + gfc_conv_expr_reference (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + ptr = se.expr; + OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gfc_add_block_to_block (block, &se.post); + ptr = fold_convert (build_pointer_type (char_type_node), ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + + if (POINTER_TYPE_P (TREE_TYPE (decl)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) + && ptr_kind == GOMP_MAP_POINTER) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + ptr = fold_convert (sizetype, ptr); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + ptr2 = gfc_conv_descriptor_data_get (decl); + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + if (ptr_kind == GOMP_MAP_ATTACH_DETACH) + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + } + else + { + if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) + ptr2 = build_fold_addr_expr (decl); + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); + ptr2 = decl; + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) = decl; + } + ptr2 = fold_convert (sizetype, ptr2); + OMP_CLAUSE_SIZE (node3) + = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); +} + static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where, bool declare_simd = false) @@ -2389,7 +2477,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) || GFC_DECL_CRAY_POINTEE (decl) || GFC_DESCRIPTOR_TYPE_P - (TREE_TYPE (TREE_TYPE (decl))))) + (TREE_TYPE (TREE_TYPE (decl))) + || n->sym->ts.type == BT_DERIVED)) { tree orig_decl = decl; node4 = build_omp_clause (input_location, @@ -2411,7 +2500,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, decl = build_fold_indirect_ref (decl); } } - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) + && n->u.map_op != OMP_MAP_ATTACH + && n->u.map_op != OMP_MAP_DETACH) { tree type = TREE_TYPE (decl); tree ptr = gfc_conv_descriptor_data_get (decl); @@ -2542,83 +2633,144 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, else OMP_CLAUSE_DECL (node) = decl; } - else + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && n->expr->ref->type == REF_COMPONENT) { - tree ptr, ptr2; + gfc_ref *lastcomp; + + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + lastcomp = ref; + + symbol_attribute sym_attr; + + sym_attr = lastcomp->u.c.component->attr; + gfc_init_se (&se, NULL); - if (n->expr->ref->u.ar.type == AR_ELEMENT) + + if (!sym_attr.dimension + && lastcomp->u.c.component->ts.type != BT_DERIVED) { - gfc_conv_expr_reference (&se, n->expr); + /* Last component is a scalar. */ + gfc_conv_expr (&se, n->expr); gfc_add_block_to_block (block, &se.pre); - ptr = se.expr; - OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + OMP_CLAUSE_DECL (node) = se.expr; + gfc_add_block_to_block (block, &se.post); + goto finalize_map_clause; } - else - { - gfc_conv_expr_descriptor (&se, n->expr); - ptr = gfc_conv_array_data (se.expr); - tree type = TREE_TYPE (se.expr); - gfc_add_block_to_block (block, &se.pre); - OMP_CLAUSE_SIZE (node) - = gfc_full_array_size (block, se.expr, - GFC_TYPE_ARRAY_RANK (type)); - tree elemsz - = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); - } - gfc_add_block_to_block (block, &se.post); - ptr = fold_convert (build_pointer_type (char_type_node), - ptr); - OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); - if (POINTER_TYPE_P (TREE_TYPE (decl)) - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + se.expr = gfc_maybe_dereference_var (n->sym, decl); + + for (gfc_ref *ref = n->expr->ref; + ref && ref != lastcomp->next; + ref = ref->next) { - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node4) = decl; - OMP_CLAUSE_SIZE (node4) = size_int (0); - decl = build_fold_indirect_ref (decl); + if (ref->type == REF_COMPONENT) + { + if (ref->u.c.sym->attr.extension) + conv_parent_component_references (&se, ref); + + gfc_conv_component_ref (&se, ref); + } + else + sorry ("unhandled derived-type component"); } - ptr = fold_convert (sizetype, ptr); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + + tree inner = se.expr; + + /* Last component is a derived type. */ + if (lastcomp->u.c.component->ts.type == BT_DERIVED) { - tree type = TREE_TYPE (decl); - ptr2 = gfc_conv_descriptor_data_get (decl); - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); - OMP_CLAUSE_DECL (node2) = decl; - OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); + if (sym_attr.allocatable || sym_attr.pointer) + { + tree data = inner; + tree size = TYPE_SIZE_UNIT (TREE_TYPE (inner)); + + OMP_CLAUSE_DECL (node) + = build_fold_indirect_ref (data); + OMP_CLAUSE_SIZE (node) = size; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, + GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node2) = data; + OMP_CLAUSE_SIZE (node2) = size_int (0); + } + else + { + OMP_CLAUSE_DECL (node) = decl; + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (decl)); + } } - else + else if (lastcomp->next + && lastcomp->next->type == REF_ARRAY + && lastcomp->next->u.ar.type == AR_FULL) { - if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) - ptr2 = build_fold_addr_expr (decl); - else + /* Just pass the (auto-dereferenced) decl through for + bare attach and detach clauses. */ + if (n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH) { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); - ptr2 = decl; + OMP_CLAUSE_DECL (node) = inner; + OMP_CLAUSE_SIZE (node) = size_zero_node; + goto finalize_map_clause; } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node3) = decl; + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) + { + tree type = TREE_TYPE (inner); + tree ptr = gfc_conv_descriptor_data_get (inner); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = inner; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, + GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (inner); + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + OMP_CLAUSE_SIZE (node3) = size_int (0); + int rank = GFC_TYPE_ARRAY_RANK (type); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, inner, rank); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + else + OMP_CLAUSE_DECL (node) = inner; } - ptr2 = fold_convert (sizetype, ptr2); - OMP_CLAUSE_SIZE (node3) - = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); + else /* An array element or section. */ + { + bool element + = (lastcomp->next + && lastcomp->next->type == REF_ARRAY + && lastcomp->next->u.ar.type == AR_ELEMENT); + + gfc_trans_omp_array_section (block, n, inner, element, + GOMP_MAP_ATTACH_DETACH, + node, node2, node3, node4); + } + } + else /* An array element or array section. */ + { + bool element = n->expr->ref->u.ar.type == AR_ELEMENT; + gfc_trans_omp_array_section (block, n, decl, element, + GOMP_MAP_POINTER, node, node2, + node3, node4); } + + finalize_map_clause: switch (n->u.map_op) { case OMP_MAP_ALLOC: @@ -2627,6 +2779,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_MAP_IF_PRESENT: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT); break; + case OMP_MAP_ATTACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH); + break; case OMP_MAP_TO: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); break; @@ -2651,6 +2806,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_MAP_DELETE: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); break; + case OMP_MAP_DETACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH); + break; case OMP_MAP_FORCE_ALLOC: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); break; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d3c057278f3..4358ba017fd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -565,6 +565,14 @@ tree gfc_conv_expr_present (gfc_symbol *); /* Convert a missing, dummy argument into a null or zero. */ void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int); +/* Lowering of component references. */ +void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref); +void conv_parent_component_references (gfc_se * se, gfc_ref * ref); + +/* Automatically dereference var. */ +tree gfc_maybe_dereference_var (gfc_symbol *, tree, bool desc_only = false, + bool is_classarray = false); + /* Generate code to allocate a string temporary. */ tree gfc_conv_string_tmp (gfc_se *, tree, tree); /* Get the string length variable belonging to an expression. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9cd38fd2a1a..8c2abb64d37 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2019-12-19 Julian Brown + + * gfortran.dg/goacc/derived-types.f90: New test. + * gfortran.dg/goacc/derived-types-2.f90: New test. + * gfortran.dg/goacc/derived-types-3.f90: New test. + * gfortran.dg/goacc/data-clauses.f95: Adjust for expected errors. + * gfortran.dg/goacc/enter-exit-data.f95: Likewise. + 2019-12-19 Julian Brown Cesar Philippidis diff --git a/gcc/testsuite/gfortran.dg/goacc/data-clauses.f95 b/gcc/testsuite/gfortran.dg/goacc/data-clauses.f95 index 30930a0cf1c..cc68e408e1f 100644 --- a/gcc/testsuite/gfortran.dg/goacc/data-clauses.f95 +++ b/gcc/testsuite/gfortran.dg/goacc/data-clauses.f95 @@ -39,9 +39,9 @@ contains !$acc end data - !$acc parallel copy (tip) ! { dg-error "POINTER" } + !$acc parallel copy (tip) !$acc end parallel - !$acc parallel copy (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel copy (tia) !$acc end parallel !$acc parallel deviceptr (i) copy (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -54,9 +54,9 @@ contains !$acc end data - !$acc parallel copyin (tip) ! { dg-error "POINTER" } + !$acc parallel copyin (tip) !$acc end parallel - !$acc parallel copyin (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel copyin (tia) !$acc end parallel !$acc parallel deviceptr (i) copyin (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -71,9 +71,9 @@ contains !$acc end data - !$acc parallel copyout (tip) ! { dg-error "POINTER" } + !$acc parallel copyout (tip) !$acc end parallel - !$acc parallel copyout (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel copyout (tia) !$acc end parallel !$acc parallel deviceptr (i) copyout (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -90,9 +90,9 @@ contains !$acc end data - !$acc parallel create (tip) ! { dg-error "POINTER" } + !$acc parallel create (tip) !$acc end parallel - !$acc parallel create (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel create (tia) !$acc end parallel !$acc parallel deviceptr (i) create (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -134,7 +134,7 @@ contains !$acc parallel present (tip) ! { dg-error "POINTER" } !$acc end parallel - !$acc parallel present (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel present (tia) !$acc end parallel !$acc parallel deviceptr (i) present (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -165,9 +165,9 @@ contains !$acc end parallel - !$acc parallel present_or_copy (tip) ! { dg-error "POINTER" } + !$acc parallel present_or_copy (tip) !$acc end parallel - !$acc parallel present_or_copy (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel present_or_copy (tia) !$acc end parallel !$acc parallel deviceptr (i) present_or_copy (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -190,9 +190,9 @@ contains !$acc end data - !$acc parallel present_or_copyin (tip) ! { dg-error "POINTER" } + !$acc parallel present_or_copyin (tip) !$acc end parallel - !$acc parallel present_or_copyin (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel present_or_copyin (tia) !$acc end parallel !$acc parallel deviceptr (i) present_or_copyin (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -217,9 +217,9 @@ contains !$acc end data - !$acc parallel present_or_copyout (tip) ! { dg-error "POINTER" } + !$acc parallel present_or_copyout (tip) !$acc end parallel - !$acc parallel present_or_copyout (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel present_or_copyout (tia) !$acc end parallel !$acc parallel deviceptr (i) present_or_copyout (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -246,9 +246,9 @@ contains !$acc end data - !$acc parallel present_or_create (tip) ! { dg-error "POINTER" } + !$acc parallel present_or_create (tip) !$acc end parallel - !$acc parallel present_or_create (tia) ! { dg-error "ALLOCATABLE" } + !$acc parallel present_or_create (tia) !$acc end parallel !$acc parallel deviceptr (i) present_or_create (i) ! { dg-error "multiple clauses" } !$acc end parallel @@ -277,4 +277,4 @@ contains !$acc end data end subroutine foo -end module test \ No newline at end of file +end module test diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-types-2.f90 b/gcc/testsuite/gfortran.dg/goacc/derived-types-2.f90 new file mode 100644 index 00000000000..d01583fac89 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/derived-types-2.f90 @@ -0,0 +1,14 @@ +module bar + type :: type1 + real(8), pointer, public :: p(:) => null() + end type + type :: type2 + class(type1), pointer :: p => null() + end type +end module + +subroutine foo (var) + use bar + type(type2), intent(inout) :: var + !$acc enter data create(var%p%p) +end subroutine diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-types-3.f90 b/gcc/testsuite/gfortran.dg/goacc/derived-types-3.f90 new file mode 100644 index 00000000000..9619e2fe1f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/derived-types-3.f90 @@ -0,0 +1,12 @@ +module bar + type :: type1 + integer :: a(5) + integer :: b(5) + end type +end module + +subroutine foo + use bar + type(type1) :: var + !$acc enter data copyin(var%a) copyin(var%a) ! { dg-error ".var\.a. appears more than once in map clauses" } +end subroutine diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 b/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 new file mode 100644 index 00000000000..5fb29816c42 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 @@ -0,0 +1,77 @@ +! Test ACC UPDATE with derived types. + +module dt + integer, parameter :: n = 10 + type inner + integer :: d(n) + end type inner + type dtype + integer(8) :: a, b, c(n) + type(inner) :: in + end type dtype +end module dt + +program derived_acc + use dt + + implicit none + type(dtype):: var + integer i + !$acc declare create(var) + !$acc declare pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc update host(var) + !$acc update host(var%a) + !$acc update device(var) + !$acc update device(var%a) + !$acc update self(var) + !$acc update self(var%a) + + !$acc enter data copyin(var) + !$acc enter data copyin(var%a) + + !$acc exit data copyout(var) + !$acc exit data copyout(var%a) + + !$acc data copy(var) + !$acc end data + + !$acc data copyout(var%a) + !$acc end data + + !$acc parallel loop pcopyout(var) + do i = 1, 10 + end do + !$acc end parallel loop + + !$acc parallel loop copyout(var%a) + do i = 1, 10 + end do + !$acc end parallel loop + + !$acc parallel pcopy(var) + !$acc end parallel + + !$acc parallel pcopy(var%a) + do i = 1, 10 + end do + !$acc end parallel + + !$acc kernels pcopyin(var) + !$acc end kernels + + !$acc kernels pcopy(var%a) + do i = 1, 10 + end do + !$acc end kernels + + !$acc kernels loop pcopyin(var) + do i = 1, 10 + end do + !$acc end kernels loop + + !$acc kernels loop pcopy(var%a) + do i = 1, 10 + end do + !$acc end kernels loop +end program derived_acc diff --git a/gcc/testsuite/gfortran.dg/goacc/enter-exit-data.f95 b/gcc/testsuite/gfortran.dg/goacc/enter-exit-data.f95 index a414df8d439..c2a49796318 100644 --- a/gcc/testsuite/gfortran.dg/goacc/enter-exit-data.f95 +++ b/gcc/testsuite/gfortran.dg/goacc/enter-exit-data.f95 @@ -44,14 +44,14 @@ contains !$acc enter data wait (i, 1) !$acc enter data wait (a) ! { dg-error "INTEGER" } !$acc enter data wait (b(5:6)) ! { dg-error "INTEGER" } - !$acc enter data copyin (tip) ! { dg-error "POINTER" } - !$acc enter data copyin (tia) ! { dg-error "ALLOCATABLE" } - !$acc enter data create (tip) ! { dg-error "POINTER" } - !$acc enter data create (tia) ! { dg-error "ALLOCATABLE" } - !$acc enter data present_or_copyin (tip) ! { dg-error "POINTER" } - !$acc enter data present_or_copyin (tia) ! { dg-error "ALLOCATABLE" } - !$acc enter data present_or_create (tip) ! { dg-error "POINTER" } - !$acc enter data present_or_create (tia) ! { dg-error "ALLOCATABLE" } + !$acc enter data copyin (tip) + !$acc enter data copyin (tia) + !$acc enter data create (tip) + !$acc enter data create (tia) + !$acc enter data present_or_copyin (tip) + !$acc enter data present_or_copyin (tia) + !$acc enter data present_or_create (tip) + !$acc enter data present_or_create (tia) !$acc enter data copyin (i) create (i) ! { dg-error "multiple clauses" } !$acc enter data copyin (i) present_or_copyin (i) ! { dg-error "multiple clauses" } !$acc enter data create (i) present_or_copyin (i) ! { dg-error "multiple clauses" } @@ -79,10 +79,10 @@ contains !$acc exit data wait (i, 1) !$acc exit data wait (a) ! { dg-error "INTEGER" } !$acc exit data wait (b(5:6)) ! { dg-error "INTEGER" } - !$acc exit data copyout (tip) ! { dg-error "POINTER" } - !$acc exit data copyout (tia) ! { dg-error "ALLOCATABLE" } - !$acc exit data delete (tip) ! { dg-error "POINTER" } - !$acc exit data delete (tia) ! { dg-error "ALLOCATABLE" } + !$acc exit data copyout (tip) + !$acc exit data copyout (tia) + !$acc exit data delete (tip) + !$acc exit data delete (tia) !$acc exit data copyout (i) delete (i) ! { dg-error "multiple clauses" } !$acc exit data finalize !$acc exit data finalize copyout (i)