[openacc] Check for sufficient parallelism when calling acc routines in Fortran

Message ID 70aa6842-6ccb-5c2b-b664-95d1c9abb1cb@codesourcery.com
State New
Headers show
Series
  • [openacc] Check for sufficient parallelism when calling acc routines in Fortran
Related show

Commit Message

Cesar Philippidis Oct. 2, 2018, 3:06 p.m.
This patch updates the Fortran FE OpenACC routine parser to enforce the
new OpenACC 2.5 routine directive semantics. In addition to emitting a
warning when the user doesn't specify a gang, worker or vector clause,
it also clarifies some error messages and introduces a new error when
the user tries to use an acc routine with insufficient parallelism,
e.g., calling a gang routine from a vector loop.

Is this patch OK for trunk? I bootstrapped and regtested it for x86_64
Linux with nvptx offloading.

Thanks,
Cesar

Patch

[OpenACC] Check for sufficient parallelism when calling acc routines in fortran

2018-XX-YY  Cesar Philippidis  <cesar@codesourcery.com>

	gcc/fortran/
	* gfortran.h (gfc_resolve_oacc_routine_call): Declare.
	(gfc_resolve_oacc_routines): Declare.
	* openmp.c (gfc_match_oacc_routine): Make error reporting more
	precise.  Defer rejection of non-function and subroutine symbols
	until gfc_resolve_oacc_routines.
	(struct fortran_omp_context): Add a dims member.
	(gfc_resolve_oacc_blocks): Update ctx->dims.
	(gfc_resolve_oacc_routine_call): New function.
	(gfc_resolve_oacc_routines): New function.
	* resolve.c (resolve_function): Call gfc_resolve_oacc_routine_call.
	(resolve_call): Likewise.
	(resolve_codes): Call gfc_resolve_oacc_routines.

	gcc/testsuite/
	* gfortran.dg/goacc/routine-10.f90: New test.
	* gfortran.dg/goacc/routine-9.f90: New test.
	* gfortran.dg/goacc/routine-nested-parallelism.f: New test.
	* gfortran.dg/goacc/routine-nested-parallelism.f90: New test.

(cherry picked from gomp-4_0-branch r239784)
(cherry picked from gomp-4_0-branch r247353)

---
 gcc/fortran/gfortran.h                        |   2 +
 gcc/fortran/openmp.c                          | 108 +++++-
 gcc/fortran/resolve.c                         |  11 +
 .../gfortran.dg/goacc/routine-10.f90          |   6 +
 gcc/testsuite/gfortran.dg/goacc/routine-9.f90 |  96 +++++
 .../goacc/routine-nested-parallelism.f        | 340 ++++++++++++++++++
 .../goacc/routine-nested-parallelism.f90      | 340 ++++++++++++++++++
 7 files changed, 887 insertions(+), 16 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-10.f90
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-9.f90
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 781dc2a7d17..87f98bbd110 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3166,6 +3166,8 @@  void gfc_resolve_oacc_directive (gfc_code *, gfc_namespace *);
 void gfc_resolve_oacc_declare (gfc_namespace *);
 void gfc_resolve_oacc_parallel_loop_blocks (gfc_code *, gfc_namespace *);
 void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_oacc_routine_call (gfc_symbol *, locus *);                     
+void gfc_resolve_oacc_routines (gfc_namespace *);
 
 /* expr.c */
 void gfc_free_actual_arglist (gfc_actual_arglist *);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 58cbe0ae90c..5850538c1f0 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2319,7 +2319,13 @@  gfc_match_oacc_routine (void)
 	{
 	  if ((isym = gfc_find_function (buffer)) == NULL
 	      && (isym = gfc_find_subroutine (buffer)) == NULL)
-	    st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	    {
+	      st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	      if (st == NULL && gfc_current_ns->proc_name->attr.contained
+		  && gfc_current_ns->parent)
+		st = gfc_find_symtree (gfc_current_ns->parent->sym_root,
+				       buffer);
+	    }
 	  if (st)
 	    {
 	      sym = st->n.sym;
@@ -2327,18 +2333,12 @@  gfc_match_oacc_routine (void)
 		  && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
 	        sym = NULL;
 	    }
-
-	  if ((isym == NULL && st == NULL)
-	      || (sym
-		  && !sym->attr.external
-		  && !sym->attr.function
-		  && !sym->attr.subroutine))
+	  else if (isym == NULL)
 	    {
-	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
-			 "invalid function name %s",
-			 (sym) ? sym->name : buffer);
-	      gfc_current_locus = old_loc;
-	      return MATCH_ERROR;
+	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, "
+			 "invalid function name %qs", &old_loc, buffer);\
+	      goto cleanup;
+
 	    }
 
 	  /* Set sym to NULL if it matches the current procedure's
@@ -2371,20 +2371,27 @@  gfc_match_oacc_routine (void)
   dims = gfc_oacc_routine_dims (c);
   if (dims == OACC_FUNCTION_NONE)
     {
-      gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %C");
+      gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %L",
+		 &old_loc);
 
       /* Don't abort early, because it's important to let the user
 	 know of any potential duplicate routine directives.  */
       seen_error = true;
     }
