diff mbox

OpenACC routines -- fortran front end

Message ID ac368653-bfa5-6b35-13be-eef8d5f3d155@codesourcery.com
State New
Headers show

Commit Message

Cesar Philippidis Nov. 22, 2016, 7:58 p.m. UTC
On 11/18/2016 04:29 AM, Jakub Jelinek wrote:
> On Fri, Nov 11, 2016 at 03:44:07PM -0800, Cesar Philippidis wrote:

>> --- a/gcc/fortran/gfortran.h

>> +++ b/gcc/fortran/gfortran.h

>> @@ -314,6 +314,15 @@ enum save_state

>>  { SAVE_NONE = 0, SAVE_EXPLICIT, SAVE_IMPLICIT

>>  };

>>  

>> +/* Flags to keep track of ACC routine states.  */

>> +enum oacc_function

>> +{ OACC_FUNCTION_NONE = 0,

> 

> Please add a newline after {.

> 

>>    if (clauses)

>>      {

>>        unsigned mask = 0;

>>  

>>        if (clauses->gang)

>> -	level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);

>> +	{

>> +	  level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);

>> +	  ret = OACC_FUNCTION_GANG;

>> +	}

>>        if (clauses->worker)

>> -	level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);

>> +	{

>> +	  level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);

>> +	  ret = OACC_FUNCTION_WORKER;

>> +	}

>>        if (clauses->vector)

>> -	level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);

>> +	{

>> +	  level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);

>> +	  ret = OACC_FUNCTION_VECTOR;

>> +	}

> 

> As you have {}s around, please use

> 	level = GOMP_DIM_*;

> 	mask |= GOMP_DIM_MASK (level);

> 	ret = OACC_FUNCTION_*;

> 

>>        if (clauses->seq)

>>  	level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);

>>  

>>        if (mask != (mask & -mask))

>> -	gfc_error ("Multiple loop axes specified for routine");

>> +	ret = OACC_FUNCTION_NONE;

>>      }

>>  

>> -  if (level < 0)

>> -    level = GOMP_DIM_MAX;

>> -

>> -  return level;

>> +  return ret;

>>  }

>>  

>>  match

>>  gfc_match_oacc_routine (void)

