[PATCH 5/5] [gfortran] Lower allocate directive (OpenMP 5.0).

[Hafiz Abid Qadeer <abidh@codesourcery.com>]

This patch looks for malloc/free calls that were generated by allocate statement
that is associated with allocate directive and replaces them with GOMP_alloc
and GOMP_free.

gcc/ChangeLog:

	* omp-low.c (scan_sharing_clauses): Handle OMP_CLAUSE_ALLOCATOR.
	(scan_omp_allocate): New.
	(scan_omp_1_stmt): Call it.
	(lower_omp_allocate): New function.
	(lower_omp_1): Call it.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/allocate-6.f90: Add tests.

libgomp/ChangeLog:

	* testsuite/libgomp.fortran/allocate-1.c: New test.
	* testsuite/libgomp.fortran/allocate-2.f90: New test.
---
 gcc/omp-low.c                                 | 125 ++++++++++++++++++
 gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 |   9 ++
 .../testsuite/libgomp.fortran/allocate-1.c    |   7 +
 .../testsuite/libgomp.fortran/allocate-2.f90  |  49 +++++++
 4 files changed, 190 insertions(+)
 create mode 100644 libgomp/testsuite/libgomp.fortran/allocate-1.c
 create mode 100644 libgomp/testsuite/libgomp.fortran/allocate-2.f90

diff --git a/gcc/omp-low.c b/gcc/omp-low.c
index f2237428de1..8a0ae3932b9 100644
--- a/gcc/omp-low.c
+++ b/gcc/omp-low.c
@@ -1684,6 +1684,7 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
 	case OMP_CLAUSE_FINALIZE:
 	case OMP_CLAUSE_TASK_REDUCTION:
 	case OMP_CLAUSE_ALLOCATE:
+	case OMP_CLAUSE_ALLOCATOR:
 	  break;
 
 	case OMP_CLAUSE_ALIGNED:
@@ -1892,6 +1893,7 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
 	case OMP_CLAUSE_FINALIZE:
 	case OMP_CLAUSE_FILTER:
 	case OMP_CLAUSE__CONDTEMP_:
+	case OMP_CLAUSE_ALLOCATOR:
 	  break;
 
 	case OMP_CLAUSE__CACHE_:
@@ -2962,6 +2964,16 @@ scan_omp_simd_scan (gimple_stmt_iterator *gsi, gomp_for *stmt,
   maybe_lookup_ctx (new_stmt)->for_simd_scan_phase = true;
 }
 
+/* Scan an OpenMP allocate directive.  */
+
+static void
+scan_omp_allocate (gomp_allocate *stmt, omp_context *outer_ctx)
+{
+  omp_context *ctx;
+  ctx = new_omp_context (stmt, outer_ctx);
+  scan_sharing_clauses (gimple_omp_allocate_clauses (stmt), ctx);
+}
+
 /* Scan an OpenMP sections directive.  */
 
 static void
@@ -4247,6 +4259,9 @@ scan_omp_1_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p,
 	    insert_decl_map (&ctx->cb, var, var);
       }
       break;
+    case GIMPLE_OMP_ALLOCATE:
+      scan_omp_allocate (as_a <gomp_allocate *> (stmt), ctx);
+      break;
     default:
       *handled_ops_p = false;
       break;
@@ -8680,6 +8695,111 @@ lower_omp_single_simple (gomp_single *single_stmt, gimple_seq *pre_p)
   gimple_seq_add_stmt (pre_p, gimple_build_label (flabel));
 }
 
