Fortran/OpenMP: align/allocator modifiers to the allocate clause

gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (show_omp_namelist): Improve OMP_LIST_ALLOCATE
	output.
	* gfortran.h (struct gfc_omp_namelist): Add 'align' to 'u'.
	(gfc_free_omp_namelist): Add bool arg.
	* match.cc (gfc_free_omp_namelist): Likewise; free 'u.align'.
	* openmp.cc (gfc_free_omp_clauses, gfc_match_omp_clause_reduction,
	gfc_match_omp_flush): Update call.
	(gfc_match_omp_clauses): Match 'align/allocate modifers in
	'allocate' clause.
	(resolve_omp_clauses): Resolve align.
	* st.cc (gfc_free_statement): Update call
	* trans-openmp.cc (gfc_trans_omp_clauses): Handle 'align'.

libgomp/ChangeLog:

	* libgomp.texi (5.1 Impl. Status): Split allocate clause/directive
	item about 'align'; mark clause as 'Y' and directive as 'N'.
	* testsuite/libgomp.fortran/allocate-2.f90: New test.
	* testsuite/libgomp.fortran/allocate-3.f90: New test.

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 2f042ab..5ae72dc 100644 (file)
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -1357,6 +1357,29 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
            }
          ns_iter = n->u2.ns;
        }
+      if (list_type == OMP_LIST_ALLOCATE)
+       {
+         if (n->expr)
+           {
+             fputs ("allocator(", dumpfile);
+             show_expr (n->expr);
+             fputc (')', dumpfile);
+           }
+         if (n->expr && n->u.align)
+           fputc (',', dumpfile);
+         if (n->u.align)
+           {
+             fputs ("allocator(", dumpfile);
+             show_expr (n->u.align);
+             fputc (')', dumpfile);
+           }
+         if (n->expr || n->u.align)
+           fputc (':', dumpfile);
+         fputs (n->sym->name, dumpfile);
+         if (n->next)
+           fputs (") ALLOCATE(", dumpfile);
+         continue;
+       }
       if (list_type == OMP_LIST_REDUCTION)
        switch (n->u.reduction_op)
          {

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b541a07..5f8a81a 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1349,6 +1349,7 @@ typedef struct gfc_omp_namelist
       gfc_omp_reduction_op reduction_op;
       gfc_omp_depend_doacross_op depend_doacross_op;
       gfc_omp_map_op map_op;
+      gfc_expr *align;
       struct
        {
          ENUM_BITFIELD (gfc_omp_linear_op) op:4;
@@ -3572,7 +3573,7 @@ void gfc_free_iterator (gfc_iterator *, int);
 void gfc_free_forall_iterator (gfc_forall_iterator *);
 void gfc_free_alloc_list (gfc_alloc *);
 void gfc_free_namelist (gfc_namelist *);
-void gfc_free_omp_namelist (gfc_omp_namelist *, bool);
+void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool);
 void gfc_free_equiv (gfc_equiv *);
 void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *);
 void gfc_free_data (gfc_data *);

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 8b8b6e7..7ba0f34 100644 (file)
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5524,13 +5524,15 @@ gfc_free_namelist (gfc_namelist *name)
 /* Free an OpenMP namelist structure.  */
 
 void
-gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns)
+gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align)
 {
   gfc_omp_namelist *n;
 
   for (; name; name = n)
     {
       gfc_free_expr (name->expr);
+      if (free_align)
+       gfc_free_expr (name->u.align);
       if (free_ns)
        gfc_free_namespace (name->u2.ns);
       else if (name->u2.udr)

diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 862c649..4b4e6ac 100644 (file)
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -187,7 +187,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
   gfc_free_expr (c->vector_length_expr);
   for (i = 0; i < OMP_LIST_NUM; i++)
     gfc_free_omp_namelist (c->lists[i],
-                          i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND);
+                          i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
+                          i == OMP_LIST_ALLOCATE);
   gfc_free_expr_list (c->wait_list);
   gfc_free_expr_list (c->tile_list);
   free (CONST_CAST (char *, c->critical_name));
@@ -542,7 +543,7 @@ syntax:
   gfc_error ("Syntax error in OpenMP variable list at %C");
 
 cleanup:
-  gfc_free_omp_namelist (head, false);
+  gfc_free_omp_namelist (head, false, false);
   gfc_current_locus = old_loc;
   return MATCH_ERROR;
 }