>>  {

>>    locus old_loc;

>> -  gfc_symbol *sym = NULL;

>>    match m;

>> +  gfc_intrinsic_sym *isym = NULL;

>> +  gfc_symbol *sym = NULL;

>>    gfc_omp_clauses *c = NULL;

>>    gfc_oacc_routine_name *n = NULL;

>> +  oacc_function dims = OACC_FUNCTION_NONE;

>> +  bool seen_error = false;

>>  

>>    old_loc = gfc_current_locus;

>>  

>> @@ -2287,45 +2314,52 @@ gfc_match_oacc_routine (void)

>>    if (m == MATCH_YES)

>>      {

>>        char buffer[GFC_MAX_SYMBOL_LEN + 1];

>> -      gfc_symtree *st;

>> +      gfc_symtree *st = NULL;

>>  

>>        m = gfc_match_name (buffer);

>>        if (m == MATCH_YES)

>>  	{

>> -	  st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);

>> +	  if ((isym = gfc_find_function (buffer)) == NULL

>> +	      && (isym = gfc_find_subroutine (buffer)) == NULL)

>> +	    {

>> +	      st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);

>> +	      if (st == NULL && gfc_current_ns->proc_name->attr.contained

> 

> Please add a newline before &&.

> 

>> +		  && gfc_current_ns->parent)

>> +		st = gfc_find_symtree (gfc_current_ns->parent->sym_root,

>> +				       buffer);

>> +	    }

> 

>> @@ -5934,6 +6033,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;

> 

> Shouldn't these be else if ?

>> +

>> +  if (dims == OACC_FUNCTION_NONE && ctx.previous != NULL

> 

> Again, as the whole condition doesn't fit on one line, please

> put && on a new line.

>> +      && !ctx.previous->is_openmp)

>> +    dims = ctx.previous->dims;


I've address those issues in this patch. Is it ok for trunk?

Cesar
diff mbox

Patch

2016-11-22  Cesar Philippidis  <cesar@codesourcery.com>

	gcc/fortran/
	* gfortran.h (enum oacc_function): Make OACC_FUNCTION_SEQ the last
	entry the enum.
	(oacc_function_types): Declare.
	(symbol_attribute): Add oacc_function, oacc_function_nohost members.
	(gfc_omp_clauses): Add routine_bind, nohost, bind members.
	(gfc_oacc_routine_name): Add loc.
	(gfc_resolve_oacc_routine_call): Declare.
	(gfc_resolve_oacc_routines): Declare.
	* module.c (oacc_function): New DECL_MIO_NAME.
	(mio_symbol_attribute): Set the oacc_function attribute.
	* openmp.c (enum omp_mask2): Add OMP_CLAUSE_BIND and OMP_CLAUSE_NOHOST.
	(gfc_match_omp_clauses): Likewise.
	(OACC_ROUTINE_CLAUSES): Add OMP_CLAUSE_BIND and OMP_CLAUSE_NOHOST.
	(gfc_oacc_routine_dims): Change the type of oacc_function from unsigned
	to an ENUM_BITFIELD.Move gfc_error to gfc_match_oacc_routine.  Return
	OACC_FUNCTION_NONE on error.
	(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.
	* symbol.c (oacc_function_types): Define.
	* trans-decl.c (add_attributes_to_decl): Update to handle the
	retyped oacc_function attribute.


diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7956630..5c1dbda 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -314,6 +314,16 @@  enum save_state
 { SAVE_NONE = 0, SAVE_EXPLICIT, SAVE_IMPLICIT
 };
 
+/* Flags to keep track of ACC routine states.  */
+enum oacc_function
+{
+  OACC_FUNCTION_NONE = 0,
+  OACC_FUNCTION_GANG,
+  OACC_FUNCTION_WORKER,
+  OACC_FUNCTION_VECTOR,
+  OACC_FUNCTION_SEQ
+};
+
 /* Strings for all symbol attributes.  We use these for dumping the
    parse tree, in error messages, and also when reading and writing
    modules.  In symbol.c.  */
@@ -323,6 +333,7 @@  extern const mstring intents[];
 extern const mstring access_types[];
 extern const mstring ifsrc_types[];
 extern const mstring save_status[];
+extern const mstring oacc_function_types[];
 
 /* Strings for DTIO procedure names.  In symbol.c.  */
 extern const mstring dtio_procs[];
@@ -882,7 +893,8 @@  typedef struct
   unsigned oacc_declare_link:1;
 
   /* This is an OpenACC acclerator function at level N - 1  */
-  unsigned oacc_function:3;
+  ENUM_BITFIELD (oacc_function) oacc_function:3;
+  unsigned oacc_function_nohost:1;
 
   /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES).  */
   unsigned ext_attr:EXT_ATTR_NUM;
@@ -1310,10 +1322,11 @@  typedef struct gfc_omp_clauses
   struct gfc_expr *num_gangs_expr;
   struct gfc_expr *num_workers_expr;
   struct gfc_expr *vector_length_expr;
+  struct gfc_symbol *routine_bind;
   gfc_expr_list *wait_list;
   gfc_expr_list *tile_list;
   unsigned async:1, gang:1, worker:1, vector:1, seq:1, independent:1;
-  unsigned wait:1, par_auto:1, gang_static:1;
+  unsigned wait:1, par_auto:1, gang_static:1, nohost:1, bind:1;
   locus loc;
 
 }
@@ -1691,6 +1704,7 @@  typedef struct gfc_oacc_routine_name
   struct gfc_symbol *sym;
   struct gfc_omp_clauses *clauses;
   struct gfc_oacc_routine_name *next;
+  locus loc;
 }
 gfc_oacc_routine_name;
 
@@ -3067,6 +3081,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/module.c b/gcc/fortran/module.c
index 4116db8..135b44c 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2097,6 +2097,7 @@  DECL_MIO_NAME (procedure_type)
 DECL_MIO_NAME (ref_type)
 DECL_MIO_NAME (sym_flavor)
 DECL_MIO_NAME (sym_intent)