+static void
+lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *)
+{
+  gomp_allocate *st = as_a <gomp_allocate *> (gsi_stmt (*gsi_p));
+  tree clauses = gimple_omp_allocate_clauses (st);
+  int kind = gimple_omp_allocate_kind (st);
+  gcc_assert (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE
+	      || kind == GF_OMP_ALLOCATE_KIND_FREE);
+  bool allocate = (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE);
+
+  for (tree c = clauses; c; c = OMP_CLAUSE_CHAIN (c))
+    {
+      if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_ALLOCATOR)
+	continue;
+      tree var = OMP_ALLOCATE_DECL (c);
+
+      gimple_stmt_iterator gsi = *gsi_p;
+      for (gsi_next (&gsi); !gsi_end_p (gsi); gsi_next (&gsi))
+	{
+	  gimple *stmt = gsi_stmt (gsi);
+
+	  if (gimple_code (stmt) != GIMPLE_CALL
+	      || (allocate && gimple_call_fndecl (stmt)
+		  != builtin_decl_explicit (BUILT_IN_MALLOC))
+	      || (!allocate && gimple_call_fndecl (stmt)
+		  != builtin_decl_explicit (BUILT_IN_FREE)))
+	    continue;
+	  const gcall *gs = as_a <const gcall *> (stmt);
+	  tree allocator = OMP_ALLOCATE_ALLOCATOR (c)
+			   ? OMP_ALLOCATE_ALLOCATOR (c)
+			   : integer_zero_node;
+	  if (allocate)
+	    {
+	      tree lhs = gimple_call_lhs (gs);
+	      if (lhs && TREE_CODE (lhs) == SSA_NAME)
+		{
+		  gimple_stmt_iterator gsi2 = gsi;
+		  gsi_next (&gsi2);
+		  gimple *assign = gsi_stmt (gsi2);
+		  if (gimple_code (assign) == GIMPLE_ASSIGN)
+		    {
+		      lhs = gimple_assign_lhs (as_a <const gassign *> (assign));
+		      if (lhs == NULL_TREE
+			  || TREE_CODE (lhs) != COMPONENT_REF)
+			continue;
+		      lhs = TREE_OPERAND (lhs, 0);
+		    }
+		}
+
+	      if (lhs == var)
+		{
+		  unsigned HOST_WIDE_INT ialign = 0;
+		  tree align;
+		  if (TYPE_P (var))
+		    ialign = TYPE_ALIGN_UNIT (var);
+		  else
+		    ialign = DECL_ALIGN_UNIT (var);
+		  align = build_int_cst (size_type_node, ialign);
+		  tree repl = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
+		  tree size = gimple_call_arg (gs, 0);
+		  gimple *g = gimple_build_call (repl, 3, align, size,
+						 allocator);
+		  gimple_call_set_lhs (g, gimple_call_lhs (gs));
+		  gimple_set_location (g, gimple_location (stmt));
+		  gsi_replace (&gsi, g, true);
+		}
+	    }
+	  else
+	    {
+	      tree arg = gimple_call_arg (gs, 0);
+	      if (arg && TREE_CODE (arg) == SSA_NAME)
+		{
+		  gimple_stmt_iterator gsi2 = gsi;
+		  gsi_prev (&gsi2);
+		  if (!gsi_end_p (gsi2))
+		    {
+		      gimple *gs = gsi_stmt (gsi2);
+		      if (gimple_code (gs) == GIMPLE_ASSIGN)
+			{
+			  const gassign *assign = as_a <const gassign *> (gs);
+			  tree rhs = gimple_assign_rhs1 (assign);
+			  tree lhs = gimple_assign_lhs (assign);
+			  if (lhs == arg && rhs
+			      && TREE_CODE (rhs) == COMPONENT_REF)
+			      arg = TREE_OPERAND (rhs, 0);
+			}
+		    }
+		}
+
+	      if (arg == var)
+		{
+		  tree repl = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
+		  gimple *g = gimple_build_call (repl, 2,
+						 gimple_call_arg (gs, 0),
+						 allocator);
+		  gimple_set_location (g, gimple_location (stmt));
+		  gsi_replace (&gsi, g, true);
+		  break;
+		}
+	    }
+	}
+    }
+  gsi_replace (gsi_p, gimple_build_nop (), true);
+}
+
 
 /* A subroutine of lower_omp_single.  Expand the simple form of
    a GIMPLE_OMP_SINGLE, with a copyprivate clause:
@@ -14179,6 +14299,11 @@ lower_omp_1 (gimple_stmt_iterator *gsi_p, omp_context *ctx)
       gcc_assert (ctx);
       lower_omp_scope (gsi_p, ctx);
       break;
+    case GIMPLE_OMP_ALLOCATE:
+      ctx = maybe_lookup_ctx (stmt);
+      gcc_assert (ctx);
+      lower_omp_allocate (gsi_p, ctx);
+      break;
     case GIMPLE_OMP_SINGLE:
       ctx = maybe_lookup_ctx (stmt);
       gcc_assert (ctx);
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
index 6957bc55da0..738d9936f6a 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
@@ -1,5 +1,6 @@
 ! { dg-do compile }
 ! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" }
+! { dg-additional-options "-fdump-tree-omplower" }
 
 module omp_lib_kinds
   use iso_c_binding, only: c_int, c_intptr_t
@@ -47,6 +48,7 @@ end type
   real, allocatable :: var3(:,:)
   type (my_type), allocatable :: var4
   integer, pointer :: pii, parr(:)
+  integer, allocatable :: var
 
   character, allocatable :: str1a, str1aarr(:) 
   character(len=5), allocatable :: str5a, str5aarr(:)
@@ -67,9 +69,16 @@ end type
 
   !$omp allocate
   allocate(pii, parr(5))
+
+  ! allocate statement not associated with an allocate directive
+  allocate(var)
 end subroutine
 
 ! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "original" } }
 ! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "original" } }
 ! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "gimple" } }
 ! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "gimple" } }
+! { dg-final { scan-tree-dump-times "builtin_malloc" 11 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 9 "original" } }
+! { dg-final { scan-tree-dump-times "GOMP_alloc" 10 "omplower" } }
+! { dg-final { scan-tree-dump-times "GOMP_free" 8 "omplower" } }
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-1.c b/libgomp/testsuite/libgomp.fortran/allocate-1.c
new file mode 100644
index 00000000000..d33acc6feef
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-1.c
@@ -0,0 +1,7 @@
+#include <stdint.h>
+
+int
+is_64bit_aligned_ (uintptr_t a)
+{
+  return ( (a & 0x3f) == 0);
+}
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-2.f90 b/libgomp/testsuite/libgomp.fortran/allocate-2.f90
new file mode 100644
index 00000000000..8678c53a34c
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-2.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+! { dg-additional-sources allocate-1.c }
+! { dg-prune-output "command-line option '-fintrinsic-modules-path=.*' is valid for Fortran but not for C" }
+
+module m
+  use omp_lib
+  use iso_c_binding
+  implicit none
+  interface
+    integer(c_int) function is_64bit_aligned (a) bind(C)
+      import :: c_int
+      integer  :: a
+    end
+  end interface
+end module m
+
+subroutine foo (x, y, h)
+  use omp_lib
+  !use iso_c_binding
+  integer  :: x
+  integer  :: y
+  integer (kind=omp_allocator_handle_kind) :: h
+  integer, allocatable :: var1
+  !integer, allocatable :: var2(:)
+
+  !$omp allocate (var1)  allocator(h)
+  allocate (var1)
+
+  !y = 1
+  if (is_64bit_aligned(var1) == 0) then
+    stop 19
+  end if
+
+end subroutine
+
+program main
+  use omp_lib
+  type (omp_alloctrait) :: traits(3)
+  integer (omp_allocator_handle_kind) :: a
+
+  traits = [omp_alloctrait (omp_atk_alignment, 64), &
+            omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), &
+            omp_alloctrait (omp_atk_pool_size, 8192)]
+  a = omp_init_allocator (omp_default_mem_space, 3, traits)
+  if (a == omp_null_allocator) stop 1
+  !call omp_set_default_allocator (omp_default_mem_alloc);
+  call foo (42, 12, a);
+  call omp_destroy_allocator (a);
+end
-- 
2.25.1