@@ -632,7 +633,7 @@ syntax:
   gfc_error ("Syntax error in OpenMP variable list at %C");
 
 cleanup:
-  gfc_free_omp_namelist (head, false);
+  gfc_free_omp_namelist (head, false, false);
   gfc_current_locus = old_loc;
   return MATCH_ERROR;
 }
@@ -741,7 +742,7 @@ syntax:
   gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
 
 cleanup:
-  gfc_free_omp_namelist (head, false);
+  gfc_free_omp_namelist (head, false, false);
   gfc_current_locus = old_loc;
   return MATCH_ERROR;
 }
@@ -1467,7 +1468,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
       *head = NULL;
       gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
                     buffer, &old_loc);
-      gfc_free_omp_namelist (n, false);
+      gfc_free_omp_namelist (n, false, false);
     }
   else
     for (n = *head; n; n = n->next)
@@ -1785,7 +1786,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 
              if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
                {
-                 gfc_free_omp_namelist (*head, false);
+                 gfc_free_omp_namelist (*head, false, false);
                  gfc_current_locus = old_loc;
                  *head = NULL;
                  break;
@@ -1853,17 +1854,33 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
              && gfc_match ("allocate ( ") == MATCH_YES)
            {
              gfc_expr *allocator = NULL;
+             gfc_expr *align = NULL;
              old_loc = gfc_current_locus;
-             m = gfc_match_expr (&allocator);
-             if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
+             if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
+               gfc_match (" , align ( %e )", &align);
+             else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
+               gfc_match (" , allocator ( %e )", &allocator);
+
+             if (m == MATCH_YES)
                {
-                 /* If no ":" then there is no allocator, we backtrack
-                    and read the variable list.  */
-                 gfc_free_expr (allocator);
-                 allocator = NULL;
-                 gfc_current_locus = old_loc;
+                 if (gfc_match (" : ") != MATCH_YES)
+                   {
+                     gfc_error ("Expected %<:%> at %C");
+                     goto error;
+                   }
+               }
+             else
+               {
+                 m = gfc_match_expr (&allocator);
+                 if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
+                   {
+                      /* If no ":" then there is no allocator, we backtrack
+                         and read the variable list.  */
+                     gfc_free_expr (allocator);
+                     allocator = NULL;
+                     gfc_current_locus = old_loc;
+                   }
                }
-
              gfc_omp_namelist **head = NULL;
              m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
                                               true, NULL, &head);
@@ -1871,16 +1888,18 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
              if (m != MATCH_YES)
                {
                  gfc_free_expr (allocator);
+                 gfc_free_expr (align);
                  gfc_error ("Expected variable list at %C");
                  goto error;
                }
 
              for (gfc_omp_namelist *n = *head; n; n = n->next)
-               if (allocator)
-                 n->expr = gfc_copy_expr (allocator);
-               else
-                 n->expr = NULL;
+               {
+                 n->expr = (allocator) ? gfc_copy_expr (allocator) : NULL;
+                 n->u.align = (align) ? gfc_copy_expr (align) : NULL;
+               }
              gfc_free_expr (allocator);