+  else if (dims == OACC_FUNCTION_AUTO)
+    {
+      gfc_warning (0, "Expected one of %<gang%>, %<worker%>, %<vector%> or "
+		   "%<seq%> clauses in !$ACC ROUTINE at %L", &old_loc);
+      dims = OACC_FUNCTION_SEQ;
+    }
 
   if (isym != NULL)
     {
       if (c && (c->gang || c->worker || c->vector))
 	{
 	  gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) "
-		     "at %C, with incompatible clauses specifying the level "
-		     "of parallelism");
+		     "at %L, with incompatible clauses specifying the level "
+		     "of parallelism", &old_loc);
 	  goto cleanup;
 	}
       /* The intrinsic symbol has been marked with a SEQ, or with no clause at
@@ -2429,7 +2436,8 @@  gfc_match_oacc_routine (void)
 				       &old_loc))
 	goto cleanup;
 
-      gfc_current_ns->proc_name->attr.oacc_function = dims;
+      gfc_current_ns->proc_name->attr.oacc_function
+	= seen_error ? OACC_FUNCTION_SEQ : dims;
       gfc_current_ns->proc_name->attr.oacc_function_nohost
 	= c ? c->nohost : false;
 
@@ -5359,6 +5367,7 @@  static struct fortran_omp_context
   hash_set<gfc_symbol *> *private_iterators;
   struct fortran_omp_context *previous;
   bool is_openmp;
+  oacc_function dims;
 } *omp_current_ctx;
 static gfc_code *omp_current_do_code;
 static int omp_current_do_collapse;
@@ -6036,6 +6045,7 @@  void
 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
 {
   fortran_omp_context ctx;
+  oacc_function dims = OACC_FUNCTION_NONE;
 
   resolve_oacc_loop_blocks (code);
 
@@ -6044,6 +6054,21 @@  gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
   ctx.private_iterators = new hash_set<gfc_symbol *>;
   ctx.previous = omp_current_ctx;
   ctx.is_openmp = false;
+
+  if (code->ext.omp_clauses->gang)
+    dims = OACC_FUNCTION_GANG;
+  if (code->ext.omp_clauses->worker)
+    dims = OACC_FUNCTION_WORKER;
+  if (code->ext.omp_clauses->vector)
+    dims = OACC_FUNCTION_VECTOR;
+  if (code->ext.omp_clauses->seq)
+    dims = OACC_FUNCTION_SEQ;
+
+  if (dims == OACC_FUNCTION_NONE && ctx.previous != NULL
+      && !ctx.previous->is_openmp)
+    dims = ctx.previous->dims;
+
+  ctx.dims = dims;
   omp_current_ctx = &ctx;
 
   gfc_resolve_blocks (code->block, ns);
@@ -6401,3 +6426,54 @@  gfc_resolve_omp_udrs (gfc_symtree *st)
   for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
     gfc_resolve_omp_udr (omp_udr);
 }
+
+/* Ensure that any calls to OpenACC routines respects the current
+   level of parallelism of the innermost loop.  */
+
+void
+gfc_resolve_oacc_routine_call (gfc_symbol *sym, locus *loc)
+{
+  gfc_oacc_routine_name *n = NULL;
+  oacc_function loop_dims = OACC_FUNCTION_NONE;
+  oacc_function routine_dims;
+
+  if (!omp_current_ctx)
+    return;
+
+  loop_dims = omp_current_ctx->dims;
+
+  if (omp_current_ctx->is_openmp || loop_dims == OACC_FUNCTION_NONE)
+    return;
+
+  for (n = gfc_current_ns->oacc_routine_names; n; n = n->next)
+    if (n->sym == sym)
+      break;
+
+  if (n == NULL)
+    return;
+
+  routine_dims = gfc_oacc_routine_dims (n->clauses);
+
+  if (routine_dims == OACC_FUNCTION_SEQ)
+    return;
+  if (routine_dims <= loop_dims)
+    gfc_error ("Insufficient !$ACC LOOP parallelism available to call "
+	       "%qs at %L", sym->name, loc);
+}
+
+void
+gfc_resolve_oacc_routines (gfc_namespace *ns)
+{
+  gfc_oacc_routine_name *routines = NULL;
+
+  for (routines = ns->oacc_routine_names; routines; routines = routines->next)
+    {
+      gfc_symbol *sym = routines->sym;
+
+      if (!sym->attr.external
+	  && !sym->attr.function
+	  && !sym->attr.subroutine)
+	gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, "
+		   "invalid function name %qs", &routines->loc, sym->name);
+    }
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a2beb7fc90a..a6d0450014a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3337,6 +3337,11 @@  resolve_function (gfc_expr *expr)
     /* typebound procedure: Assume the worst.  */
     gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
 
