Fortran: Add 'device_type' clause to OpenMP's declare target

gcc/fortran/ChangeLog: * gfortran.h (enum gfc_omp_device_type): New. (symbol_attribute, gfc_omp_clauses, gfc_common_head): Use it. * module.c (enum ab_attribute): Add AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_NOHOST and AB_OMP_DEVICE_TYPE_ANY. (attr_bits, mio_symbol_attribute): Handle it. (load_commons, write_common_0): Handle omp_device_type flag. * openmp.c (enum omp_mask1): Add OMP_CLAUSE_DEVICE_TYPE (OMP_DECLARE_TARGET_CLAUSES): Likewise. (gfc_match_omp_clauses): Match 'device_type'. (gfc_match_omp_declare_target): Handle it. * trans-common.c (build_common_decl): Write device-type clause. * trans-decl.c (add_attributes_to_decl): Likewise. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/declare-target-4.f90: New test. * gfortran.dg/gomp/declare-target-5.f90: New test.
2020-08-26 09:32:40 +02:00 · 2020-08-26 09:32:40 +02:00 · d58e7173ef
commit d58e7173ef
parent 4797a61cc5
7 changed files with 277 additions and 7 deletions
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@ -753,6 +753,13 @@ CInteropKind_t;
   that the list is initialized.  */
 extern CInteropKind_t c_interop_kinds_table[];

+enum gfc_omp_device_type
+{
+  OMP_DEVICE_TYPE_UNSET,
+  OMP_DEVICE_TYPE_HOST,
+  OMP_DEVICE_TYPE_NOHOST,
+  OMP_DEVICE_TYPE_ANY
+};

 /* Structure and list of supported extension attributes.  */
 typedef enum
@ -919,6 +926,7 @@ typedef struct
  /* Mentioned in OMP DECLARE TARGET.  */
  unsigned omp_declare_target:1;
  unsigned omp_declare_target_link:1;
+  ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;

  /* Mentioned in OACC DECLARE.  */
  unsigned oacc_declare_create:1;
@ -1360,6 +1368,7 @@ typedef struct gfc_omp_clauses
  struct gfc_expr *num_threads;
  gfc_omp_namelist *lists[OMP_LIST_NUM];
  enum gfc_omp_sched_kind sched_kind;
+  enum gfc_omp_device_type device_type;
  struct gfc_expr *chunk_size;
  enum gfc_omp_default_sharing default_sharing;
  int collapse, orderedc;
@ -1699,6 +1708,7 @@ typedef struct gfc_common_head
  char use_assoc, saved, threadprivate;
  unsigned char omp_declare_target : 1;
  unsigned char omp_declare_target_link : 1;
+  ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;
  /* Provide sufficient space to hold "symbol.symbol.eq.1234567890".  */
  char name[2*GFC_MAX_SYMBOL_LEN + 1 + 14 + 1];
  struct gfc_symbol *head;
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@ -2051,7 +2051,8 @@ enum ab_attribute
  AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS,
  AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS,
  AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL,
-  AB_OMP_REQ_MEM_ORDER_RELAXED
+  AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST,
+  AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY
 };

 static const mstring attr_bits[] =
@ -2132,6 +2133,9 @@ static const mstring attr_bits[] =
    minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST),
    minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL),
    minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED),
+    minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST),
+    minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST),
+    minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY),
    minit (NULL, -1)
 };

@ -2397,6 +2401,22 @@ mio_symbol_attribute (symbol_attribute *attr)
 	      == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
 	    MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits);
 	}
+      switch (attr->omp_device_type)
+	{
+	case OMP_DEVICE_TYPE_UNSET:
+	  break;
+	case OMP_DEVICE_TYPE_HOST:
+	  MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_HOST, attr_bits);
+	  break;
+	case OMP_DEVICE_TYPE_NOHOST:
+	  MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits);
+	  break;
+	case OMP_DEVICE_TYPE_ANY:
+	  MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits);
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
      mio_rparen ();
    }
  else
@ -2661,6 +2681,15 @@ mio_symbol_attribute (symbol_attribute *attr)
 					   "relaxed", &gfc_current_locus,
 					   module_name);
 	      break;