+DECL_MIO_NAME (oacc_function)
 #undef DECL_MIO_NAME
 
 /* Symbol attributes are stored in list with the first three elements
@@ -2118,6 +2119,8 @@  mio_symbol_attribute (symbol_attribute *attr)
   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
   attr->save = MIO_NAME (save_state) (attr->save, save_status);
+  attr->oacc_function = MIO_NAME (oacc_function) (attr->oacc_function,
+						  oacc_function_types);
 
   ext_attr = attr->ext_attr;
   mio_integer ((int *) &ext_attr);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 11ffb5d..29d6fb8 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -813,6 +813,8 @@  enum omp_mask2
   OMP_CLAUSE_DELETE,
   OMP_CLAUSE_AUTO,
   OMP_CLAUSE_TILE,
+  OMP_CLAUSE_BIND,
+  OMP_CLAUSE_NOHOST,
   /* This must come last.  */
   OMP_MASK2_LAST
 };
@@ -1015,6 +1017,14 @@  gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 	      continue;
 	    }
 	  break;
+	case 'b':
+	  if ((mask & OMP_CLAUSE_BIND) && c->routine_bind == NULL
+	      && gfc_match ("bind ( %s )", &c->routine_bind) == MATCH_YES)
+	    {
+	      c->bind = 1;
+	      continue;
+	    }
+	  break;
 	case 'c':
 	  if ((mask & OMP_CLAUSE_COLLAPSE)
 	      && !c->collapse)
@@ -1434,6 +1444,12 @@  gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 	      c->nogroup = needs_space = true;
 	      continue;
 	    }
+	  if ((mask & OMP_CLAUSE_NOHOST) && !c->nohost
+	      && gfc_match ("nohost") == MATCH_YES)
+	    {
+	      c->nohost = true;
+	      continue;
+	    }
 	  if ((mask & OMP_CLAUSE_NOTINBRANCH)
 	      && !c->notinbranch
 	      && !c->inbranch
@@ -1975,7 +1991,7 @@  gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
   omp_mask (OMP_CLAUSE_ASYNC)
 #define OACC_ROUTINE_CLAUSES \
   (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR	      \
-   | OMP_CLAUSE_SEQ)
+   | OMP_CLAUSE_SEQ | OMP_CLAUSE_BIND | OMP_CLAUSE_NOHOST)
 
 
 static match
@@ -2232,44 +2248,58 @@  gfc_match_oacc_cache (void)
   return MATCH_YES;
 }
 
-/* Determine the loop level for a routine.   */
+/* Determine the loop level for a routine.  Returns OACC_FUNCTION_NONE
+   if any error is detected.  */
 
-static int
+static oacc_function
 gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
 {
   int level = -1;
+  oacc_function ret = OACC_FUNCTION_SEQ;
 
   if (clauses)
     {
       unsigned mask = 0;
 
       if (clauses->gang)
-	level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
+	{
+	  level = GOMP_DIM_GANG;
+	  mask |= GOMP_DIM_MASK (level);
+	  ret = OACC_FUNCTION_GANG;
+	}
       if (clauses->worker)
-	level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
+	{
+	  level = GOMP_DIM_WORKER;
+	  mask |= GOMP_DIM_MASK (level);
+	  ret = OACC_FUNCTION_WORKER;
+	}
       if (clauses->vector)
-	level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
+	{
+	  level = GOMP_DIM_VECTOR;
+	  mask |= GOMP_DIM_MASK (level);
+	  ret = OACC_FUNCTION_VECTOR;
+	}
       if (clauses->seq)
 	level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);
 
       if (mask != (mask & -mask))
-	gfc_error ("Multiple loop axes specified for routine");
+	ret = OACC_FUNCTION_NONE;
     }
 
