Fortran/openmp: Add support for 2 argument num_teams clause
Fortran part to commit r12-5146-g48d7327f2aaf65
gcc/fortran/ChangeLog:
* gfortran.h (struct gfc_omp_clauses): Rename num_teams to
num_teams_upper, add num_teams_upper.
* dump-parse-tree.c (show_omp_clauses): Update to handle
lower-bound num_teams clause.
* frontend-passes.c (gfc_code_walker): Likewise
* openmp.c (gfc_free_omp_clauses, gfc_match_omp_clauses,
resolve_omp_clauses): Likewise.
* trans-openmp.c (gfc_trans_omp_clauses, gfc_split_omp_clauses,
gfc_trans_omp_target): Likewise.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/teams-1.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/num-teams-1.f90: New test.
* gfortran.dg/gomp/num-teams-2.f90: New test.
gcc/fortran/dump-parse-tree.c | 9 ++++-
gcc/fortran/frontend-passes.c | 3 +-
gcc/fortran/gfortran.h | 3 +-
gcc/fortran/openmp.c | 32 +++++++++++++---
gcc/fortran/trans-openmp.c | 35 ++++++++++++-----
gcc/testsuite/gfortran.dg/gomp/num-teams-1.f90 | 53 ++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/gomp/num-teams-2.f90 | 37 ++++++++++++++++++
libgomp/testsuite/libgomp.fortran/teams-1.f90 | 22 +++++++++++
8 files changed, 175 insertions(+), 19 deletions(-)
@@ -1741,10 +1741,15 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
}
fprintf (dumpfile, " BIND(%s)", type);
}
- if (omp_clauses->num_teams)
+ if (omp_clauses->num_teams_upper)
{
fputs (" NUM_TEAMS(", dumpfile);
- show_expr (omp_clauses->num_teams);
+ if (omp_clauses->num_teams_lower)
+ {
+ show_expr (omp_clauses->num_teams_lower);
+ fputc (':', dumpfile);
+ }
+ show_expr (omp_clauses->num_teams_upper);
fputc (')', dumpfile);
}
if (omp_clauses->device)
@@ -5634,7 +5634,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
- WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_teams_lower);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_teams_upper);
WALK_SUBEXPR (co->ext.omp_clauses->device);
WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
@@ -1502,7 +1502,8 @@ typedef struct gfc_omp_clauses
struct gfc_expr *chunk_size;
struct gfc_expr *safelen_expr;
struct gfc_expr *simdlen_expr;
- struct gfc_expr *num_teams;
+ struct gfc_expr *num_teams_lower;
+ struct gfc_expr *num_teams_upper;
struct gfc_expr *device;
struct gfc_expr *thread_limit;
struct gfc_expr *grainsize;
@@ -85,7 +85,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
gfc_free_expr (c->chunk_size);
gfc_free_expr (c->safelen_expr);
gfc_free_expr (c->simdlen_expr);
- gfc_free_expr (c->num_teams);
+ gfc_free_expr (c->num_teams_lower);
+ gfc_free_expr (c->num_teams_upper);
gfc_free_expr (c->device);
gfc_free_expr (c->thread_limit);
gfc_free_expr (c->dist_chunk_size);
@@ -2420,11 +2421,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
continue;
}
if ((mask & OMP_CLAUSE_NUM_TEAMS)
- && (m = gfc_match_dupl_check (!c->num_teams, "num_teams", true,
- &c->num_teams)) != MATCH_NO)
+ && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
+ true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
+ if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
+ goto error;
+ if (gfc_peek_ascii_char () == ':')
+ {
+ c->num_teams_lower = c->num_teams_upper;
+ c->num_teams_upper = NULL;
+ if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
+ goto error;
+ }
+ if (gfc_match (") ") != MATCH_YES)
+ goto error;
continue;
}
if ((mask & OMP_CLAUSE_NUM_THREADS)
@@ -7293,8 +7305,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
if (omp_clauses->simdlen_expr)
resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
- if (omp_clauses->num_teams)
- resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS");
+ if (omp_clauses->num_teams_lower)
+ resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
+ if (omp_clauses->num_teams_upper)
+ resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
+ if (omp_clauses->num_teams_lower
+ && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
+ && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
+ && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
+ omp_clauses->num_teams_upper->value.integer) > 0)
+ gfc_warning (0, "NUM_TEAMS lower bound at %L larger than upper bound at %L",
+ &omp_clauses->num_teams_lower->where,
+ &omp_clauses->num_teams_upper->where);
if (omp_clauses->device)
resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
if (omp_clauses->filter)
@@ -3927,18 +3927,27 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
}
- if (clauses->num_teams)
+ if (clauses->num_teams_upper)
{
- tree num_teams;
+ tree num_teams_lower = NULL_TREE, num_teams_upper;
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, clauses->num_teams);
+ gfc_conv_expr (&se, clauses->num_teams_upper);
gfc_add_block_to_block (block, &se.pre);
- num_teams = gfc_evaluate_now (se.expr, block);
+ num_teams_upper = gfc_evaluate_now (se.expr, block);
gfc_add_block_to_block (block, &se.post);
+ if (clauses->num_teams_lower)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->num_teams_lower);
+ gfc_add_block_to_block (block, &se.pre);
+ num_teams_lower = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+ }
c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS);
- OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams;
+ OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower;
+ OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper;
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
@@ -5873,8 +5882,10 @@ gfc_split_omp_clauses (gfc_code *code,
if (mask & GFC_OMP_MASK_TEAMS)
{
/* First the clauses that are unique to some constructs. */
- clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
- = code->ext.omp_clauses->num_teams;
+ clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower
+ = code->ext.omp_clauses->num_teams_lower;
+ clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
+ = code->ext.omp_clauses->num_teams_upper;
clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit
= code->ext.omp_clauses->thread_limit;
/* Shared and default clauses are allowed on parallel, teams
@@ -6649,7 +6660,7 @@ gfc_trans_omp_target (gfc_code *code)
break;
default:
if (flag_openmp
- && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams
+ && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper
|| clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit))
{
gfc_omp_clauses clausesb;
@@ -6658,9 +6669,13 @@ gfc_trans_omp_target (gfc_code *code)
thread_limit clauses are evaluated before entering the
target construct. */
memset (&clausesb, '\0', sizeof (clausesb));
- clausesb.num_teams = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams;
+ clausesb.num_teams_lower
+ = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower;
+ clausesb.num_teams_upper
+ = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper;
clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit;
- clausesa[GFC_OMP_SPLIT_TEAMS].num_teams = NULL;
+ clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL;
+ clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL;
clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL;
teams_clauses
= gfc_trans_omp_clauses (&block, &clausesb, code->loc);
new file mode 100644
@@ -0,0 +1,53 @@
+module m
+ implicit none (type, external)
+
+ interface
+ integer function fn(i); integer :: i; end
+ end interface
+
+contains
+
+subroutine foo
+ !$omp teams num_teams (4 : 6)
+ !$omp end teams
+
+ !$omp teams num_teams (7)
+ !$omp end teams
+end
+
+subroutine bar
+ !$omp target teams num_teams (5 : 19)
+ !$omp end target teams
+
+ !$omp target teams num_teams (21)
+ !$omp end target teams
+end
+
+subroutine baz
+ !$omp teams num_teams (fn (1) : fn (2))
+ !$omp end teams
+
+ !$omp teams num_teams (fn (3))
+ !$omp end teams
+end
+
+subroutine qux
+ !$omp target teams num_teams (fn (4) : fn (5))
+ !$omp end target teams
+
+ !$omp target teams num_teams (fn (6))
+ !$omp end target teams
+end
+
+subroutine corge
+ !$omp target
+ !$omp teams num_teams (fn (7) : fn (8))
+ !$omp end teams
+ !$omp end target
+
+ !$omp target
+ !$omp teams num_teams (fn (9))
+ !$omp end teams
+ !$omp end target
+end
+end module m
new file mode 100644
@@ -0,0 +1,37 @@
+module m
+ implicit none (type, external)
+
+contains
+
+subroutine foo (i)
+ integer :: i
+
+ !$omp teams num_teams (6 : 4) ! { dg-warning "NUM_TEAMS lower bound at .1. larger than upper bound at .2." }
+ !$omp end teams
+
+ !$omp teams num_teams (-7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" }
+ !$omp end teams
+
+ !$omp teams num_teams (i : -7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" }
+ !$omp end teams
+
+ !$omp teams num_teams (-7 : 8) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" }
+ !$omp end teams
+end
+
+subroutine bar (i)
+ integer :: i
+
+ !$omp target teams num_teams (6 : 4) ! { dg-warning "NUM_TEAMS lower bound at .1. larger than upper bound at .2." }
+ !$omp end target teams
+
+ !$omp target teams num_teams (-7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" }
+ !$omp end target teams
+
+ !$omp target teams num_teams (i : -7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" }
+ !$omp end target teams
+
+ !$omp target teams num_teams (-7 : 8) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" }
+ !$omp end target teams
+end
+end module
new file mode 100644
@@ -0,0 +1,22 @@
+program main
+ use omp_lib
+ implicit none (type, external)
+ integer :: i
+
+ !$omp teams num_teams (5)
+ if (omp_get_num_teams () /= 5) stop 1
+ !$omp distribute dist_schedule(static,1)
+ do i = 0, 4
+ if (omp_get_team_num () /= i) stop 2
+ end do
+ !$omp end teams
+
+ !$omp teams num_teams (7 : 9)
+ if (omp_get_num_teams () < 7 .or. omp_get_num_teams () > 9) &
+ stop 3
+ !$omp distribute dist_schedule(static,1)
+ do i = 0, omp_get_num_teams () - 1
+ if (omp_get_team_num () /= i) stop 4
+ end do
+ !$omp end teams
+end program main