+  /* Calls to OpenACC routines have imposed restrictions on gang,
+     worker and vector parallelism.  */
+  if (sym)
+    gfc_resolve_oacc_routine_call (sym, &expr->where);
+
   return t;
 }
 
@@ -3680,6 +3685,11 @@  resolve_call (gfc_code *c)
     /* Typebound procedure: Assume the worst.  */
     gfc_current_ns->proc_name->attr.array_outer_dependency = 1;
 
+  /* Calls to OpenACC routines have imposed restrictions on gang,
+     worker and vector parallelism.  */
+  if (csym)
+    gfc_resolve_oacc_routine_call (csym, &c->loc);
+
   return t;
 }
 
@@ -16645,6 +16655,7 @@  resolve_codes (gfc_namespace *ns)
   bitmap_obstack_initialize (&labels_obstack);
 
   gfc_resolve_oacc_declare (ns);
+  gfc_resolve_oacc_routines (ns);
   gfc_resolve_omp_local_vars (ns);
   gfc_resolve_code (ns->code, ns);
 
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-10.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-10.f90
new file mode 100644
index 00000000000..20b2d77b59b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-10.f90
@@ -0,0 +1,6 @@ 
+! Ensure that GFortran doesn't ICE with incomplete function
+! definitions.
+
+integer function f1 ! { dg-error "Expected formal argument list in function definition" }
+  !$acc routine ! { dg-error "Unclassifiable OpenACC directive" }
+end function f1 ! { dg-error "Expecting END PROGRAM statement" }
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-9.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-9.f90
new file mode 100644
index 00000000000..590e5946d2f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-9.f90
@@ -0,0 +1,96 @@ 
+! Check for late resolver errors caused by invalid ACC ROUTINE
+! directives.
+
+module m
+  integer m1int
+contains
+  subroutine subr5 (x)
+    implicit none
+    integer extfunc
+    !$acc routine (subr5)
+    !$acc routine (extfunc)
+    !$acc routine (m1int) ! { dg-error "invalid function name" }
+    integer, intent(inout) :: x
+    if (x < 1) then
+       x = 1
+    else
+       x = x * x - 1 + extfunc(2)
+    end if
+  end subroutine subr5
+end module m
+
+program main
+  implicit none
+  interface
+    function subr6 (x)
+    integer, intent (in) :: x
+    integer :: subr6
+    end function subr6
+  end interface
+  integer, parameter :: n = 10
+  integer :: a(n), i
+  !$acc routine (subr1) ! { dg-error "invalid function name" }
+  external :: subr2
+  !$acc routine (subr2)
+
+  external :: R1, R2
+  !$acc routine (R1)
+  !$acc routine (R2)
+
+  !$acc parallel
+  !$acc loop
+  do i = 1, n
+     call subr1 (i)
+     call subr2 (i)
+  end do
+  !$acc end parallel
+end program main
+
+subroutine subr1 (x)
+  !$acc routine
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr1
+
+subroutine subr2 (x)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr2
+
+subroutine subr3 (x)
+  !$acc routine (subr3)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     call subr4 (x)
+  end if
+end subroutine subr3
+
+subroutine subr4 (x)
+  !$acc routine (subr4)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr4
+
+subroutine subr10 (x)
+  !$acc routine (subr10) device ! { dg-error "Unclassifiable OpenACC directive" }
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr10
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f
new file mode 100644
index 00000000000..d1304c66c22
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f
@@ -0,0 +1,340 @@ 
+! Validate calls to ACC ROUTINES.  Ensure that the loop containing the
+! call has sufficient parallelism to for the routine.
+
+      subroutine sub
+      implicit none
+      integer, parameter :: n = 100
+      integer :: a(n), i, j
+      external gangr, workerr, vectorr, seqr
+!$acc routine (gangr) gang
+!$acc routine (workerr) worker
+!$acc routine (vectorr) vector
+!$acc routine (seqr) seq
+
+!
+! Test subroutine calls inside nested loops.
+!
+
+!$acc parallel loop
+      do i = 1, n
+         !$acc loop
+         do j = 1, n
+            call workerr (a, n)
+         end do
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop
+      do i = 1, n
+!$acc loop gang
+         do j = 1, n
+            call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+         end do
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to seq routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call seqr (a, n)
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to gang routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call gangr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to worker routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call workerr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call workerr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to vector routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         call vectorr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         call vectorr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         call vectorr (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+      end subroutine sub
+
+      subroutine func
+      implicit none
+      integer, parameter :: n = 100
+      integer :: a(n), i, j
+      integer gangf, workerf, vectorf, seqf
+!$acc routine (gangf) gang
+!$acc routine (workerf) worker
+!$acc routine (vectorf) vector
+!$acc routine (seqf) seq
+
+!
+! Test subroutine calls inside nested loops.
+!
+
+!$acc parallel loop
+      do i = 1, n
+!$acc loop
+         do j = 1, n
+            a(1) = workerf (a, n)
+         end do
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop
+      do i = 1, n
+!$acc loop gang
+         do j = 1, n
+            a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+         end do
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to seq routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = seqf (a, n)
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to gang routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = gangf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to worker routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = workerf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = workerf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!
+! Test calls to vector routines
+!
+
+!$acc parallel loop
+      do i = 1, n
+         a(1) = vectorf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop gang
+      do i = 1, n
+         a(1) = vectorf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop worker
+      do i = 1, n
+         a(1) = vectorf (a, n)
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop vector
+      do i = 1, n
+         a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+
+!$acc parallel loop seq
+      do i = 1, n
+         a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+      end do
+!$acc end parallel loop
+      end subroutine func
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90
new file mode 100644
index 00000000000..94e0464592a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90
@@ -0,0 +1,340 @@ 
+! Validate calls to ACC ROUTINES.  Ensure that the loop containing the
+! call has sufficient parallelism to for the routine.
+
+subroutine sub
+  implicit none
+  integer, parameter :: n = 100
+  integer :: a(n), i, j
+  external gangr, workerr, vectorr, seqr
+  !$acc routine (gangr) gang
+  !$acc routine (workerr) worker
+  !$acc routine (vectorr) vector
+  !$acc routine (seqr) seq
+
+  !
+  ! Test subroutine calls inside nested loops.
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop
+     do j = 1, n
+        call workerr (a, n)
+     end do
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop gang
+     do j = 1, n
+        call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+     end do
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to seq routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call seqr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to gang routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call gangr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to worker routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call workerr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call workerr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to vector routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     call vectorr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     call vectorr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     call vectorr (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+end subroutine sub
+
+subroutine func
+  implicit none
+  integer, parameter :: n = 100
+  integer :: a(n), i, j
+  integer gangf, workerf, vectorf, seqf
+  !$acc routine (gangf) gang
+  !$acc routine (workerf) worker
+  !$acc routine (vectorf) vector
+  !$acc routine (seqf) seq
+
+  !
+  ! Test subroutine calls inside nested loops.
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop
+     do j = 1, n
+        a(1) = workerf (a, n)
+     end do
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop
+  do i = 1, n
+     !$acc loop gang
+     do j = 1, n
+        a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+     end do
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to seq routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = seqf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to gang routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = gangf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to worker routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = workerf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = workerf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !
+  ! Test calls to vector routines
+  !
+
+  !$acc parallel loop
+  do i = 1, n
+     a(1) = vectorf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop gang
+  do i = 1, n
+     a(1) = vectorf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop worker
+  do i = 1, n
+     a(1) = vectorf (a, n)
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop vector
+  do i = 1, n
+     a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+
+  !$acc parallel loop seq
+  do i = 1, n
+     a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" }
+  end do
+  !$acc end parallel loop
+end subroutine func
-- 
2.17.1