+	    case AB_OMP_DEVICE_TYPE_HOST:
+	      attr->omp_device_type = OMP_DEVICE_TYPE_HOST;
+	      break;
+	    case AB_OMP_DEVICE_TYPE_NOHOST:
+	      attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST;
+	      break;
+	    case AB_OMP_DEVICE_TYPE_ANY:
+	      attr->omp_device_type = OMP_DEVICE_TYPE_ANY;
+	      break;
 	    }
 	}
    }
@ -4849,6 +4878,7 @@ load_commons (void)
 	p->saved = 1;
      if (flags & 2)
 	p->threadprivate = 1;
+      p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3);
      p->use_assoc = 1;

      /* Get whether this was a bind(c) common or not.  */
@ -5713,6 +5743,7 @@ write_common_0 (gfc_symtree *st, bool this_module)
      flags = p->saved ? 1 : 0;
      if (p->threadprivate)
 	flags |= 2;
+      flags |= p->omp_device_type << 2;
      mio_integer (&flags);

      /* Write out whether the common block is bind(c) or not.  */
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@ -752,7 +752,7 @@ cleanup:
  return MATCH_ERROR;
 }

-/* OpenMP 4.5 clauses.  */
+/* OpenMP clauses.  */
 enum omp_mask1
 {
  OMP_CLAUSE_PRIVATE,
@ -800,7 +800,8 @@ enum omp_mask1
  OMP_CLAUSE_SIMD,
  OMP_CLAUSE_THREADS,
  OMP_CLAUSE_USE_DEVICE_PTR,
-  OMP_CLAUSE_USE_DEVICE_ADDR,  /* Actually, OpenMP 5.0.  */
+  OMP_CLAUSE_USE_DEVICE_ADDR,  /* OpenMP 5.0.  */
+  OMP_CLAUSE_DEVICE_TYPE,  /* OpenMP 5.0.  */
  OMP_CLAUSE_NOWAIT,
  /* This must come last.  */
  OMP_MASK1_LAST
@ -1214,6 +1215,24 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 					   OMP_MAP_FORCE_DEVICEPTR, false,
 					   allow_derived))
 	    continue;
+	  if ((mask & OMP_CLAUSE_DEVICE_TYPE)
+	      && gfc_match ("device_type ( ") == MATCH_YES)
+	    {
+	      if (gfc_match ("host") == MATCH_YES)
+		c->device_type = OMP_DEVICE_TYPE_HOST;
+	      else if (gfc_match ("nohost") == MATCH_YES)
+		c->device_type = OMP_DEVICE_TYPE_NOHOST;
+	      else if (gfc_match ("any") == MATCH_YES)
+		c->device_type = OMP_DEVICE_TYPE_ANY;
+	      else
+		{
+		  gfc_error ("Expected HOST, NOHOST or ANY at %C");
+		  break;
+		}
+	      if (gfc_match (" )") != MATCH_YES)
+		break;
+	      continue;
+	    }
 	  if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
 	      && gfc_match_omp_variable_list
 		   ("device_resident (",
@ -2638,7 +2657,7 @@ cleanup:
 #define OMP_ORDERED_CLAUSES \
  (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
 #define OMP_DECLARE_TARGET_CLAUSES \
-  (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)
+  (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE)


 static match
@ -3275,6 +3294,15 @@ gfc_match_omp_declare_target (void)
 		gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
 						 &n->sym->declared_at);
 	    }
+	  if (c->device_type != OMP_DEVICE_TYPE_UNSET)
+	    {
+	      if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
+		  && n->sym->attr.omp_device_type != c->device_type)
+		gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
+			       "TARGET directive to a different DEVICE_TYPE",
+			       n->sym->name, &n->where);
+	      n->sym->attr.omp_device_type = c->device_type;
+	    }
 	  n->sym->mark = 1;
 	}
      else if (n->u.common->omp_declare_target
@ -3297,6 +3325,13 @@ gfc_match_omp_declare_target (void)
 	{
 	  n->u.common->omp_declare_target = 1;
 	  n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
+	  if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
+	      && n->u.common->omp_device_type != c->device_type)
+	    gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
+			   "TARGET directive to a different DEVICE_TYPE",
+			   &n->where);
+	  n->u.common->omp_device_type = c->device_type;
+
 	  for (s = n->u.common->head; s; s = s->common_next)
 	    {
 	      s->mark = 1;
@ -3307,8 +3342,17 @@ gfc_match_omp_declare_target (void)
 		    gfc_add_omp_declare_target_link (&s->attr, s->name,
 						     &s->declared_at);
 		}
