procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

OpenACC 2.6 deep copy: Fortran front-end parts

Browse source 
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
This commit is contained in:
Julian Brown 2019-12-20 01:20:42 +00:00 • committed by Julian Brown
parent 519d7496be
commit 549188ea10
12 changed files with 616 additions and 238 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
gcc/fortran/ChangeLog
View file

@ -1,3 +1,34 @@
2019-12-19 Julian Brown <julian@codesourcery.com>
* 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 <mark.eggleston@codethink.com>
PR fortran/92896

2
gcc/fortran/gfortran.h
View file

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

166
gcc/fortran/openmp.c
View file

@ -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])
{

184
gcc/fortran/trans-expr.c
View file

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

292
gcc/fortran/trans-openmp.c
View file

@ -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<tree, va_heap, vl_embed> *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_init_se (&se, NULL);
if (n->expr->ref->u.ar.type == AR_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);
gfc_ref *lastcomp;
if (POINTER_TYPE_P (TREE_TYPE (decl))
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
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 (!sym_attr.dimension
&& lastcomp->u.c.component->ts.type != BT_DERIVED)
{
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);
/* Last component is a scalar. */
gfc_conv_expr (&se, n->expr);
gfc_add_block_to_block (block, &se.pre);
OMP_CLAUSE_DECL (node) = se.expr;
gfc_add_block_to_block (block, &se.post);
goto finalize_map_clause;
}
ptr = fold_convert (sizetype, ptr);
if (GFC_DESCRIPTOR_TYPE_P (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)
{
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 (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");
}
else
tree inner = se.expr;
/* Last component is a derived type. */
if (lastcomp->u.c.component->ts.type == BT_DERIVED)
{
if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
ptr2 = build_fold_addr_expr (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
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
ptr2 = decl;
OMP_CLAUSE_DECL (node) = decl;
OMP_CLAUSE_SIZE (node)
= TYPE_SIZE_UNIT (TREE_TYPE (decl));
}
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
OMP_CLAUSE_DECL (node3) = decl;
}
ptr2 = fold_convert (sizetype, ptr2);
OMP_CLAUSE_SIZE (node3)
= fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
else if (lastcomp->next
&& lastcomp->next->type == REF_ARRAY
&& lastcomp->next->u.ar.type == AR_FULL)
{
/* 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)
{
OMP_CLAUSE_DECL (node) = inner;
OMP_CLAUSE_SIZE (node) = size_zero_node;
goto finalize_map_clause;
}
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;
}
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;

8
gcc/fortran/trans.h
View file

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

8
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,11 @@
2019-12-19 Julian Brown <julian@codesourcery.com>
* 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 <julian@codesourcery.com>
Cesar Philippidis <cesar@codesourcery.com>

36
gcc/testsuite/gfortran.dg/goacc/data-clauses.f95
View file

@ -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
end module test

14
gcc/testsuite/gfortran.dg/goacc/derived-types-2.f90 Normal file
View file

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

12
gcc/testsuite/gfortran.dg/goacc/derived-types-3.f90 Normal file
View file

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

77
gcc/testsuite/gfortran.dg/goacc/derived-types.f90 Normal file
View file

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

24
gcc/testsuite/gfortran.dg/goacc/enter-exit-data.f95
View file

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