From b46ebd6c7beaf55974973de0f02d39299b733bc9 Mon Sep 17 00:00:00 2001 From: Jakub Jelinek Date: Tue, 24 Jun 2014 09:45:22 +0200 Subject: [PATCH] gimplify.c (gimplify_scan_omp_clauses) : Gimplify OMP_CLAUSE_ALIGNED_ALIGNMENT. (gimplify_adjust_omp_clauses_1): Make sure OMP_CLAUSE_SIZE is non-NULL. (gimplify_adjust_omp_clauses): Likewise. * omp-low.c (lower_rec_simd_input_clauses, lower_rec_input_clauses, expand_omp_simd): Handle non-constant safelen the same as safelen(1). * tree-nested.c (convert_nonlocal_omp_clauses, convert_local_omp_clauses): Handle OMP_CLAUSE_ALIGNED. For OMP_CLAUSE_{MAP,TO,FROM} if not decl use walk_tree. (convert_nonlocal_reference_stmt, convert_local_reference_stmt): Fixup handling of GIMPLE_OMP_TARGET. (convert_tramp_reference_stmt, convert_gimple_call): Handle GIMPLE_OMP_TARGET. gcc/fortran/ * dump-parse-tree.c (show_omp_namelist): Use n->udr->udr instead of n->udr. * f95-lang.c (gfc_init_builtin_functions): Initialize BUILT_IN_ASSUME_ALIGNED. * gfortran.h (gfc_omp_namelist): Change udr field type to struct gfc_omp_namelist_udr. (gfc_omp_namelist_udr): New type. (gfc_get_omp_namelist_udr): Define. (gfc_resolve_code): New prototype. * match.c (gfc_free_omp_namelist): Free name->udr. * module.c (intrinsics): Add INTRINSIC_USER. (fix_mio_expr): Likewise. (mio_expr): Handle INSTRINSIC_USER and non-resolved EXPR_FUNCTION. * openmp.c (gfc_match_omp_clauses): Adjust initialization of n->udr. (gfc_match_omp_declare_reduction): Treat len=: the same as len=*. Set attr.flavor on omp_{out,in,priv,orig} artificial variables. (struct resolve_omp_udr_callback_data): New type. (resolve_omp_udr_callback, resolve_omp_udr_callback2, resolve_omp_udr_clause): New functions. (resolve_omp_clauses): Adjust for n->udr changes, resolve UDR clauses here. (omp_udr_callback): Don't check for implicitly declared functions here. (gfc_resolve_omp_udr): Don't call gfc_resolve. Don't check for implicitly declared subroutines here. * resolve.c (resolve_function): If value.function.isym is non-NULL, consider it already resolved. (resolve_code): Renamed to ... (gfc_resolve_code): ... this. No longer static. (gfc_resolve_blocks, generate_component_assignments, resolve_codes): Adjust callers. * trans-openmp.c (gfc_omp_privatize_by_reference): Don't privatize by reference type (C_PTR) variables. (gfc_omp_finish_clause): Make sure OMP_CLAUSE_SIZE is non-NULL. (gfc_trans_omp_udr_expr): Remove. (gfc_trans_omp_array_reduction_or_udr): Adjust for n->udr changes. Don't call gfc_trans_omp_udr_expr, even for sym->attr.dimension expand it as assignment or subroutine call. Don't initialize value.function.isym. gcc/testsuite/ * gfortran.dg/gomp/udr2.f90 (f7, f9): Add !$omp parallel with reduction clause. * gfortran.dg/gomp/udr4.f90 (f4): Likewise. Remove Label is never defined expected error. * gfortran.dg/gomp/udr8.f90: New test. libgomp/ * testsuite/libgomp.fortran/aligned1.f03: New test. * testsuite/libgomp.fortran/nestedfn5.f90: New test. * testsuite/libgomp.fortran/target7.f90: Surround loop spawning tasks with !$omp parallel !$omp single. * testsuite/libgomp.fortran/target8.f90: New test. * testsuite/libgomp.fortran/udr4.f90 (foo UDR, bar UDR): Adjust not to use trim in the combiner, instead call elemental function. (fn): New elemental function. * testsuite/libgomp.fortran/udr6.f90 (do_add, dp_add, dp_init): Make elemental. * testsuite/libgomp.fortran/udr7.f90 (omp_priv, omp_orig, omp_out, omp_in): Likewise. * testsuite/libgomp.fortran/udr12.f90: New test. * testsuite/libgomp.fortran/udr13.f90: New test. * testsuite/libgomp.fortran/udr14.f90: New test. * testsuite/libgomp.fortran/udr15.f90: New test. From-SVN: r211929 --- gcc/ChangeLog | 20 + gcc/fortran/ChangeLog | 42 +++ gcc/fortran/dump-parse-tree.c | 2 +- gcc/fortran/f95-lang.c | 7 + gcc/fortran/gfortran.h | 12 +- gcc/fortran/match.c | 8 + gcc/fortran/module.c | 41 +- gcc/fortran/openmp.c | 170 +++++++-- gcc/fortran/resolve.c | 32 +- gcc/fortran/trans-openmp.c | 183 +++------ gcc/gimplify.c | 39 +- gcc/omp-low.c | 17 +- gcc/testsuite/ChangeLog | 8 + gcc/testsuite/gfortran.dg/gomp/udr2.f90 | 10 + gcc/testsuite/gfortran.dg/gomp/udr4.f90 | 14 +- gcc/testsuite/gfortran.dg/gomp/udr8.f90 | 351 ++++++++++++++++++ gcc/tree-nested.c | 167 ++++++++- libgomp/ChangeLog | 19 + .../testsuite/libgomp.fortran/aligned1.f03 | 133 +++++++ .../testsuite/libgomp.fortran/nestedfn5.f90 | 96 +++++ libgomp/testsuite/libgomp.fortran/target7.f90 | 4 + libgomp/testsuite/libgomp.fortran/target8.f90 | 33 ++ libgomp/testsuite/libgomp.fortran/udr12.f90 | 76 ++++ libgomp/testsuite/libgomp.fortran/udr13.f90 | 106 ++++++ libgomp/testsuite/libgomp.fortran/udr14.f90 | 50 +++ libgomp/testsuite/libgomp.fortran/udr15.f90 | 64 ++++ libgomp/testsuite/libgomp.fortran/udr4.f90 | 15 +- libgomp/testsuite/libgomp.fortran/udr6.f90 | 11 +- libgomp/testsuite/libgomp.fortran/udr7.f90 | 24 +- 29 files changed, 1513 insertions(+), 241 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/gomp/udr8.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/aligned1.f03 create mode 100644 libgomp/testsuite/libgomp.fortran/nestedfn5.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/target8.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/udr12.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/udr13.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/udr14.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/udr15.f90 diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 567c09a6ff0..d99680af6f2 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,23 @@ +2014-06-24 Jakub Jelinek + + * gimplify.c (gimplify_scan_omp_clauses) : Gimplify OMP_CLAUSE_ALIGNED_ALIGNMENT. + (gimplify_adjust_omp_clauses_1): Make sure OMP_CLAUSE_SIZE is + non-NULL. + (gimplify_adjust_omp_clauses): Likewise. + * omp-low.c (lower_rec_simd_input_clauses, + lower_rec_input_clauses, expand_omp_simd): Handle non-constant + safelen the same as safelen(1). + * tree-nested.c (convert_nonlocal_omp_clauses, + convert_local_omp_clauses): Handle OMP_CLAUSE_ALIGNED. For + OMP_CLAUSE_{MAP,TO,FROM} if not decl use walk_tree. + (convert_nonlocal_reference_stmt, convert_local_reference_stmt): + Fixup handling of GIMPLE_OMP_TARGET. + (convert_tramp_reference_stmt, convert_gimple_call): Handle + GIMPLE_OMP_TARGET. + 2014-06-24 Chung-Lin Tang PR tree-optimization/61554 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 05df7c1dfc0..57c5f8f4544 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,45 @@ +2014-06-24 Jakub Jelinek + + * dump-parse-tree.c (show_omp_namelist): Use n->udr->udr instead + of n->udr. + * f95-lang.c (gfc_init_builtin_functions): Initialize + BUILT_IN_ASSUME_ALIGNED. + * gfortran.h (gfc_omp_namelist): Change udr field type to + struct gfc_omp_namelist_udr. + (gfc_omp_namelist_udr): New type. + (gfc_get_omp_namelist_udr): Define. + (gfc_resolve_code): New prototype. + * match.c (gfc_free_omp_namelist): Free name->udr. + * module.c (intrinsics): Add INTRINSIC_USER. + (fix_mio_expr): Likewise. + (mio_expr): Handle INSTRINSIC_USER and non-resolved EXPR_FUNCTION. + * openmp.c (gfc_match_omp_clauses): Adjust initialization of n->udr. + (gfc_match_omp_declare_reduction): Treat len=: the same as len=*. + Set attr.flavor on omp_{out,in,priv,orig} artificial variables. + (struct resolve_omp_udr_callback_data): New type. + (resolve_omp_udr_callback, resolve_omp_udr_callback2, + resolve_omp_udr_clause): New functions. + (resolve_omp_clauses): Adjust for n->udr changes, resolve UDR clauses + here. + (omp_udr_callback): Don't check for implicitly declared functions + here. + (gfc_resolve_omp_udr): Don't call gfc_resolve. Don't check for + implicitly declared subroutines here. + * resolve.c (resolve_function): If value.function.isym is non-NULL, + consider it already resolved. + (resolve_code): Renamed to ... + (gfc_resolve_code): ... this. No longer static. + (gfc_resolve_blocks, generate_component_assignments, resolve_codes): + Adjust callers. + * trans-openmp.c (gfc_omp_privatize_by_reference): Don't privatize + by reference type (C_PTR) variables. + (gfc_omp_finish_clause): Make sure OMP_CLAUSE_SIZE is non-NULL. + (gfc_trans_omp_udr_expr): Remove. + (gfc_trans_omp_array_reduction_or_udr): Adjust for n->udr changes. + Don't call gfc_trans_omp_udr_expr, even for sym->attr.dimension + expand it as assignment or subroutine call. Don't initialize + value.function.isym. + 2014-06-23 Tobias Burnus * trans-decl.c (gfc_trans_deferred_vars): Fix handling of diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index de942f83819..19f83a9eff8 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1040,7 +1040,7 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break; case OMP_REDUCTION_USER: if (n->udr) - fprintf (dumpfile, "%s:", n->udr->name); + fprintf (dumpfile, "%s:", n->udr->udr->name); break; default: break; } diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index e41f61a9f5d..40f7f181cab 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -1082,6 +1082,13 @@ gfc_init_builtin_functions (void) BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST); TREE_THIS_VOLATILE (builtin_decl_explicit (BUILT_IN_TRAP)) = 1; + ftype = build_varargs_function_type_list (ptr_type_node, const_ptr_type_node, + size_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_assume_aligned", ftype, + BUILT_IN_ASSUME_ALIGNED, + "__builtin_assume_aligned", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__emutls_get_address", builtin_types[BT_FN_PTR_PTR], BUILT_IN_EMUTLS_GET_ADDRESS, diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a11ca3d704f..1c4638f3318 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1111,7 +1111,7 @@ typedef struct gfc_omp_namelist gfc_omp_depend_op depend_op; gfc_omp_map_op map_op; } u; - struct gfc_omp_udr *udr; + struct gfc_omp_namelist_udr *udr; struct gfc_omp_namelist *next; } gfc_omp_namelist; @@ -1237,6 +1237,15 @@ typedef struct gfc_omp_udr gfc_omp_udr; #define gfc_get_omp_udr() XCNEW (gfc_omp_udr) +typedef struct gfc_omp_namelist_udr +{ + struct gfc_omp_udr *udr; + struct gfc_code *combiner; + struct gfc_code *initializer; +} +gfc_omp_namelist_udr; +#define gfc_get_omp_namelist_udr() XCNEW (gfc_omp_namelist_udr) + /* The gfc_st_label structure is a BBT attached to a namespace that records the usage of statement labels within that space. */ @@ -3011,6 +3020,7 @@ void gfc_free_association_list (gfc_association_list *); /* resolve.c */ bool gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); +void gfc_resolve_code (gfc_code *, gfc_namespace *); void gfc_resolve_blocks (gfc_code *, gfc_namespace *); int gfc_impure_variable (gfc_symbol *); int gfc_pure (gfc_symbol *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 41915b4118e..b3f47a8e73e 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -4577,6 +4577,14 @@ gfc_free_omp_namelist (gfc_omp_namelist *name) for (; name; name = n) { gfc_free_expr (name->expr); + if (name->udr) + { + if (name->udr->combiner) + gfc_free_statement (name->udr->combiner); + if (name->udr->initializer) + gfc_free_statement (name->udr->initializer); + free (name->udr); + } n = name->next; free (name); } diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index bdd9961652d..ec67960eae9 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3136,6 +3136,7 @@ static const mstring intrinsics[] = minit ("LE", INTRINSIC_LE_OS), minit ("NOT", INTRINSIC_NOT), minit ("PARENTHESES", INTRINSIC_PARENTHESES), + minit ("USER", INTRINSIC_USER), minit (NULL, -1) }; @@ -3172,7 +3173,8 @@ fix_mio_expr (gfc_expr *e) && !e->symtree->n.sym->attr.dummy) e->symtree = ns_st; } - else if (e->expr_type == EXPR_FUNCTION && e->value.function.name) + else if (e->expr_type == EXPR_FUNCTION + && (e->value.function.name || e->value.function.isym)) { gfc_symbol *sym; @@ -3287,6 +3289,32 @@ mio_expr (gfc_expr **ep) mio_expr (&e->value.op.op2); break; + case INTRINSIC_USER: + /* INTRINSIC_USER should not appear in resolved expressions, + though for UDRs we need to stream unresolved ones. */ + if (iomode == IO_OUTPUT) + write_atom (ATOM_STRING, e->value.op.uop->name); + else + { + char *name = read_string (); + const char *uop_name = find_use_name (name, true); + if (uop_name == NULL) + { + size_t len = strlen (name); + char *name2 = XCNEWVEC (char, len + 2); + memcpy (name2, name, len); + name2[len] = ' '; + name2[len + 1] = '\0'; + free (name); + uop_name = name = name2; + } + e->value.op.uop = gfc_get_uop (uop_name); + free (name); + } + mio_expr (&e->value.op.op1); + mio_expr (&e->value.op.op2); + break; + default: bad_module ("Bad operator"); } @@ -3305,6 +3333,8 @@ mio_expr (gfc_expr **ep) flag = 1; else if (e->ref) flag = 2; + else if (e->value.function.isym == NULL) + flag = 3; else flag = 0; mio_integer (&flag); @@ -3316,6 +3346,8 @@ mio_expr (gfc_expr **ep) case 2: mio_ref_list (&e->ref); break; + case 3: + break; default: write_atom (ATOM_STRING, e->value.function.isym->name); } @@ -3323,7 +3355,10 @@ mio_expr (gfc_expr **ep) else { require_atom (ATOM_STRING); - e->value.function.name = gfc_get_string (atom_string); + if (atom_string[0] == '\0') + e->value.function.name = NULL; + else + e->value.function.name = gfc_get_string (atom_string); free (atom_string); mio_integer (&flag); @@ -3335,6 +3370,8 @@ mio_expr (gfc_expr **ep) case 2: mio_ref_list (&e->ref); break; + case 3: + break; default: require_atom (ATOM_STRING); e->value.function.isym = gfc_find_function (atom_string); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 266ac3d9a9d..68ba70f7ebe 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -486,7 +486,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask, for (n = *head; n; n = n->next) { n->u.reduction_op = rop; - n->udr = udr; + if (udr) + { + n->udr = gfc_get_omp_namelist_udr (); + n->udr->udr = udr; + } } continue; } @@ -1182,6 +1186,9 @@ gfc_match_omp_declare_reduction (void) m = gfc_match_type_spec (&ts); if (m != MATCH_YES) return MATCH_ERROR; + /* Treat len=: the same as len=*. */ + if (ts.type == BT_CHARACTER) + ts.deferred = false; tss.safe_push (ts); while (gfc_match_char (',') == MATCH_YES) @@ -1219,6 +1226,8 @@ gfc_match_omp_declare_reduction (void) omp_in->n.sym->ts = tss[i]; omp_out->n.sym->attr.omp_udr_artificial_var = 1; omp_in->n.sym->attr.omp_udr_artificial_var = 1; + omp_out->n.sym->attr.flavor = FL_VARIABLE; + omp_in->n.sym->attr.flavor = FL_VARIABLE; gfc_commit_symbols (); omp_udr->combiner_ns = combiner_ns; omp_udr->omp_out = omp_out->n.sym; @@ -1249,6 +1258,8 @@ gfc_match_omp_declare_reduction (void) omp_orig->n.sym->ts = tss[i]; omp_priv->n.sym->attr.omp_udr_artificial_var = 1; omp_orig->n.sym->attr.omp_udr_artificial_var = 1; + omp_priv->n.sym->attr.flavor = FL_VARIABLE; + omp_orig->n.sym->attr.flavor = FL_VARIABLE; gfc_commit_symbols (); omp_udr->initializer_ns = initializer_ns; omp_udr->omp_priv = omp_priv->n.sym; @@ -1900,6 +1911,104 @@ gfc_match_omp_end_single (void) } +struct resolve_omp_udr_callback_data +{ + gfc_symbol *sym1, *sym2; +}; + + +static int +resolve_omp_udr_callback (gfc_expr **e, int *, void *data) +{ + struct resolve_omp_udr_callback_data *rcd + = (struct resolve_omp_udr_callback_data *) data; + if ((*e)->expr_type == EXPR_VARIABLE + && ((*e)->symtree->n.sym == rcd->sym1 + || (*e)->symtree->n.sym == rcd->sym2)) + { + gfc_ref *ref = gfc_get_ref (); + ref->type = REF_ARRAY; + ref->u.ar.where = (*e)->where; + ref->u.ar.as = (*e)->symtree->n.sym->as; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = 0; + ref->next = (*e)->ref; + (*e)->ref = ref; + } + return 0; +} + + +static int +resolve_omp_udr_callback2 (gfc_expr **e, int *, void *) +{ + if ((*e)->expr_type == EXPR_FUNCTION + && (*e)->value.function.isym == NULL) + { + gfc_symbol *sym = (*e)->symtree->n.sym; + if (!sym->attr.intrinsic + && sym->attr.if_source == IFSRC_UNKNOWN) + gfc_error ("Implicitly declared function %s used in " + "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where); + } + return 0; +} + + +static gfc_code * +resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, + gfc_symbol *sym1, gfc_symbol *sym2) +{ + gfc_code *copy; + gfc_symbol sym1_copy, sym2_copy; + + if (ns->code->op == EXEC_ASSIGN) + { + copy = gfc_get_code (EXEC_ASSIGN); + copy->expr1 = gfc_copy_expr (ns->code->expr1); + copy->expr2 = gfc_copy_expr (ns->code->expr2); + } + else + { + copy = gfc_get_code (EXEC_CALL); + copy->symtree = ns->code->symtree; + copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual); + } + copy->loc = ns->code->loc; + sym1_copy = *sym1; + sym2_copy = *sym2; + *sym1 = *n->sym; + *sym2 = *n->sym; + sym1->name = sym1_copy.name; + sym2->name = sym2_copy.name; + ns->proc_name = ns->parent->proc_name; + if (n->sym->attr.dimension) + { + struct resolve_omp_udr_callback_data rcd; + rcd.sym1 = sym1; + rcd.sym2 = sym2; + gfc_code_walker (©, gfc_dummy_code_callback, + resolve_omp_udr_callback, &rcd); + } + gfc_resolve_code (copy, gfc_current_ns); + if (copy->op == EXEC_CALL && copy->resolved_isym == NULL) + { + gfc_symbol *sym = copy->resolved_sym; + if (sym + && !sym->attr.intrinsic + && sym->attr.if_source == IFSRC_UNKNOWN) + gfc_error ("Implicitly declared subroutine %s used in " + "!$OMP DECLARE REDUCTION at %L ", sym->name, + ©->loc); + } + gfc_code_walker (©, gfc_dummy_code_callback, + resolve_omp_udr_callback2, NULL); + *sym1 = sym1_copy; + *sym2 = sym2_copy; + return copy; +} + + /* OpenMP directive resolving routines. */ static void @@ -2295,9 +2404,15 @@ resolve_omp_clauses (gfc_code *code, locus *where, const char *udr_name = NULL; if (n->udr) { - udr_name = n->udr->name; - n->udr = gfc_find_omp_udr (NULL, udr_name, - &n->sym->ts); + udr_name = n->udr->udr->name; + n->udr->udr + = gfc_find_omp_udr (NULL, udr_name, + &n->sym->ts); + if (n->udr->udr == NULL) + { + free (n->udr); + n->udr = NULL; + } } if (n->udr == NULL) { @@ -2337,7 +2452,20 @@ resolve_omp_clauses (gfc_code *code, locus *where, gfc_typename (&n->sym->ts), where); } else - n->u.reduction_op = OMP_REDUCTION_USER; + { + gfc_omp_udr *udr = n->udr->udr; + n->u.reduction_op = OMP_REDUCTION_USER; + n->udr->combiner + = resolve_omp_udr_clause (n, udr->combiner_ns, + udr->omp_out, + udr->omp_in); + if (udr->initializer_ns) + n->udr->initializer + = resolve_omp_udr_clause (n, + udr->initializer_ns, + udr->omp_priv, + udr->omp_orig); + } } break; case OMP_LIST_LINEAR: @@ -3317,15 +3445,6 @@ omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, &(*e)->where); } } - else if ((*e)->expr_type == EXPR_FUNCTION - && (*e)->value.function.isym == NULL) - { - gfc_symbol *sym = (*e)->symtree->n.sym; - if (!sym->attr.intrinsic - && sym->attr.if_source == IFSRC_UNKNOWN) - gfc_error ("Implicitly declared function %s used in " - "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where); - } return 0; } @@ -3337,9 +3456,6 @@ gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) gfc_actual_arglist *a; const char *predef_name = NULL; - gfc_resolve (omp_udr->combiner_ns); - if (omp_udr->initializer_ns) - gfc_resolve (omp_udr->initializer_ns); switch (omp_udr->rop) { case OMP_REDUCTION_PLUS: @@ -3394,16 +3510,6 @@ gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) gfc_error ("Subroutine call with alternate returns in combiner " "of !$OMP DECLARE REDUCTION at %L", &omp_udr->combiner_ns->code->loc); - if (omp_udr->combiner_ns->code->resolved_isym == NULL) - { - gfc_symbol *sym = omp_udr->combiner_ns->code->resolved_sym; - if (sym - && !sym->attr.intrinsic - && sym->attr.if_source == IFSRC_UNKNOWN) - gfc_error ("Implicitly declared subroutine %s used in " - "!$OMP DECLARE REDUCTION at %L ", sym->name, - &omp_udr->combiner_ns->code->loc); - } } if (omp_udr->initializer_ns) { @@ -3429,16 +3535,6 @@ gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) gfc_error ("One of actual subroutine arguments in INITIALIZER " "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV " "at %L", &omp_udr->initializer_ns->code->loc); - if (omp_udr->initializer_ns->code->resolved_isym == NULL) - { - gfc_symbol *sym = omp_udr->initializer_ns->code->resolved_sym; - if (sym - && !sym->attr.intrinsic - && sym->attr.if_source == IFSRC_UNKNOWN) - gfc_error ("Implicitly declared subroutine %s used in " - "!$OMP DECLARE REDUCTION at %L ", sym->name, - &omp_udr->initializer_ns->code->loc); - } } } else if (omp_udr->ts.type == BT_DERIVED diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 64f34898770..48b3a40f769 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -40,7 +40,7 @@ typedef enum seq_type seq_type; /* Stack to keep track of the nesting of blocks as we move through the - code. See resolve_branch() and resolve_code(). */ + code. See resolve_branch() and gfc_resolve_code(). */ typedef struct code_stack { @@ -2887,7 +2887,8 @@ resolve_function (gfc_expr *expr) /* See if function is already resolved. */ - if (expr->value.function.name != NULL) + if (expr->value.function.name != NULL + || expr->value.function.isym != NULL) { if (expr->ts.type == BT_UNKNOWN) expr->ts = sym->ts; @@ -4930,7 +4931,7 @@ resolve_variable (gfc_expr *e) if (check_assumed_size_reference (sym, e)) return false; - /* Deal with forward references to entries during resolve_code, to + /* Deal with forward references to entries during gfc_resolve_code, to satisfy, at least partially, 12.5.2.5. */ if (gfc_current_ns->entries && current_entry_id == sym->entry_id @@ -8979,8 +8980,6 @@ resolve_block_construct (gfc_code* code) /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and DO code nodes. */ -static void resolve_code (gfc_code *, gfc_namespace *); - void gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) { @@ -9072,7 +9071,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) gfc_internal_error ("gfc_resolve_blocks(): Bad block type"); } - resolve_code (b->next, ns); + gfc_resolve_code (b->next, ns); } } @@ -9520,7 +9519,7 @@ nonscalar_typebound_assign (gfc_symbol *derived, int depth) The pointer assignments are taken care of by the intrinsic assignment of the structure itself. This function recursively adds defined assignments where required. The recursion is accomplished - by calling resolve_code. + by calling gfc_resolve_code. When the lhs in a defined assignment has intent INOUT, we need a temporary for the lhs. In pseudo-code: @@ -9638,9 +9637,9 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) comp1, comp2, (*code)->loc); /* Convert the assignment if there is a defined assignment for - this type. Otherwise, using the call from resolve_code, + this type. Otherwise, using the call from gfc_resolve_code, recurse into its components. */ - resolve_code (this_code, ns); + gfc_resolve_code (this_code, ns); if (this_code->op == EXEC_ASSIGN_CALL) { @@ -9804,8 +9803,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) /* Given a block of code, recursively resolve everything pointed to by this code block. */ -static void -resolve_code (gfc_code *code, gfc_namespace *ns) +void +gfc_resolve_code (gfc_code *code, gfc_namespace *ns) { int omp_workshare_save; int forall_save, do_concurrent_save; @@ -10091,7 +10090,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_DO_WHILE: if (code->expr1 == NULL) - gfc_internal_error ("resolve_code(): No expression on DO WHILE"); + gfc_internal_error ("gfc_resolve_code(): No expression on " + "DO WHILE"); if (t && (code->expr1->rank != 0 || code->expr1->ts.type != BT_LOGICAL)) @@ -10233,7 +10233,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; default: - gfc_internal_error ("resolve_code(): Bad statement code"); + gfc_internal_error ("gfc_resolve_code(): Bad statement code"); } } @@ -14696,7 +14696,7 @@ gfc_resolve_uops (gfc_symtree *symtree) assign types to all intermediate expressions, make sure that all assignments are to compatible types and figure out which names refer to which functions or subroutines. It doesn't check code - block, which is handled by resolve_code. */ + block, which is handled by gfc_resolve_code. */ static void resolve_types (gfc_namespace *ns) @@ -14785,7 +14785,7 @@ resolve_types (gfc_namespace *ns) } -/* Call resolve_code recursively. */ +/* Call gfc_resolve_code recursively. */ static void resolve_codes (gfc_namespace *ns) @@ -14811,7 +14811,7 @@ resolve_codes (gfc_namespace *ns) old_obstack = labels_obstack; bitmap_obstack_initialize (&labels_obstack); - resolve_code (ns->code, ns); + gfc_resolve_code (ns->code, ns); bitmap_obstack_release (&labels_obstack); labels_obstack = old_obstack; diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 7667f2534f7..458cfffa2d9 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -53,11 +53,13 @@ gfc_omp_privatize_by_reference (const_tree decl) if (TREE_CODE (type) == POINTER_TYPE) { /* Array POINTER/ALLOCATABLE have aggregate types, all user variables - that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P - set are supposed to be privatized by reference. */ + that have POINTER_TYPE type and aren't scalar pointers, scalar + allocatables, Cray pointees or C pointers are supposed to be + privatized by reference. */ if (GFC_DECL_GET_SCALAR_POINTER (decl) || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) - || GFC_DECL_CRAY_POINTEE (decl)) + || GFC_DECL_CRAY_POINTEE (decl) + || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) return false; if (!DECL_ARTIFICIAL (decl) @@ -895,6 +897,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) OMP_CLAUSE_SIZE (c4) = size_int (0); decl = build_fold_indirect_ref (decl); OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_SIZE (c) = NULL_TREE; } if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) { @@ -956,6 +959,10 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) gimplify_and_add (stmt, pre_p); } tree last = c; + if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) + = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); if (c2) { OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); @@ -1182,78 +1189,6 @@ omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, return 0; } -static tree -gfc_trans_omp_udr_expr (gfc_omp_namelist *n, bool is_initializer, - gfc_expr *syme, gfc_expr *outere) -{ - gfc_se symse, outerse; - gfc_ss *symss, *outerss; - gfc_loopinfo loop; - stmtblock_t block, body; - tree tem; - int i; - gfc_namespace *ns = (is_initializer - ? n->udr->initializer_ns : n->udr->combiner_ns); - - syme = gfc_copy_expr (syme); - outere = gfc_copy_expr (outere); - gfc_init_se (&symse, NULL); - gfc_init_se (&outerse, NULL); - gfc_start_block (&block); - gfc_init_loopinfo (&loop); - symss = gfc_walk_expr (syme); - outerss = gfc_walk_expr (outere); - gfc_add_ss_to_loop (&loop, symss); - gfc_add_ss_to_loop (&loop, outerss); - gfc_conv_ss_startstride (&loop); - /* Enable loop reversal. */ - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) - loop.reverse[i] = GFC_ENABLE_REVERSE; - gfc_conv_loop_setup (&loop, &ns->code->loc); - gfc_copy_loopinfo_to_se (&symse, &loop); - gfc_copy_loopinfo_to_se (&outerse, &loop); - symse.ss = symss; - outerse.ss = outerss; - gfc_mark_ss_chain_used (symss, 1); - gfc_mark_ss_chain_used (outerss, 1); - gfc_start_scalarized_body (&loop, &body); - gfc_conv_expr (&symse, syme); - gfc_conv_expr (&outerse, outere); - - if (is_initializer) - { - n->udr->omp_priv->backend_decl = symse.expr; - n->udr->omp_orig->backend_decl = outerse.expr; - } - else - { - n->udr->omp_out->backend_decl = outerse.expr; - n->udr->omp_in->backend_decl = symse.expr; - } - - if (ns->code->op == EXEC_ASSIGN) - tem = gfc_trans_assignment (ns->code->expr1, ns->code->expr2, - false, false); - else - tem = gfc_trans_call (ns->code, false, NULL_TREE, NULL_TREE, false); - gfc_add_expr_to_block (&body, tem); - - gcc_assert (symse.ss == gfc_ss_terminator - && outerse.ss == gfc_ss_terminator); - /* Generate the copying loops. */ - gfc_trans_scalarizing_loops (&loop, &body); - - /* Wrap the whole thing up. */ - gfc_add_block_to_block (&block, &loop.pre); - gfc_add_block_to_block (&block, &loop.post); - - gfc_cleanup_loop (&loop); - gfc_free_expr (syme); - gfc_free_expr (outere); - - return gfc_finish_block (&block); -} - static void gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) { @@ -1268,6 +1203,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) locus old_loc = gfc_current_locus; const char *iname; bool t; + gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; @@ -1292,7 +1228,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) init_val_sym.attr.flavor = FL_VARIABLE; if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); - else if (n->udr->initializer_ns) + else if (udr->initializer_ns) backend_decl = NULL; else switch (sym->ts.type) @@ -1334,34 +1270,18 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) gcc_assert (symtree3 == root3); memset (omp_var_copy, 0, sizeof omp_var_copy); - if (n->udr) + if (udr) { - omp_var_copy[0] = *n->udr->omp_out; - omp_var_copy[1] = *n->udr->omp_in; - if (sym->attr.dimension) + omp_var_copy[0] = *udr->omp_out; + omp_var_copy[1] = *udr->omp_in; + *udr->omp_out = outer_sym; + *udr->omp_in = *sym; + if (udr->initializer_ns) { - n->udr->omp_out->ts = sym->ts; - n->udr->omp_in->ts = sym->ts; - } - else - { - *n->udr->omp_out = outer_sym; - *n->udr->omp_in = *sym; - } - if (n->udr->initializer_ns) - { - omp_var_copy[2] = *n->udr->omp_priv; - omp_var_copy[3] = *n->udr->omp_orig; - if (sym->attr.dimension) - { - n->udr->omp_priv->ts = sym->ts; - n->udr->omp_orig->ts = sym->ts; - } - else - { - *n->udr->omp_priv = *sym; - *n->udr->omp_orig = outer_sym; - } + omp_var_copy[2] = *udr->omp_priv; + omp_var_copy[3] = *udr->omp_orig; + *udr->omp_priv = *sym; + *udr->omp_orig = outer_sym; } } @@ -1394,7 +1314,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) t = gfc_resolve_expr (e2); gcc_assert (t); } - else if (n->udr->initializer_ns == NULL) + else if (udr->initializer_ns == NULL) { gcc_assert (sym->ts.type == BT_DERIVED); e2 = gfc_default_initializer (&sym->ts); @@ -1402,21 +1322,18 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) t = gfc_resolve_expr (e2); gcc_assert (t); } - else if (n->udr->initializer_ns->code->op == EXEC_ASSIGN) + else if (n->udr->initializer->op == EXEC_ASSIGN) { - if (!sym->attr.dimension) - { - e2 = gfc_copy_expr (n->udr->initializer_ns->code->expr2); - t = gfc_resolve_expr (e2); - gcc_assert (t); - } + e2 = gfc_copy_expr (n->udr->initializer->expr2); + t = gfc_resolve_expr (e2); + gcc_assert (t); } - if (n->udr && n->udr->initializer_ns) + if (udr && udr->initializer_ns) { struct omp_udr_find_orig_data cd; - cd.omp_udr = n->udr; + cd.omp_udr = udr; cd.omp_orig_seen = false; - gfc_code_walker (&n->udr->initializer_ns->code, + gfc_code_walker (&n->udr->initializer, gfc_dummy_code_callback, omp_udr_find_orig, &cd); if (cd.omp_orig_seen) OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; @@ -1466,18 +1383,15 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) iname = "ieor"; break; case ERROR_MARK: - if (n->udr->combiner_ns->code->op == EXEC_ASSIGN) + if (n->udr->combiner->op == EXEC_ASSIGN) { - if (!sym->attr.dimension) - { - gfc_free_expr (e3); - e3 = gfc_copy_expr (n->udr->combiner_ns->code->expr1); - e4 = gfc_copy_expr (n->udr->combiner_ns->code->expr2); - t = gfc_resolve_expr (e3); - gcc_assert (t); - t = gfc_resolve_expr (e4); - gcc_assert (t); - } + gfc_free_expr (e3); + e3 = gfc_copy_expr (n->udr->combiner->expr1); + e4 = gfc_copy_expr (n->udr->combiner->expr2); + t = gfc_resolve_expr (e3); + gcc_assert (t); + t = gfc_resolve_expr (e4); + gcc_assert (t); } break; default: @@ -1503,7 +1417,6 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) e4->expr_type = EXPR_FUNCTION; e4->where = where; e4->symtree = symtree4; - e4->value.function.isym = gfc_find_function (iname); e4->value.function.actual = gfc_get_actual_arglist (); e4->value.function.actual->expr = e3; e4->value.function.actual->next = gfc_get_actual_arglist (); @@ -1522,10 +1435,8 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) pushlevel (); if (e2) stmt = gfc_trans_assignment (e1, e2, false, false); - else if (sym->attr.dimension) - stmt = gfc_trans_omp_udr_expr (n, true, e1, e3); else - stmt = gfc_trans_call (n->udr->initializer_ns->code, false, + stmt = gfc_trans_call (n->udr->initializer, false, NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); @@ -1537,10 +1448,8 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) pushlevel (); if (e4) stmt = gfc_trans_assignment (e3, e4, false, true); - else if (sym->attr.dimension) - stmt = gfc_trans_omp_udr_expr (n, false, e1, e3); else - stmt = gfc_trans_call (n->udr->combiner_ns->code, false, + stmt = gfc_trans_call (n->udr->combiner, false, NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); @@ -1566,14 +1475,14 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) if (outer_sym.as) gfc_free_array_spec (outer_sym.as); - if (n->udr) + if (udr) { - *n->udr->omp_out = omp_var_copy[0]; - *n->udr->omp_in = omp_var_copy[1]; - if (n->udr->initializer_ns) + *udr->omp_out = omp_var_copy[0]; + *udr->omp_in = omp_var_copy[1]; + if (udr->initializer_ns) { - *n->udr->omp_priv = omp_var_copy[2]; - *n->udr->omp_orig = omp_var_copy[3]; + *udr->omp_priv = omp_var_copy[2]; + *udr->omp_orig = omp_var_copy[3]; } } } diff --git a/gcc/gimplify.c b/gcc/gimplify.c index 338c5c0ffe6..21ddcf7cf9e 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -5993,14 +5993,21 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, goto do_add; case OMP_CLAUSE_MAP: - if (OMP_CLAUSE_SIZE (c) - && gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, - NULL, is_gimple_val, fb_rvalue) == GS_ERROR) + decl = OMP_CLAUSE_DECL (c); + if (error_operand_p (decl)) + { + remove = true; + break; + } + if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); + if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, + NULL, is_gimple_val, fb_rvalue) == GS_ERROR) { remove = true; break; } - decl = OMP_CLAUSE_DECL (c); if (!DECL_P (decl)) { if (gimplify_expr (&OMP_CLAUSE_DECL (c), pre_p, @@ -6038,15 +6045,17 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, case OMP_CLAUSE_TO: case OMP_CLAUSE_FROM: - if (OMP_CLAUSE_SIZE (c) - && gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, - NULL, is_gimple_val, fb_rvalue) == GS_ERROR) + decl = OMP_CLAUSE_DECL (c); + if (error_operand_p (decl)) { remove = true; break; } - decl = OMP_CLAUSE_DECL (c); - if (error_operand_p (decl)) + if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); + if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, + NULL, is_gimple_val, fb_rvalue) == GS_ERROR) { remove = true; break; @@ -6221,6 +6230,12 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, remove = true; break; } + if (gimplify_expr (&OMP_CLAUSE_ALIGNED_ALIGNMENT (c), pre_p, NULL, + is_gimple_val, fb_rvalue) == GS_ERROR) + { + remove = true; + break; + } if (!is_global_var (decl) && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) omp_add_variable (ctx, decl, GOVD_ALIGNED); @@ -6350,6 +6365,8 @@ gimplify_adjust_omp_clauses_1 (splay_tree_node n, void *data) OMP_CLAUSE_CHAIN (nc) = OMP_CLAUSE_CHAIN (clause); OMP_CLAUSE_CHAIN (clause) = nc; } + else + OMP_CLAUSE_SIZE (clause) = DECL_SIZE_UNIT (decl); } if (code == OMP_CLAUSE_FIRSTPRIVATE && (flags & GOVD_LASTPRIVATE) != 0) { @@ -6518,6 +6535,8 @@ gimplify_adjust_omp_clauses (gimple_seq *pre_p, tree *list_p) OMP_CLAUSE_CHAIN (c) = nc; c = nc; } + else if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl); break; case OMP_CLAUSE_TO: @@ -6542,6 +6561,8 @@ gimplify_adjust_omp_clauses (gimple_seq *pre_p, tree *list_p) OMP_CLAUSE_SIZE (c), true); } } + else if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl); break; case OMP_CLAUSE_REDUCTION: diff --git a/gcc/omp-low.c b/gcc/omp-low.c index a30ce5aa135..adbd0eb6b26 100644 --- a/gcc/omp-low.c +++ b/gcc/omp-low.c @@ -2996,8 +2996,10 @@ lower_rec_simd_input_clauses (tree new_var, omp_context *ctx, int &max_vf, { tree c = find_omp_clause (gimple_omp_for_clauses (ctx->stmt), OMP_CLAUSE_SAFELEN); - if (c - && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c), max_vf) == -1) + if (c && TREE_CODE (OMP_CLAUSE_SAFELEN_EXPR (c)) != INTEGER_CST) + max_vf = 1; + else if (c && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c), + max_vf) == -1) max_vf = tree_to_shwi (OMP_CLAUSE_SAFELEN_EXPR (c)); } if (max_vf > 1) @@ -3745,8 +3747,9 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist, tree c = find_omp_clause (gimple_omp_for_clauses (ctx->stmt), OMP_CLAUSE_SAFELEN); if (c == NULL_TREE - || compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c), - max_vf) == 1) + || (TREE_CODE (OMP_CLAUSE_SAFELEN_EXPR (c)) == INTEGER_CST + && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c), + max_vf) == 1)) { c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_SAFELEN); OMP_CLAUSE_SAFELEN_EXPR (c) = build_int_cst (integer_type_node, @@ -6900,8 +6903,10 @@ expand_omp_simd (struct omp_region *region, struct omp_for_data *fd) else { safelen = OMP_CLAUSE_SAFELEN_EXPR (safelen); - if (!tree_fits_uhwi_p (safelen) - || tree_to_uhwi (safelen) > INT_MAX) + if (TREE_CODE (safelen) != INTEGER_CST) + loop->safelen = 0; + else if (!tree_fits_uhwi_p (safelen) + || tree_to_uhwi (safelen) > INT_MAX) loop->safelen = INT_MAX; else loop->safelen = tree_to_uhwi (safelen); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e797c79ed54..279d4ee29ce 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2014-06-24 Jakub Jelinek + + * gfortran.dg/gomp/udr2.f90 (f7, f9): Add !$omp parallel with + reduction clause. + * gfortran.dg/gomp/udr4.f90 (f4): Likewise. + Remove Label is never defined expected error. + * gfortran.dg/gomp/udr8.f90: New test. + 2014-06-24 Markus Trippelsdorf PR tree-optimization/61554 diff --git a/gcc/testsuite/gfortran.dg/gomp/udr2.f90 b/gcc/testsuite/gfortran.dg/gomp/udr2.f90 index 83fe6bd911c..7038d1869d9 100644 --- a/gcc/testsuite/gfortran.dg/gomp/udr2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/udr2.f90 @@ -11,6 +11,10 @@ subroutine f7 !$omp declare reduction (bar:real:omp_out = omp_out.or.omp_in) ! { dg-error "Operands of logical operator" } !$omp declare reduction (baz:real:omp_out = omp_out + omp_in) !$omp & initializer (a (omp_priv, omp_orig)) ! { dg-error "Unclassifiable OpenMP directive" } + real :: r + r = 0.0 +!$omp parallel reduction (bar:r) +!$omp end parallel end subroutine f7 subroutine f8 interface @@ -29,9 +33,15 @@ subroutine f9 integer :: x = 0 integer :: y = 0 end type dt + integer :: i !$omp declare reduction (foo:integer:dt (omp_out, omp_in)) ! { dg-error "which is not consistent with the CALL" } !$omp declare reduction (bar:integer:omp_out = omp_out + omp_in) & !$omp & initializer (dt (omp_priv, omp_orig)) ! { dg-error "which is not consistent with the CALL" } + i = 0 +!$omp parallel reduction (foo : i) +!$omp end parallel +!$omp parallel reduction (bar : i) +!$omp end parallel end subroutine f9 subroutine f10 integer :: a, b diff --git a/gcc/testsuite/gfortran.dg/gomp/udr4.f90 b/gcc/testsuite/gfortran.dg/gomp/udr4.f90 index 7e86a757214..b48c1090f27 100644 --- a/gcc/testsuite/gfortran.dg/gomp/udr4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/udr4.f90 @@ -23,6 +23,18 @@ subroutine f4 !$omp & initializer(omp_priv = omp_in (omp_orig)) ! { dg-error "Implicitly declared function omp_in used" } !$omp declare reduction (id2:real:omp_out=omp_out+omp_in) & !$omp & initializer(omp_priv = baz (omp_orig)) ! { dg-error "Implicitly declared function baz used" } + integer :: i + real :: r + i = 0 + r = 0 +!$omp parallel reduction (foo: i, r) +!$omp end parallel +!$omp parallel reduction (bar: i, r) +!$omp end parallel +!$omp parallel reduction (id1: i, r) +!$omp end parallel +!$omp parallel reduction (id2: i, r) +!$omp end parallel end subroutine f4 subroutine f5 interface @@ -37,8 +49,6 @@ subroutine f5 !$omp & initializer (f5a (omp_priv, *20, omp_orig)) ! { dg-error "Subroutine call with alternate returns in INITIALIZER clause" } 10 continue 20 continue -! { dg-error "Label\[^\n\r]* is never defined" "" { target *-*-* } 0 } -! { dg-prune-output "" } end subroutine f5 subroutine f6 integer :: a diff --git a/gcc/testsuite/gfortran.dg/gomp/udr8.f90 b/gcc/testsuite/gfortran.dg/gomp/udr8.f90 new file mode 100644 index 00000000000..e040b3d1e8b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/udr8.f90 @@ -0,0 +1,351 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000 -fopenmp" } + +module m +contains + function fn1 (x, y) + integer, intent(in) :: x, y + integer :: fn1 + fn1 = x + 2 * y + end function + subroutine sub1 (x, y) + integer, intent(in) :: y + integer, intent(out) :: x + x = y + end subroutine + function fn2 (x) + integer, intent(in) :: x + integer :: fn2 + fn2 = x + end function + subroutine sub2 (x, y) + integer, intent(in) :: y + integer, intent(inout) :: x + x = x + y + end subroutine + function fn3 (x, y) + integer, intent(in) :: x(:), y(:) + integer :: fn3(lbound(x, 1):ubound(x, 1)) + fn3 = x + 2 * y + end function + subroutine sub3 (x, y) + integer, intent(in) :: y(:) + integer, intent(out) :: x(:) + x = y + end subroutine + function fn4 (x) + integer, intent(in) :: x(:) + integer :: fn4(lbound(x, 1):ubound(x, 1)) + fn4 = x + end function + subroutine sub4 (x, y) + integer, intent(in) :: y(:) + integer, intent(inout) :: x(:) + x = x + y + end subroutine + function fn5 (x, y) + integer, intent(in) :: x(10), y(10) + integer :: fn5(10) + fn5 = x + 2 * y + end function + subroutine sub5 (x, y) + integer, intent(in) :: y(10) + integer, intent(out) :: x(10) + x = y + end subroutine + function fn6 (x) + integer, intent(in) :: x(10) + integer :: fn6(10) + fn6 = x + end function + subroutine sub6 (x, y) + integer, intent(in) :: y(10) + integer, intent(inout) :: x(10) + x = x + y + end subroutine + function fn7 (x, y) + integer, allocatable, intent(in) :: x(:), y(:) + integer, allocatable :: fn7(:) + fn7 = x + 2 * y + end function + subroutine sub7 (x, y) + integer, allocatable, intent(in) :: y(:) + integer, allocatable, intent(out) :: x(:) + x = y + end subroutine + function fn8 (x) + integer, allocatable, intent(in) :: x(:) + integer, allocatable :: fn8(:) + fn8 = x + end function + subroutine sub8 (x, y) + integer, allocatable, intent(in) :: y(:) + integer, allocatable, intent(inout) :: x(:) + x = x + y + end subroutine +end module +subroutine test1 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test1 +subroutine test2 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & +!$omp & initializer (sub1 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn2 (omp_orig)) + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test2 +subroutine test3 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test3 +subroutine test4 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & +!$omp & initializer (sub1 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn2 (omp_orig)) + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test4 +subroutine test5 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & +!$omp & initializer (sub3 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn4 (omp_orig)) + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test5 +subroutine test6 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test6 +subroutine test7 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & +!$omp & initializer (sub3 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn4 (omp_orig)) + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test7 +subroutine test8 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test8 +subroutine test9 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & +!$omp & initializer (sub5 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn6 (omp_orig)) + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test9 +subroutine test10 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test10 +subroutine test11 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & +!$omp & initializer (sub5 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn6 (omp_orig)) + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test11 +subroutine test12 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test12 +subroutine test13 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" } +!$omp & fn5 (omp_out, omp_in)) & ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } +!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } +!$omp initializer (omp_priv = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" } +!$omp & fn6 (omp_orig)) ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } + integer :: a(9) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test13 +subroutine test14 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } +!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } +!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test14 +subroutine test15 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test15 +subroutine test16 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & +!$omp & initializer (sub7 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn8 (omp_orig)) + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test16 +subroutine test17 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test17 diff --git a/gcc/tree-nested.c b/gcc/tree-nested.c index ea2fb722795..5408fba1ff9 100644 --- a/gcc/tree-nested.c +++ b/gcc/tree-nested.c @@ -1151,8 +1151,29 @@ convert_nonlocal_omp_clauses (tree *pclauses, struct walk_stmt_info *wi) goto do_decl_clause; wi->val_only = true; wi->is_lhs = false; - convert_nonlocal_reference_op (&OMP_CLAUSE_DECL (clause), - &dummy, wi); + walk_tree (&OMP_CLAUSE_DECL (clause), convert_nonlocal_reference_op, + wi, NULL); + break; + + case OMP_CLAUSE_ALIGNED: + if (OMP_CLAUSE_ALIGNED_ALIGNMENT (clause)) + { + wi->val_only = true; + wi->is_lhs = false; + convert_nonlocal_reference_op + (&OMP_CLAUSE_ALIGNED_ALIGNMENT (clause), &dummy, wi); + } + /* Like do_decl_clause, but don't add any suppression. */ + decl = OMP_CLAUSE_DECL (clause); + if (TREE_CODE (decl) == VAR_DECL + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + break; + if (decl_function_context (decl) != info->context) + { + OMP_CLAUSE_DECL (clause) = get_nonlocal_debug_decl (info, decl); + if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_PRIVATE) + need_chain = true; + } break; case OMP_CLAUSE_NOWAIT: @@ -1353,10 +1374,42 @@ convert_nonlocal_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p, break; case GIMPLE_OMP_TARGET: + if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION) + { + save_suppress = info->suppress_expansion; + convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt), + wi); + info->suppress_expansion = save_suppress; + walk_body (convert_nonlocal_reference_stmt, + convert_nonlocal_reference_op, info, + gimple_omp_body_ptr (stmt)); + break; + } save_suppress = info->suppress_expansion; - convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi); + if (convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt), + wi)) + { + tree c, decl; + decl = get_chain_decl (info); + c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP); + OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_MAP_KIND (c) = OMP_CLAUSE_MAP_TO; + OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl); + OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt); + gimple_omp_target_set_clauses (stmt, c); + } + + save_local_var_chain = info->new_local_var_chain; + info->new_local_var_chain = NULL; + walk_body (convert_nonlocal_reference_stmt, convert_nonlocal_reference_op, info, gimple_omp_body_ptr (stmt)); + + if (info->new_local_var_chain) + declare_vars (info->new_local_var_chain, + gimple_seq_first_stmt (gimple_omp_body (stmt)), + false); + info->new_local_var_chain = save_local_var_chain; info->suppress_expansion = save_suppress; break; @@ -1728,10 +1781,35 @@ convert_local_omp_clauses (tree *pclauses, struct walk_stmt_info *wi) goto do_decl_clause; wi->val_only = true; wi->is_lhs = false; - convert_local_reference_op (&OMP_CLAUSE_DECL (clause), - &dummy, wi); + walk_tree (&OMP_CLAUSE_DECL (clause), convert_local_reference_op, + wi, NULL); break; + case OMP_CLAUSE_ALIGNED: + if (OMP_CLAUSE_ALIGNED_ALIGNMENT (clause)) + { + wi->val_only = true; + wi->is_lhs = false; + convert_local_reference_op + (&OMP_CLAUSE_ALIGNED_ALIGNMENT (clause), &dummy, wi); + } + /* Like do_decl_clause, but don't add any suppression. */ + decl = OMP_CLAUSE_DECL (clause); + if (TREE_CODE (decl) == VAR_DECL + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + break; + if (decl_function_context (decl) == info->context + && !use_pointer_in_frame (decl)) + { + tree field = lookup_field_for_decl (info, decl, NO_INSERT); + if (field) + { + OMP_CLAUSE_DECL (clause) + = get_local_debug_decl (info, decl, field); + need_frame = true; + } + } + break; case OMP_CLAUSE_NOWAIT: case OMP_CLAUSE_ORDERED: @@ -1862,10 +1940,38 @@ convert_local_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p, break; case GIMPLE_OMP_TARGET: + if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION) + { + save_suppress = info->suppress_expansion; + convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi); + info->suppress_expansion = save_suppress; + walk_body (convert_local_reference_stmt, convert_local_reference_op, + info, gimple_omp_body_ptr (stmt)); + break; + } save_suppress = info->suppress_expansion; - convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi); - walk_body (convert_local_reference_stmt, convert_local_reference_op, - info, gimple_omp_body_ptr (stmt)); + if (convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi)) + { + tree c; + (void) get_frame_type (info); + c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP); + OMP_CLAUSE_DECL (c) = info->frame_decl; + OMP_CLAUSE_MAP_KIND (c) = OMP_CLAUSE_MAP_TOFROM; + OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (info->frame_decl); + OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt); + gimple_omp_target_set_clauses (stmt, c); + } + + save_local_var_chain = info->new_local_var_chain; + info->new_local_var_chain = NULL; + + walk_body (convert_local_reference_stmt, convert_local_reference_op, info, + gimple_omp_body_ptr (stmt)); + + if (info->new_local_var_chain) + declare_vars (info->new_local_var_chain, + gimple_seq_first_stmt (gimple_omp_body (stmt)), false); + info->new_local_var_chain = save_local_var_chain; info->suppress_expansion = save_suppress; break; @@ -2166,6 +2272,13 @@ convert_tramp_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p, break; } + case GIMPLE_OMP_TARGET: + if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION) + { + *handled_ops_p = false; + return NULL_TREE; + } + /* FALLTHRU */ case GIMPLE_OMP_PARALLEL: case GIMPLE_OMP_TASK: { @@ -2186,7 +2299,6 @@ convert_tramp_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p, default: *handled_ops_p = false; return NULL_TREE; - break; } *handled_ops_p = true; @@ -2258,6 +2370,42 @@ convert_gimple_call (gimple_stmt_iterator *gsi, bool *handled_ops_p, info->static_chain_added |= save_static_chain_added; break; + case GIMPLE_OMP_TARGET: + if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION) + { + walk_body (convert_gimple_call, NULL, info, gimple_omp_body_ptr (stmt)); + break; + } + save_static_chain_added = info->static_chain_added; + info->static_chain_added = 0; + walk_body (convert_gimple_call, NULL, info, gimple_omp_body_ptr (stmt)); + for (i = 0; i < 2; i++) + { + tree c, decl; + if ((info->static_chain_added & (1 << i)) == 0) + continue; + decl = i ? get_chain_decl (info) : info->frame_decl; + /* Don't add CHAIN.* or FRAME.* twice. */ + for (c = gimple_omp_target_clauses (stmt); + c; + c = OMP_CLAUSE_CHAIN (c)) + if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_MAP + && OMP_CLAUSE_DECL (c) == decl) + break; + if (c == NULL) + { + c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP); + OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_MAP_KIND (c) + = i ? OMP_CLAUSE_MAP_TO : OMP_CLAUSE_MAP_TOFROM; + OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl); + OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt); + gimple_omp_target_set_clauses (stmt, c); + } + } + info->static_chain_added |= save_static_chain_added; + break; + case GIMPLE_OMP_FOR: walk_body (convert_gimple_call, NULL, info, gimple_omp_for_pre_body_ptr (stmt)); @@ -2265,7 +2413,6 @@ convert_gimple_call (gimple_stmt_iterator *gsi, bool *handled_ops_p, case GIMPLE_OMP_SECTIONS: case GIMPLE_OMP_SECTION: case GIMPLE_OMP_SINGLE: - case GIMPLE_OMP_TARGET: case GIMPLE_OMP_TEAMS: case GIMPLE_OMP_MASTER: case GIMPLE_OMP_TASKGROUP: diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog index e3fdb625ef6..4b63b9a3ce0 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,22 @@ +2014-06-24 Jakub Jelinek + + * testsuite/libgomp.fortran/aligned1.f03: New test. + * testsuite/libgomp.fortran/nestedfn5.f90: New test. + * testsuite/libgomp.fortran/target7.f90: Surround loop spawning + tasks with !$omp parallel !$omp single. + * testsuite/libgomp.fortran/target8.f90: New test. + * testsuite/libgomp.fortran/udr4.f90 (foo UDR, bar UDR): Adjust + not to use trim in the combiner, instead call elemental function. + (fn): New elemental function. + * testsuite/libgomp.fortran/udr6.f90 (do_add, dp_add, dp_init): + Make elemental. + * testsuite/libgomp.fortran/udr7.f90 (omp_priv, omp_orig, omp_out, + omp_in): Likewise. + * testsuite/libgomp.fortran/udr12.f90: New test. + * testsuite/libgomp.fortran/udr13.f90: New test. + * testsuite/libgomp.fortran/udr14.f90: New test. + * testsuite/libgomp.fortran/udr15.f90: New test. + 2014-06-18 Jakub Jelinek * omp_lib.f90.in (openmp_version): Set to 201307. diff --git a/libgomp/testsuite/libgomp.fortran/aligned1.f03 b/libgomp/testsuite/libgomp.fortran/aligned1.f03 new file mode 100644 index 00000000000..67a9ab40423 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/aligned1.f03 @@ -0,0 +1,133 @@ +! { dg-do run } +! { dg-options "-fopenmp -fcray-pointer" } + + use iso_c_binding, only : c_ptr, c_ptrdiff_t, c_loc + interface + subroutine foo (x, y, z, w) + use iso_c_binding, only : c_ptr + real, pointer :: x(:), y(:), w(:) + type(c_ptr) :: z + end subroutine + subroutine bar (x, y, z, w) + use iso_c_binding, only : c_ptr + real, pointer :: x(:), y(:), w(:) + type(c_ptr) :: z + end subroutine + subroutine baz (x, c) + real, pointer :: x(:) + real, allocatable :: c(:) + end subroutine + end interface + type dt + real, allocatable :: a(:) + end type + type (dt) :: b(64) + real, target :: a(4096+63) + real, pointer :: p(:), q(:), r(:), s(:) + real, allocatable :: c(:) + integer(c_ptrdiff_t) :: o + integer :: i + o = 64 - mod (loc (a), 64) + if (o == 64) o = 0 + o = o / sizeof(0.0) + p => a(o + 1:o + 1024) + q => a(o + 1025:o + 2048) + r => a(o + 2049:o + 3072) + s => a(o + 3073:o + 4096) + do i = 1, 1024 + p(i) = i + q(i) = i + r(i) = i + s(i) = i + end do + call foo (p, q, c_loc (r(1)), s) + do i = 1, 1024 + if (p(i) /= i * i + 3 * i + 2) call abort + p(i) = i + end do + call bar (p, q, c_loc (r(1)), s) + do i = 1, 1024 + if (p(i) /= i * i + 3 * i + 2) call abort + end do + ! Attempt to create 64-byte aligned allocatable + do i = 1, 64 + allocate (c(1023 + i)) + if (iand (loc (c(1)), 63) == 0) exit + deallocate (c) + allocate (b(i)%a(1023 + i)) + allocate (c(1023 + i)) + if (iand (loc (c(1)), 63) == 0) exit + deallocate (c) + end do + if (allocated (c)) then + do i = 1, 1024 + c(i) = 2 * i + end do + call baz (p, c) + do i = 1, 1024 + if (p(i) /= i * i + 5 * i + 2) call abort + end do + end if +end +subroutine foo (x, y, z, w) + use iso_c_binding, only : c_ptr, c_f_pointer + real, pointer :: x(:), y(:), w(:), p(:) + type(c_ptr) :: z + integer :: i + real :: pt(1024) + pointer (ip, pt) + ip = loc (w) +!$omp simd aligned (x, y : 64) + do i = 1, 1024 + x(i) = x(i) * y(i) + 2.0 + end do +!$omp simd aligned (x, z : 64) private (p) + do i = 1, 1024 + call c_f_pointer (z, p, shape=[1024]) + x(i) = x(i) + p(i) + end do +!$omp simd aligned (x, ip : 64) + do i = 1, 1024 + x(i) = x(i) + 2 * pt(i) + end do +!$omp end simd +end subroutine +subroutine bar (x, y, z, w) + use iso_c_binding, only : c_ptr, c_f_pointer + real, pointer :: x(:), y(:), w(:), a(:), b(:) + type(c_ptr) :: z, c + integer :: i + real :: pt(1024) + pointer (ip, pt) + ip = loc (w) + a => x + b => y + c = z +!$omp simd aligned (a, b : 64) + do i = 1, 1024 + a(i) = a(i) * b(i) + 2.0 + end do +!$omp simd aligned (a, c : 64) + do i = 1, 1024 + block + real, pointer :: p(:) + call c_f_pointer (c, p, shape=[1024]) + a(i) = a(i) + p(i) + end block + end do +!$omp simd aligned (a, ip : 64) + do i = 1, 1024 + a(i) = a(i) + 2 * pt(i) + end do +!$omp end simd +end subroutine +subroutine baz (x, c) + real, pointer :: x(:) + real, allocatable :: c(:) + integer :: i +!$omp simd aligned (x, c : 64) + do i = 1, 1024 + x(i) = x(i) + c(i) + end do +!$omp end simd +end subroutine baz diff --git a/libgomp/testsuite/libgomp.fortran/nestedfn5.f90 b/libgomp/testsuite/libgomp.fortran/nestedfn5.f90 new file mode 100644 index 00000000000..f67bd47e17d --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/nestedfn5.f90 @@ -0,0 +1,96 @@ +! { dg-do run } + + interface + subroutine bar (q) + integer :: q(19:) + end subroutine + end interface + integer :: q(7:15) + q(:) = 5 + call bar (q) +end +subroutine bar (q) + use iso_c_binding, only: c_ptr, c_loc, c_int + integer :: a, b, c, d(2:3,4:5), q(19:), h, k, m, n, o, p + integer(c_int), target :: e(64) + type (c_ptr) :: f, g(64) + logical :: l + a = 1 + b = 2 + c = 3 + d = 4 + l = .false. + f = c_loc (e) + call foo +contains + subroutine foo + use iso_c_binding, only: c_sizeof +!$omp simd linear(a:2) linear(b:1) + do a = 1, 20, 2 + b = b + 1 + end do +!$omp end simd + if (a /= 21 .or. b /= 12) call abort +!$omp simd aligned(f : c_sizeof (e(1))) + do b = 1, 64 + g(b) = f + end do +!$omp end simd +!$omp parallel +!$omp single +!$omp taskgroup +!$omp task depend(out : a, d(2:2,4:5)) + a = a + 1 + d(2:2,4:5) = d(2:2,4:5) + 1 +!$omp end task +!$omp task depend(in : a, d(2:2,4:5)) + if (a /= 22) call abort + if (any (d(2:2,4:5) /= 5)) call abort +!$omp end task +!$omp end taskgroup +!$omp end single +!$omp end parallel + b = 10 +!$omp target data map (tofrom: a, d(2:3,4:4), q) map (from: l) +!$omp target map (tofrom: b, d(2:3,4:4)) + l = .false. + if (a /= 22 .or. any (q /= 5)) l = .true. + if (lbound (q, 1) /= 19 .or. ubound (q, 1) /= 27) l = .true. + if (d(2,4) /= 5 .or. d(3,4) /= 4) l = .true. + l = l .or. (b /= 10) + a = 6 + b = 11 + q = 8 + d(2:3,4:4) = 9 +!$omp end target +!$omp target update from (a, q, d(2:3,4:4), l) + if (a /= 6 .or. l .or. b /= 11 .or. any (q /= 8)) call abort + if (any (d(2:3,4:4) /= 9) .or. d(2,5) /= 5 .or. d(3,5) /= 4) call abort + a = 12 + b = 13 + q = 14 + d = 15 +!$omp target update to (a, q, d(2:3,4:4)) +!$omp target map (tofrom: b, d(2:3,4:4)) + if (a /= 12 .or. b /= 13 .or. any (q /= 14)) l = .true. + l = l .or. any (d(2:3,4:4) /= 15) +!$omp end target + a = 0 + b = 1 + c = 100 + h = 8 + m = 0 + n = 64 + o = 16 + if (l) call abort +!$omp target teams distribute parallel do simd if (.not.l) device(a) & +!$omp & num_teams(b) dist_schedule(static, c) num_threads (h) & +!$omp & reduction (+: m) safelen (n) schedule(static, o) + do p = 1, 64 + m = m + 1 + end do +!$omp end target teams distribute parallel do simd + if (m /= 64) call abort +!$omp end target data + end subroutine foo +end subroutine bar diff --git a/libgomp/testsuite/libgomp.fortran/target7.f90 b/libgomp/testsuite/libgomp.fortran/target7.f90 index 4af0ee371bd..0c977c44ae1 100644 --- a/libgomp/testsuite/libgomp.fortran/target7.f90 +++ b/libgomp/testsuite/libgomp.fortran/target7.f90 @@ -13,6 +13,8 @@ do i = 1, n a(i) = i end do + !$omp parallel + !$omp single do i = 1, n, c !$omp task shared(a) !$omp target map(a(i:i+c-1)) @@ -23,6 +25,8 @@ !$omp end target !$omp end task end do + !$omp end single + !$omp end parallel do i = 1, n if (a(i) /= i + 1) call abort end do diff --git a/libgomp/testsuite/libgomp.fortran/target8.f90 b/libgomp/testsuite/libgomp.fortran/target8.f90 new file mode 100644 index 00000000000..0564e90e08e --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/target8.f90 @@ -0,0 +1,33 @@ +! { dg-do run } + + integer, parameter :: n = 1000 + integer, parameter :: c = 100 + integer :: i, j + real :: a(n) + do i = 1, n + a(i) = i + end do + !$omp parallel + !$omp single + do i = 1, n, c + !$omp task shared(a) + !$omp target map(a(i:i+c-1)) + !$omp parallel do + do j = i, i + c - 1 + a(j) = foo (a(j)) + end do + !$omp end target + !$omp end task + end do + !$omp end single + !$omp end parallel + do i = 1, n + if (a(i) /= i + 1) call abort + end do +contains + real function foo (x) + !$omp declare target + real, intent(in) :: x + foo = x + 1 + end function foo +end diff --git a/libgomp/testsuite/libgomp.fortran/udr12.f90 b/libgomp/testsuite/libgomp.fortran/udr12.f90 new file mode 100644 index 00000000000..601bca6a93e --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/udr12.f90 @@ -0,0 +1,76 @@ +! { dg-do run } + + interface + elemental subroutine sub1 (x, y) + integer, intent(in) :: y + integer, intent(out) :: x + end subroutine + elemental function fn2 (x) + integer, intent(in) :: x + integer :: fn2 + end function + end interface +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & +!$omp & initializer (sub1 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn2 (omp_orig)) + interface + elemental function fn1 (x, y) + integer, intent(in) :: x, y + integer :: fn1 + end function + elemental subroutine sub2 (x, y) + integer, intent(in) :: y + integer, intent(inout) :: x + end subroutine + end interface + integer :: a(10), b, r + a(:) = 0 + b = 0 + r = 0 +!$omp parallel reduction (foo : a, b) reduction (+: r) + a = a + 2 + b = b + 3 + r = r + 1 +!$omp end parallel + if (any (a /= 2 * r) .or. b /= 3 * r) call abort + a(:) = 0 + b = 0 + r = 0 +!$omp parallel reduction (bar : a, b) reduction (+: r) + a = a + 2 + b = b + 3 + r = r + 1 +!$omp end parallel + if (any (a /= 4 * r) .or. b /= 6 * r) call abort + a(:) = 0 + b = 0 + r = 0 +!$omp parallel reduction (baz : a, b) reduction (+: r) + a = a + 2 + b = b + 3 + r = r + 1 +!$omp end parallel + if (any (a /= 2 * r) .or. b /= 3 * r) call abort +end +elemental function fn1 (x, y) + integer, intent(in) :: x, y + integer :: fn1 + fn1 = x + 2 * y +end function +elemental subroutine sub1 (x, y) + integer, intent(in) :: y + integer, intent(out) :: x + x = 0 +end subroutine +elemental function fn2 (x) + integer, intent(in) :: x + integer :: fn2 + fn2 = x +end function +elemental subroutine sub2 (x, y) + integer, intent(inout) :: x + integer, intent(in) :: y + x = x + y +end subroutine diff --git a/libgomp/testsuite/libgomp.fortran/udr13.f90 b/libgomp/testsuite/libgomp.fortran/udr13.f90 new file mode 100644 index 00000000000..0da1da4bc65 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/udr13.f90 @@ -0,0 +1,106 @@ +! { dg-do run } + + interface + subroutine sub1 (x, y) + integer, intent(in) :: y(:) + integer, intent(out) :: x(:) + end subroutine + function fn2 (x, m1, m2, n1, n2) + integer, intent(in) :: x(:,:), m1, m2, n1, n2 + integer :: fn2(m1:m2,n1:n2) + end function + subroutine sub3 (x, y) + integer, allocatable, intent(in) :: y(:,:) + integer, allocatable, intent(inout) :: x(:,:) + end subroutine + end interface +!$omp declare reduction (foo : integer : sub3 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn3 (omp_orig)) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in, & +!$omp & lbound (omp_out, 1), ubound (omp_out, 1))) & +!$omp & initializer (sub1 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn2 (omp_orig, lbound (omp_priv, 1), & +!$omp ubound (omp_priv, 1), lbound (omp_priv, 2), ubound (omp_priv, 2))) + interface + function fn1 (x, y, m1, m2) + integer, intent(in) :: x(:), y(:), m1, m2 + integer :: fn1(m1:m2) + end function + subroutine sub2 (x, y) + integer, intent(in) :: y(:,:) + integer, intent(inout) :: x(:,:) + end subroutine + function fn3 (x) + integer, allocatable, intent(in) :: x(:,:) + integer, allocatable :: fn3(:,:) + end function + end interface + integer :: a(10), b(3:5,7:9), r + integer, allocatable :: c(:,:) + a(:) = 0 + r = 0 +!$omp parallel reduction (bar : a) reduction (+: r) + if (lbound (a, 1) /= 1 .or. ubound (a, 1) /= 10) call abort + a = a + 2 + r = r + 1 +!$omp end parallel + if (any (a /= 4 * r) ) call abort + b(:,:) = 0 + allocate (c (4:6,8:10)) + c(:,:) = 0 + r = 0 +!$omp parallel reduction (baz : b, c) reduction (+: r) + if (lbound (b, 1) /= 3 .or. ubound (b, 1) /= 5) call abort + if (lbound (b, 2) /= 7 .or. ubound (b, 2) /= 9) call abort + if (.not. allocated (c)) call abort + if (lbound (c, 1) /= 4 .or. ubound (c, 1) /= 6) call abort + if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 10) call abort + b = b + 3 + c = c + 4 + r = r + 1 +!$omp end parallel + if (any (b /= 3 * r) .or. any (c /= 4 * r)) call abort + deallocate (c) + allocate (c (0:1,7:11)) + c(:,:) = 0 + r = 0 +!$omp parallel reduction (foo : c) reduction (+: r) + if (.not. allocated (c)) call abort + if (lbound (c, 1) /= 0 .or. ubound (c, 1) /= 1) call abort + if (lbound (c, 2) /= 7 .or. ubound (c, 2) /= 11) call abort + c = c + 5 + r = r + 1 +!$omp end parallel + if (any (c /= 10 * r)) call abort +end +function fn1 (x, y, m1, m2) + integer, intent(in) :: x(:), y(:), m1, m2 + integer :: fn1(m1:m2) + fn1 = x + 2 * y +end function +subroutine sub1 (x, y) + integer, intent(in) :: y(:) + integer, intent(out) :: x(:) + x = 0 +end subroutine +function fn2 (x, m1, m2, n1, n2) + integer, intent(in) :: x(:,:), m1, m2, n1, n2 + integer :: fn2(m1:m2,n1:n2) + fn2 = x +end function +subroutine sub2 (x, y) + integer, intent(inout) :: x(:,:) + integer, intent(in) :: y(:,:) + x = x + y +end subroutine +function fn3 (x) + integer, allocatable, intent(in) :: x(:,:) + integer, allocatable :: fn3(:,:) + fn3 = x +end function +subroutine sub3 (x, y) + integer, allocatable, intent(inout) :: x(:,:) + integer, allocatable, intent(in) :: y(:,:) + x = x + 2 * y +end subroutine diff --git a/libgomp/testsuite/libgomp.fortran/udr14.f90 b/libgomp/testsuite/libgomp.fortran/udr14.f90 new file mode 100644 index 00000000000..d6974585578 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/udr14.f90 @@ -0,0 +1,50 @@ +! { dg-do run } + + type dt + integer :: g + integer, allocatable :: h(:) + end type +!$omp declare reduction (baz : dt : bar (omp_out, omp_in)) & +!$omp & initializer (foo (omp_priv, omp_orig)) + integer :: r + type (dt), allocatable :: a(:) + allocate (a(7:8)) + a(:)%g = 0 + a(7)%h = (/ 0, 0, 0 /) + r = 0 +!$omp parallel reduction(+:r) reduction (baz:a) + if (.not.allocated (a)) call abort + if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort + if (.not.allocated (a(7)%h)) call abort + if (allocated (a(8)%h)) call abort + if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort + a(:)%g = a(:)%g + 2 + a(7)%h = a(7)%h + 3 + r = r + 1 +!$omp end parallel + if (.not.allocated (a)) call abort + if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort + if (.not.allocated (a(7)%h)) call abort + if (allocated (a(8)%h)) call abort + if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort + if (any (a(:)%g /= 2 * r) .or. any (a(7)%h(:) /= 3 * r)) call abort +contains + subroutine foo (x, y) + type (dt), allocatable :: x(:), y(:) + if (allocated (x) .neqv. allocated (y)) call abort + if (lbound (x, 1) /= lbound (y, 1)) call abort + if (ubound (x, 1) /= ubound (y, 1)) call abort + if (allocated (x(7)%h) .neqv. allocated (y(7)%h)) call abort + if (allocated (x(8)%h) .neqv. allocated (y(8)%h)) call abort + if (lbound (x(7)%h, 1) /= lbound (y(7)%h, 1)) call abort + if (ubound (x(7)%h, 1) /= ubound (y(7)%h, 1)) call abort + x(7)%g = 0 + x(7)%h = 0 + x(8)%g = 0 + end subroutine + subroutine bar (x, y) + type (dt), allocatable :: x(:), y(:) + x(:)%g = x(:)%g + y(:)%g + x(7)%h(:) = x(7)%h(:) + y(7)%h(:) + end subroutine +end diff --git a/libgomp/testsuite/libgomp.fortran/udr15.f90 b/libgomp/testsuite/libgomp.fortran/udr15.f90 new file mode 100644 index 00000000000..2d1169568dd --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/udr15.f90 @@ -0,0 +1,64 @@ +! { dg-do run } + +module udr15m1 + integer, parameter :: a = 6 + integer :: b +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) +!$omp declare reduction (.add. : integer : & +!$omp & omp_out = omp_out .add. f3 (omp_in, -4)) & +!$omp & initializer (s1 (omp_priv, omp_orig)) + interface operator (.add.) + module procedure f1 + end interface +contains + integer function f1 (x, y) + integer, intent (in) :: x, y + f1 = x + y + end function f1 + integer function f3 (x, y) + integer, intent (in) :: x, y + f3 = iand (x, y) + end function f3 + subroutine s1 (x, y) + integer, intent (in) :: y + integer, intent (out) :: x + x = 3 + end subroutine s1 +end module udr15m1 +module udr15m2 + use udr15m1, f4 => f1, f5 => f3, s2 => s1, operator (.addtwo.) => operator (.add.) + type dt + integer :: x + end type +!$omp declare reduction (+ : dt : omp_out = f6 (omp_out + omp_in)) & +!$omp & initializer (s3 (omp_priv)) + interface operator (+) + module procedure f2 + end interface +contains + type(dt) function f2 (x, y) + type(dt), intent (in) :: x, y + f2%x = x%x + y%x + end function f2 + type(dt) function f6 (x) + type(dt), intent (in) :: x + f6%x = x%x + end function f6 + subroutine s3 (x) + type(dt), intent (out) :: x + x = dt(0) + end subroutine +end module udr15m2 + use udr15m2, operator (.addthree.) => operator (.addtwo.), & + f7 => f4, f8 => f6, s4 => s3 + integer :: i, j + type(dt) :: d + j = 3 + d%x = 0 +!$omp parallel do reduction (.addthree.: j) reduction (+ : d) + do i = 1, 100 + j = j.addthree.iand (i, -4) + d = d + dt(i) + end do + if (d%x /= 5050 .or. j /= 4903) call abort +end diff --git a/libgomp/testsuite/libgomp.fortran/udr4.f90 b/libgomp/testsuite/libgomp.fortran/udr4.f90 index 50f69005e3e..89365476af7 100644 --- a/libgomp/testsuite/libgomp.fortran/udr4.f90 +++ b/libgomp/testsuite/libgomp.fortran/udr4.f90 @@ -1,9 +1,9 @@ ! { dg-do run } !$omp declare reduction (foo : character(kind=1, len=*) & -!$omp & : omp_out = trim(omp_out) // omp_in) initializer (omp_priv = '') +!$omp & : omp_out = fn (omp_out, omp_in)) initializer (omp_priv = '') !$omp declare reduction (bar : character(kind=1, len=:) & -!$omp & : omp_out = trim(omp_in) // omp_out) initializer (omp_priv = '') +!$omp & : omp_out = fn (omp_in, omp_out)) initializer (omp_priv = '') !$omp declare reduction (baz : character(kind=1, len=1) & !$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) & !$omp & - ichar ('0'))) initializer (omp_priv = '0') @@ -11,6 +11,12 @@ !$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) & !$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + & !$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00') + interface + elemental function fn (x, y) + character (len=64), intent (in) :: x, y + character (len=64) :: fn + end function + end interface character(kind=1, len=64) :: c(-3:-2,1:1,7:8), d(2:3,-7:-5) character(kind = 1, len=1) :: e(2:4) character(kind = 1, len=1+1) :: f(8:10,9:10) @@ -37,3 +43,8 @@ if (any (f(:,:)(1:1).ne.char (ichar ('0') + 32))) call abort if (any (f(:,:)(2:2).ne.char (ichar ('0') + 64))) call abort end +elemental function fn (x, y) + character (len=64), intent (in) :: x, y + character (len=64) :: fn + fn = trim(x) // y +end function diff --git a/libgomp/testsuite/libgomp.fortran/udr6.f90 b/libgomp/testsuite/libgomp.fortran/udr6.f90 index 7fb3ee5122e..20736fb79db 100644 --- a/libgomp/testsuite/libgomp.fortran/udr6.f90 +++ b/libgomp/testsuite/libgomp.fortran/udr6.f90 @@ -8,17 +8,18 @@ module m real :: r = 0.0 end type contains - function do_add(x, y) + elemental function do_add(x, y) type (dt), intent (in) :: x, y type (dt) :: do_add do_add%r = x%r + y%r end function - subroutine dp_add(x, y) - double precision :: x, y + elemental subroutine dp_add(x, y) + double precision, intent (inout) :: x + double precision, intent (in) :: y x = x + y end subroutine - subroutine dp_init(x) - double precision :: x + elemental subroutine dp_init(x) + double precision, intent (out) :: x x = 0.0 end subroutine end module diff --git a/libgomp/testsuite/libgomp.fortran/udr7.f90 b/libgomp/testsuite/libgomp.fortran/udr7.f90 index 5253dd7d086..42be00c3a16 100644 --- a/libgomp/testsuite/libgomp.fortran/udr7.f90 +++ b/libgomp/testsuite/libgomp.fortran/udr7.f90 @@ -3,17 +3,17 @@ program udr7 implicit none interface - subroutine omp_priv (x, y, z) + elemental subroutine omp_priv (x, y, z) real, intent (in) :: x real, intent (inout) :: y - real, intent (in) :: z(:) + real, intent (in) :: z end subroutine omp_priv - real function omp_orig (x) + elemental real function omp_orig (x) real, intent (in) :: x end function omp_orig end interface !$omp declare reduction (omp_priv : real : & -!$omp & omp_priv (omp_orig (omp_in), omp_out, (/ 1.0, 2.0, 3.0 /))) & +!$omp & omp_priv (omp_orig (omp_in), omp_out, 1.0)) & !$omp & initializer (omp_out (omp_priv, omp_in (omp_orig))) real :: x (2:4, 1:1, -2:0) integer :: i @@ -24,25 +24,23 @@ program udr7 end do if (any (x /= 2080.0)) call abort contains - subroutine omp_out (x, y) + elemental subroutine omp_out (x, y) real, intent (out) :: x real, intent (in) :: y - if (y /= 4.0) call abort - x = 0.0 + x = y - 4.0 end subroutine omp_out - real function omp_in (x) + elemental real function omp_in (x) real, intent (in) :: x omp_in = x + 4.0 end function omp_in end program udr7 -subroutine omp_priv (x, y, z) +elemental subroutine omp_priv (x, y, z) real, intent (in) :: x real, intent (inout) :: y - real, intent (in) :: z(:) - if (any (z .ne. (/ 1.0, 2.0, 3.0 /))) call abort - y = y + (x - 4.0) + real, intent (in) :: z + y = y + (x - 4.0) + (z - 1.0) end subroutine omp_priv -real function omp_orig (x) +elemental real function omp_orig (x) real, intent (in) :: x omp_orig = x + 4.0 end function omp_orig