+	      if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
+		  && s->attr.omp_device_type != c->device_type)
+		gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
+			       " TARGET directive to a different DEVICE_TYPE",
+			       s->name, &n->where);
+	      s->attr.omp_device_type = c->device_type;
 	    }
 	}
+  if (c->device_type && !c->lists[OMP_LIST_TO] && !c->lists[OMP_LIST_LINK])
+    gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only "
+			"DEVICE_TYPE clause is ignored", &old_loc);

  gfc_buffer_error (true);

--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@ -426,6 +426,8 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
  /* If there is no backend_decl for the common block, build it.  */
  if (decl == NULL_TREE)
    {
+      tree omp_clauses = NULL_TREE;
+
      if (com->is_bind_c == 1 && com->binding_label)
 	decl = build_decl (input_location, VAR_DECL, identifier, union_type);
      else
@ -460,14 +462,33 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
      if (com->threadprivate)
 	set_decl_tls_model (decl, decl_default_tls_model (decl));

+      if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET)
+	{
+	  tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
+	  switch (com->omp_device_type)
+	    {
+	    case OMP_DEVICE_TYPE_HOST:
+	      OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
+	      break;
+	    case OMP_DEVICE_TYPE_NOHOST:
+	      OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
+	      break;
+	    case OMP_DEVICE_TYPE_ANY:
+	      OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
+	      break;
+	    default:
+	      gcc_unreachable ();
+	    }
+	  omp_clauses = c;
+	}
      if (com->omp_declare_target_link)
 	DECL_ATTRIBUTES (decl)
 	  = tree_cons (get_identifier ("omp declare target link"),
-		       NULL_TREE, DECL_ATTRIBUTES (decl));
+		       omp_clauses, DECL_ATTRIBUTES (decl));
      else if (com->omp_declare_target)
 	DECL_ATTRIBUTES (decl)
 	  = tree_cons (get_identifier ("omp declare target"),
-		       NULL_TREE, DECL_ATTRIBUTES (decl));
+		       omp_clauses, DECL_ATTRIBUTES (decl));

      /* Place the back end declaration for this common block in
         GLOBAL_BINDING_LEVEL.  */
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@ -1465,11 +1465,31 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
      tree dims = oacc_build_routine_dims (clauses);
      list = oacc_replace_fn_attrib_attr (list, dims);
    }