-  if (level < 0)
-    level = GOMP_DIM_MAX;
-
-  return level;
+  return ret;
 }
 
 match
 gfc_match_oacc_routine (void)
 {
   locus old_loc;
-  gfc_symbol *sym = NULL;
   match m;
+  gfc_intrinsic_sym *isym = NULL;
+  gfc_symbol *sym = NULL;
   gfc_omp_clauses *c = NULL;
   gfc_oacc_routine_name *n = NULL;
+  oacc_function dims = OACC_FUNCTION_NONE;
+  bool seen_error = false;
 
   old_loc = gfc_current_locus;
 
@@ -2287,45 +2317,53 @@  gfc_match_oacc_routine (void)
   if (m == MATCH_YES)
     {
       char buffer[GFC_MAX_SYMBOL_LEN + 1];
-      gfc_symtree *st;
+      gfc_symtree *st = NULL;
 
       m = gfc_match_name (buffer);
       if (m == MATCH_YES)
 	{
-	  st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	  if ((isym = gfc_find_function (buffer)) == NULL
+	      && (isym = gfc_find_subroutine (buffer)) == NULL)
+	    {
+	      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;
 	      if (strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
 	        sym = NULL;
 	    }
-
-	  if (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
+	     name.  This will simplify the check for duplicate ACC
+	     ROUTINE attributes.  */
+	  if (gfc_current_ns->proc_name
+	      && !strcmp (buffer, gfc_current_ns->proc_name->name))
+	    sym = NULL;
 	}
       else
         {
-	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
-	  gfc_current_locus = old_loc;
-	  return MATCH_ERROR;
+	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L", &old_loc);
+	  goto cleanup;
 	}
 
       if (gfc_match_char (')') != MATCH_YES)
 	{
-	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
-		     " ')' after NAME");
-	  gfc_current_locus = old_loc;
-	  return MATCH_ERROR;
+	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, expecting"
+		     " ')' after NAME", &old_loc);
+	  goto cleanup;
 	}
     }
 
@@ -2334,26 +2372,89 @@  gfc_match_oacc_routine (void)
 	  != MATCH_YES))
     return MATCH_ERROR;
 
-  if (sym != NULL)
+  /* Scan for invalid routine geometry.  */
+  dims = gfc_oacc_routine_dims (c);
+  if (dims == OACC_FUNCTION_NONE)
+    {
+      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;
+    }
+
+  if (isym != NULL)
     {
-      n = gfc_get_oacc_routine_name ();
-      n->sym = sym;
-      n->clauses = NULL;
-      n->next = NULL;
-      if (gfc_current_ns->oacc_routine_names != NULL)
-	n->next = gfc_current_ns->oacc_routine_names;
-
-      gfc_current_ns->oacc_routine_names = n;
+      if (c && (c->gang || c->worker || c->vector))
+	{
+	  gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) "
+		     "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
+	 all, which is OK.  */
+    }
+  else if (sym != NULL)
+    {
+      bool needs_entry = true;
+      
+      /* Scan for any repeated routine directives on 'sym' and report
+	 an error if necessary.  TODO: Extend this function to scan
+	 for compatible DEVICE_TYPE dims.  */
+      for (n = gfc_current_ns->oacc_routine_names; n; n = n->next)
+	if (n->sym == sym)
+	  {
+	    needs_entry = false;
+	    if (dims != gfc_oacc_routine_dims (n->clauses))
+	      {
+		gfc_error ("$!ACC ROUTINE already applied at %L", &old_loc);
+		goto cleanup;
+	      }
+	  }
+
+      if (needs_entry)
+	{
+	  n = gfc_get_oacc_routine_name ();
+	  n->sym = sym;
+	  n->clauses = c;
+	  n->next = NULL;
+	  n->loc = old_loc;
+
+	  if (gfc_current_ns->oacc_routine_names != NULL)
+	    n->next = gfc_current_ns->oacc_routine_names;
+
+	  gfc_current_ns->oacc_routine_names = n;
+	}
+
+      if (seen_error)
+	goto cleanup;
     }
   else if (gfc_current_ns->proc_name)
     {
+      if (gfc_current_ns->proc_name->attr.oacc_function != OACC_FUNCTION_NONE
+	  && !seen_error)
+	{
+	  gfc_error ("!$ACC ROUTINE already applied at %L", &old_loc);
+	  goto cleanup;
+	}
+
       if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
 				       gfc_current_ns->proc_name->name,
 				       &old_loc))
 	goto cleanup;
+
       gfc_current_ns->proc_name->attr.oacc_function
-	= gfc_oacc_routine_dims (c) + 1;
+	= seen_error ? OACC_FUNCTION_SEQ : dims;
+      gfc_current_ns->proc_name->attr.oacc_function_nohost
+	= c ? c->nohost : false;
+
+      if (seen_error)
+	goto cleanup;
     }