+             gfc_free_expr (align);
              continue;
            }
          if ((mask & OMP_CLAUSE_AT)
@@ -2709,7 +2728,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
                    end_colon = true;
                  else if (gfc_match (" )") != MATCH_YES)
                    {
-                     gfc_free_omp_namelist (*head, false);
+                     gfc_free_omp_namelist (*head, false, false);
                      gfc_current_locus = old_loc;
                      *head = NULL;
                      break;
@@ -2720,7 +2739,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
                {
                  if (gfc_match (" %e )", &step) != MATCH_YES)
                    {
-                     gfc_free_omp_namelist (*head, false);
+                     gfc_free_omp_namelist (*head, false, false);
                      gfc_current_locus = old_loc;
                      *head = NULL;
                      goto error;
@@ -2817,7 +2836,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
                    }
                  if (has_error)
                    {
-                     gfc_free_omp_namelist (*head, false);
+                     gfc_free_omp_namelist (*head, false, false);
                      *head = NULL;
                      goto error;
                    }
@@ -4627,14 +4646,14 @@ gfc_match_omp_flush (void)
     {
       gfc_error ("List specified together with memory order clause in FLUSH "
                 "directive at %C");
-      gfc_free_omp_namelist (list, false);
+      gfc_free_omp_namelist (list, false, false);
       gfc_free_omp_clauses (c);
       return MATCH_ERROR;
     }
   if (gfc_match_omp_eos () != MATCH_YES)
     {
       gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
-      gfc_free_omp_namelist (list, false);
+      gfc_free_omp_namelist (list, false, false);
       gfc_free_omp_clauses (c);
       return MATCH_ERROR;
     }
@@ -7279,19 +7298,36 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
   if (omp_clauses->lists[OMP_LIST_ALLOCATE])
     {
       for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
-       if (n->expr && (n->expr->ts.type != BT_INTEGER
-           || n->expr->ts.kind != gfc_c_intptr_kind))
-         {
-           gfc_error ("Expected integer expression of the "
-                      "'omp_allocator_handle_kind' kind at %L",
-                      &n->expr->where);
-           break;
-         }
+       {
+         if (n->expr && (!gfc_resolve_expr (n->expr)
+                         || n->expr->ts.type != BT_INTEGER
+                         || n->expr->ts.kind != gfc_c_intptr_kind))
+           {
+             gfc_error ("Expected integer expression of the "
+                        "%<omp_allocator_handle_kind%> kind at %L",
+                        &n->expr->where);
+             break;
+           }
+         if (!n->u.align)
+           continue;
+         int alignment = 0;
+         if (!gfc_resolve_expr (n->u.align)
+             || n->u.align->ts.type != BT_INTEGER
+             || n->u.align->rank != 0
+             || gfc_extract_int (n->u.align, &alignment)
+             || alignment <= 0)
+           {
+             gfc_error ("ALIGN modifier requires a scalar positive "
+                        "constant integer alignment expression at %L",
+                        &n->u.align->where);
+             break;
+           }
+       }
 
       /* Check for 2 things here.
-     1.  There is no duplication of variable in allocate clause.
-     2.  Variable in allocate clause are also present in some
-        privatization clase (non-composite case).  */
+        1.  There is no duplication of variable in allocate clause.
+        2.  Variable in allocate clause are also present in some
+            privatization clase (non-composite case).  */
       for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
        n->sym->mark = 0;
 
@@ -7308,7 +7344,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
                {
                  prev->next = n->next;
                  n->next = NULL;
-                 gfc_free_omp_namelist (n, 0);
+                 gfc_free_omp_namelist (n, false, true);
                  n = prev->next;
                }
              continue;

diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 3c8ca66..8b4ca5e 100644 (file)
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -286,7 +286,7 @@ gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_OMP_FLUSH:
-      gfc_free_omp_namelist (p->ext.omp_namelist, false);
+      gfc_free_omp_namelist (p->ext.omp_namelist, false, false);
       break;
 
     case EXEC_OMP_BARRIER:

diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 9070c03..7a4a339 100644 (file)
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2724,6 +2724,14 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
                        allocator_ = gfc_evaluate_now (se.expr, block);
                        OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
                      }
+                   if (n->u.align)
+                     {
+                       tree align_;
+                       gfc_init_se (&se, NULL);
+                       gfc_conv_expr (&se, n->u.align);
+                       align_ = gfc_evaluate_now (se.expr, block);
+                       OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
+                     }
                    omp_clauses = gfc_trans_add_clause (node, omp_clauses);
                  }
              }

diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi
index e8798a0..b6c1ed7 100644 (file)
--- a/libgomp/libgomp.texi
+++ b/libgomp/libgomp.texi
@@ -296,8 +296,8 @@ The OpenMP 4.5 specification is fully supported.
 @item Loop transformation constructs @tab N @tab
 @item @code{strict} modifier in the @code{grainsize} and @code{num_tasks}
       clauses of the @code{taskloop} construct @tab Y @tab
-@item @code{align} clause/modifier in @code{allocate} directive/clause
-      and @code{allocator} directive @tab P @tab C/C++ on clause only
+@item @code{align} clause in @code{allocate} directive @tab N @tab
+@item @code{align} modifier in @code{allocate} clause @tab Y @tab
 @item @code{thread_limit} clause to @code{target} construct @tab Y @tab
 @item @code{has_device_addr} clause to @code{target} construct @tab Y @tab
 @item Iterators in @code{target update} motion clauses and @code{map}

diff --git a/libgomp/testsuite/libgomp.fortran/allocate-2.f90 b/libgomp/testsuite/libgomp.fortran/allocate-2.f90
new file mode 100644 (file)
index 0000000..347656a
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-2.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+
+use omp_lib
+implicit none
+integer :: q, x,y,z
+
+!$omp parallel  &
+!$omp&   allocate(omp_low_lat_mem_alloc : x) &
+!$omp&   allocate(omp_cgroup_mem_alloc : y) &
+!$omp&   allocate(omp_pteam_mem_alloc : z) &
+!$omp&   firstprivate(q, x,y,z)
+!$omp end parallel
+
+!$omp parallel &
+!$omp&   allocate(align ( 64 ), allocator(omp_default_mem_alloc) : x) &
+!$omp&   allocate(allocator(omp_large_cap_mem_alloc) : y) &
+!$omp&   allocate(allocator ( omp_high_bw_mem_alloc ) , align ( 32 ) : z) &
+!$omp&   allocate(align (16 ): q) &
+!$omp&   firstprivate(q, x,y,z)
+!$omp end parallel
+end
+
+! { dg-final { scan-tree-dump-times "#pragma omp parallel firstprivate\\(q\\) firstprivate\\(x\\) firstprivate\\(y\\) firstprivate\\(z\\) allocate\\(allocator\\(5\\):x\\) allocate\\(allocator\\(6\\):y\\) allocate\\(allocator\\(7\\):z\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp parallel firstprivate\\(q\\) firstprivate\\(x\\) firstprivate\\(y\\) firstprivate\\(z\\) allocate\\(allocator\\(1\\),align\\(64\\):x\\) allocate\\(allocator\\(2\\):y\\) allocate\\(allocator\\(4\\),align\\(32\\):z\\) allocate\\(align\\(16\\):q\\)" 1 "original" } }

diff --git a/libgomp/testsuite/libgomp.fortran/allocate-3.f90 b/libgomp/testsuite/libgomp.fortran/allocate-3.f90
new file mode 100644 (file)
index 0000000..a398191
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-3.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+
+use omp_lib
+implicit none
+integer :: q, x,y,z
+
+!$omp parallel allocate(align ( 64 ) x)  ! { dg-error "37:Expected ':' at" }
+!$omp parallel allocate(align ( 64 ), x)  ! { dg-error "37:Expected ':' at" }
+!$omp parallel allocate(allocator ( omp_high_bw_mem_alloc ) x)  ! { dg-error "60:Expected ':' at" }
+!$omp parallel allocate(allocator ( omp_high_bw_mem_alloc ) , x)  ! { dg-error "60:Expected ':' at" }
+
+!$omp parallel allocate( omp_high_bw_mem_alloc, align(12) : x)  ! { dg-error "26:Expected variable list at" }
+!$omp parallel allocate( align(12), omp_high_bw_mem_alloc : x)  ! { dg-error "35:Expected ':' at" }
+
+!$omp parallel allocate( omp_high_bw_mem_alloc x)  ! { dg-error "26:Expected variable list at" }
+
+!$omp parallel allocate( omp_high_bw_mem_alloc , x) firstprivate(x) ! { dg-error "'omp_high_bw_mem_alloc' specified in 'allocate' clause at \\(1\\) but not in an explicit privatization clause" }
+! { dg-error "Object 'omp_high_bw_mem_alloc' is not a variable" "" { target *-*-* } .-1 }
+!$omp end parallel
+
+!$omp parallel allocate( omp_high_bw_mem_alloc , x) firstprivate(x, omp_high_bw_mem_alloc)
+! { dg-error "Object 'omp_high_bw_mem_alloc' is not a variable" "" { target *-*-* } .-1 }
+!$omp end parallel
+
+!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires a scalar positive constant integer alignment expression at" }
+!$omp end parallel
+end