+  if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET)
+    {
+      tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
+      switch (sym_attr.omp_device_type)
+	{
+	case OMP_DEVICE_TYPE_HOST:
+	  OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
+	  break;
+	case OMP_DEVICE_TYPE_NOHOST:
+	  OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
+	  break;
+	case OMP_DEVICE_TYPE_ANY:
+	  OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      OMP_CLAUSE_CHAIN (c) = clauses;
+      clauses = c;
+    }

  if (sym_attr.omp_declare_target_link
      || sym_attr.oacc_declare_link)
    list = tree_cons (get_identifier ("omp declare target link"),
-		      NULL_TREE, list);
+		      clauses, list);
  else if (sym_attr.omp_declare_target
 	   || sym_attr.oacc_declare_create
 	   || sym_attr.oacc_declare_copyin
--- a/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90
@ -0,0 +1,81 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+
+subroutine f1
+  !$omp declare target device_type (any)  ! { dg-warning "OMP DECLARE TARGET directive at .1. with only DEVICE_TYPE clause is ignored" }
+end subroutine
+
+subroutine f2
+  !$omp declare target to (f2) device_type (any)
+end subroutine
+
+subroutine f3
+  !$omp declare target device_type (any) to (f3)
+end subroutine
+
+subroutine f4
+  !$omp declare target device_type (host) to (f4)
+end subroutine
+
+subroutine f5
+  !$omp declare target device_type (nohost) to (f5)
+end subroutine
+
+module mymod
+  ! device_type is ignored for variables in OpenMP 5.0
+  ! but TR8 and later apply those rules to variables as well
+  implicit none
+  integer :: a, b(4), c, d
+  integer :: e, f, g
+  integer :: m, n, o, p, q, r, s, t, u, v, w, x
+  common /block1/ m, n
+  common /block2/ o, p
+  common /block3/ q, r
+  common /block4/ s, t
+  common /block5/ u, v
+  common /block6/ w, x
+
+  !$omp declare target to(a) device_type(nohost)
+  !$omp declare target to(b) device_type(host)
+  !$omp declare target to(c) device_type(any)
+ ! Fails in ME with "Error: wrong number of arguments specified for 'omp declare target link' attribute"
+ ! !$omp declare target link(e) device_type(nohost)
+ ! !$omp declare target link(f) device_type(host)
+ ! !$omp declare target link(g) device_type(any)
+
+  !$omp declare target to(/block1/) device_type(nohost)
+  !$omp declare target to(/block2/) device_type(host)
+  !$omp declare target to(/block3/) device_type(any)
+  !$omp declare target link(/block4/) device_type(nohost)
+  !$omp declare target link(/block5/) device_type(host)
+  !$omp declare target link(/block6/) device_type(any)
+contains
+  subroutine s1
+    !$omp declare target to (s1) device_type (any)
+  end
+  subroutine s2
+    !$omp declare target to (s2) device_type (nohost)
+  end
+  subroutine s3
+    !$omp declare target to (s3) device_type (host)
+  end
+end module
+
+module m2
+  use mymod
+  implicit none
+  public
+  private :: s1, s2, s3, a, b, c, d, e, f, g
+  public :: m, n, o, p, q, r, s, t, u, v, w, x
+end module m2
+
+! { dg-final { scan-tree-dump-times "omp declare target" 7 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(" 7 "original" } }
+! { dg-final { scan-tree-dump-times "\[\n\r]\[\n\r]f1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]f2" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]f3" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(host\\)\\)\\)\\)\[\n\r]f4" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(nohost\\)\\)\\)\\)\[\n\r]f5" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]s1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(nohost\\)\\)\\)\\)\[\n\r]s2" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(host\\)\\)\\)\\)\[\n\r]s3" 1 "original" } }
--- a/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90
@ -0,0 +1,63 @@
+subroutine foo()
+  !$omp declare target  to(foo) device_type(bar)  ! { dg-error "Expected HOST, NOHOST or ANY" }
+end
+
+subroutine bar()
+  !$omp declare target  to(bar) device_type(nohost)
+  !$omp declare target  to(bar) device_type(host)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+end
+
+module mymod_one
+  implicit none
+  integer :: a, b, c, d, e ,f
+  integer :: m, n, o, p, q, r
+  common /block1/ m, n
+  common /block2/ o, p
+  common /block3/ q, r
+  !$omp declare target  to(a) device_type(nohost)
+  !$omp declare target  to(b) device_type(any)
+  !$omp declare target  to(c) device_type(host)
+  !$omp declare target  link(d) device_type(nohost)
+  !$omp declare target  link(e) device_type(any)
+  !$omp declare target  link(f) device_type(host)
+
+  !$omp declare target  to(c) device_type(host)
+  !$omp declare target  link(d) device_type(nohost)
+end module
+
+module mtest
+  use mymod_one ! { dg-error "Cannot change attributes of USE-associated symbol" }
+  implicit none
+
+  !$omp declare target  to(a) device_type(any)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  to(b) device_type(host)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  to(c) device_type(nohost)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  link(d) device_type(host)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  link(e) device_type(nohost)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  link(f) device_type(any)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+end module
+
+module mymod
+  implicit none
+  integer :: a, b, c, d, e ,f
+  integer :: m, n, o, p, q, r
+  common /block1/ m, n
+  common /block2/ o, p
+  common /block3/ q, r
+  !$omp declare target  to(a) device_type(nohost)
+  !$omp declare target  to(b) device_type(any)
+  !$omp declare target  to(c) device_type(host)
+  !$omp declare target  link(d) device_type(nohost)
+  !$omp declare target  link(e) device_type(any)
+  !$omp declare target  link(f) device_type(host)
+
+  !$omp declare target  to(c) device_type(host)
+  !$omp declare target  link(d) device_type(nohost)
+
+  !$omp declare target  to(a) device_type(any)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  to(b) device_type(host)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  to(c) device_type(nohost)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  link(d) device_type(host)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  link(e) device_type(nohost)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+  !$omp declare target  link(f) device_type(any)  ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+end