+  else
+    gcc_unreachable ();
 
   if (n)
     n->clauses = c;
@@ -5263,6 +5364,7 @@  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;
@@ -5926,6 +6028,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);
 
@@ -5934,6 +6037,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;
+  else if (code->ext.omp_clauses->worker)
+    dims = OACC_FUNCTION_WORKER;
+  else if (code->ext.omp_clauses->vector)
+    dims = OACC_FUNCTION_VECTOR;
+  else 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);
@@ -6285,3 +6403,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 9e628f1..b00c9fa 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3159,6 +3159,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;
 }
 
@@ -3502,6 +3507,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;
 }
 
@@ -16022,6 +16032,7 @@  resolve_codes (gfc_namespace *ns)
   bitmap_obstack_initialize (&labels_obstack);
 
   gfc_resolve_oacc_declare (ns);
+  gfc_resolve_oacc_routines (ns);
   gfc_resolve_code (ns->code, ns);
 
   bitmap_obstack_release (&labels_obstack);
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0b711ca..ab07f64 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -96,6 +96,15 @@  const mstring dtio_procs[] =
     minit ("_dtio_unformatted_write", DTIO_WUF),
 };
 
+const mstring oacc_function_types[] =
+{
+  minit ("NONE", OACC_FUNCTION_NONE),
+  minit ("OACC_FUNCTION_SEQ", OACC_FUNCTION_SEQ),
+  minit ("OACC_FUNCTION_GANG", OACC_FUNCTION_GANG),
+  minit ("OACC_FUNCTION_WORKER", OACC_FUNCTION_WORKER),
+  minit ("OACC_FUNCTION_VECTOR", OACC_FUNCTION_VECTOR)
+};
+
 /* This is to make sure the backend generates setup code in the correct
    order.  */
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index ba71a21..c43f4c1 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -46,6 +46,7 @@  along with GCC; see the file COPYING3.  If not see
 #include "trans-stmt.h"
 #include "gomp-constants.h"
 #include "gimplify.h"
+#include "omp-low.h"
 
 #define MAX_LABEL_VALUE 99999
 
@@ -1380,19 +1381,38 @@  add_attributes_to_decl (symbol_attribute sym_attr, tree list)
     list = tree_cons (get_identifier ("omp declare target link"),
 		      NULL_TREE, list);
   else if (sym_attr.omp_declare_target)
-    list = tree_cons (get_identifier ("omp declare target"),
-		      NULL_TREE, list);
-
-  if (sym_attr.oacc_function)
     {
-      tree dims = NULL_TREE;
-      int ix;
-      int level = sym_attr.oacc_function - 1;
+      tree c = NULL_TREE;
+      if (sym_attr.oacc_function_nohost)
+	c = build_omp_clause (/* TODO */ input_location,
+			      OMP_CLAUSE_NOHOST);
+      list = tree_cons (get_identifier ("omp declare target"), c, list);
+    }
+  if (sym_attr.oacc_function)
 
-      for (ix = GOMP_DIM_MAX; ix--;)
-	dims = tree_cons (build_int_cst (boolean_type_node, ix >= level),
-			  integer_zero_node, dims);
+  if (sym_attr.oacc_function != OACC_FUNCTION_NONE)
+    {
+      omp_clause_code code = OMP_CLAUSE_ERROR;
+      tree clause, dims;
+      
+      switch (sym_attr.oacc_function)
+	{
+	case OACC_FUNCTION_GANG:
+	  code = OMP_CLAUSE_GANG;
+	  break;
+	case OACC_FUNCTION_WORKER:
+	  code = OMP_CLAUSE_WORKER;
+	  break;
+	case OACC_FUNCTION_VECTOR:
+	  code = OMP_CLAUSE_VECTOR;
+	  break;
+	case OACC_FUNCTION_SEQ:
+	default:
+	  code = OMP_CLAUSE_SEQ;
+	}
 
+      clause = build_omp_clause (UNKNOWN_LOCATION, code);
+      dims = build_oacc_routine_dims (clause);
       list = tree_cons (get_identifier ("oacc function"),
 			dims, list);
     }