Nonallocatable, nonpointer array arguments (of assumed shape) are special as they get a get an array descriptor ('arg') as argument but create a local variable which accesses the actual data ('arg.0 = arg->data').
With OPTIONAL, there are/were two outstanding issues:
(A) If the argument is not present, 'arg.0' is/was never assigned to.

(B) The optional-arg-is-present check is not just 'if (arg)' but 'if (arg && arg->data)' as passing an unallocated allocatable/disassociated pointer (i.e. 'arg->data = NULL') to a nonpointer, nonallocatable optional dummy argument counts as absent argument; this affects (A).
Solution:

(B) is now solved by updating what gfc_omp_check_optional_argument returns; as is now always returns an boolean_type_node, one can clean up the code which adds "!= NULL" when using the "present" tree variable.
(A) For mapping, one also does GOMP_MAP_POINTER; if one replaces this by 
a temporary variable 'D.124 = present ? arg.0 : NULL', it will later ICE 
in omp-low.c one confuses the identifier handling, which replaces the 
variables in 'target (data)'.
Build on x86-64-gnu-linux w/o offloading and on one nvptx configuration 
with actual offloading.
OK?

Tobias

PS: Besides adding tons of test cases, it also fixes the transient issue (which does only occur with -O1 ?!?) with the existing use_device_addr-{3,4}.f90 test case. That failed due to reason (A). – Cf. https://gcc.gnu.org/ml/gcc-patches/2019-12/msg00499.html
PPS: I haven't tried polymorphic data types but I am positive they will 
fail. Cray pointers are also candidates for additional failures.
2019-12-10  Tobias Burnus  <tob...@codesourcery.com>

	gcc/fortran/
	* trans-openmp.c (gfc_omp_check_optional_argument): Always return a
	Boolean expression; handle unallocated/disassociated actual arguments
	as absent if passed to nonallocatable/nonpointer dummy array arguments.
	(gfc_build_cond_assign): Change to assume a Boolean expr not a pointer.
	(gfc_omp_finish_clause, gfc_trans_omp_clauses): Assign NULL to generated
	array-data variable if the argument is absent. Simplify code as
	'present' is now a Boolean expression.

	libgomp/
	* testsuite/libgomp.fortran/optional-map.f90: Add test for
	unallocated/disassociated actual arguments to nonallocatable/nonpointer
	dummy arguments; those are/shall be regarded as absent arguments.
	* testsuite/libgomp.fortran/use_device_ptr-optional-2.f90: Ditto.
	* testsuite/libgomp.fortran/use_device_ptr-optional-3.f90: New.

 gcc/fortran/trans-openmp.c                         | 117 +++++++++++------
 libgomp/testsuite/libgomp.fortran/optional-map.f90 |  13 ++
 .../libgomp.fortran/use_device_ptr-optional-2.f90  |  11 ++
 .../libgomp.fortran/use_device_ptr-optional-3.f90  | 140 +++++++++++++++++++++
 4 files changed, 242 insertions(+), 39 deletions(-)

diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 356fd04e6c3..e46086d3916 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -90,11 +90,16 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check)
   if (!DECL_LANG_SPECIFIC (decl))
     return NULL_TREE;
 
+  bool is_array_type = false;
+
   /* For assumed-shape arrays, a local decl with arg->data is used.  */
   if (TREE_CODE (decl) != PARM_DECL
       && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
 	  || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))))
-    decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+    {
+      is_array_type = true;
+      decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+    }
 
   if (TREE_CODE (decl) != PARM_DECL
       || !DECL_LANG_SPECIFIC (decl)
@@ -126,7 +131,23 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check)
       return decl;
     }
 
-  return decl;
+  tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       decl, null_pointer_node);
+
+  /* Fortran regards unallocated allocatables/disassociated pointer which
+     are passed to a nonallocatable, nonpointer argument as not associated;
+     cf. F2018, 15.5.2.12, Paragraph 1.  */
+  if (is_array_type)
+    {
+      tree cond2 = build_fold_indirect_ref_loc (input_location, decl);
+      cond2 = gfc_conv_array_data (cond2);
+      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       cond2, null_pointer_node);
+      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			      boolean_type_node, cond, cond2);
+    }
+
+  return cond;
 }
 
 
@@ -1189,7 +1210,7 @@ gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val,
 		       tree then_b, tree else_val)
 {
   stmtblock_t cond_block;
-  tree cond, else_b = NULL_TREE;
+  tree else_b = NULL_TREE;
   tree val_ty = TREE_TYPE (val);
 
   if (else_val)
@@ -1198,15 +1219,9 @@ gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val,
       gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val));
       else_b = gfc_finish_block (&cond_block);
     }
-  cond = fold_build2_loc (input_location, NE_EXPR,
-			  logical_type_node,
-			  cond_val, null_pointer_node);
   gfc_add_expr_to_block (block,
-			 build3_loc (input_location,
-				     COND_EXPR,
-				     void_type_node,
-				     cond, then_b,
-				     else_b));
+			 build3_loc (input_location, COND_EXPR, void_type_node,
+				     cond_val, then_b, else_b));
 }
 
 /* Build a conditional expression in BLOCK, returning a temporary
@@ -1257,8 +1272,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
     }
 
   tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
-  tree present = (gfc_omp_is_optional_argument (decl)
-		  ? gfc_omp_check_optional_argument (decl, true) : NULL_TREE);
+  tree present = gfc_omp_check_optional_argument (decl, true);
   if (POINTER_TYPE_P (TREE_TYPE (decl)))
     {
       if (!gfc_omp_privatize_by_reference (decl)
@@ -1268,6 +1282,23 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
 	  && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
 	return;
       tree orig_decl = decl;
+
+      /* For nonallocatable, nonpointer arrays, a temporary variable is
+	 generated, but this one is only defined if the variable is present;
+	 hence, we now set it to NULL to avoid accessing undefined variables.
+	 We cannot use a temporary variable here as otherwise the replacement
+	 of the variables in omp-low.c will not work.  */
+      if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))
+	{
+	  tree tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				      void_type_node, decl, null_pointer_node);
+	  tree cond = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+				       boolean_type_node, present);
+	  tmp = build3_loc (input_location, COND_EXPR, void_type_node,
+			    cond, tmp, NULL_TREE);
+	  gimplify_and_add (tmp, pre_p);
+	}
+
       c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
       OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
       OMP_CLAUSE_DECL (c4) = decl;
@@ -1375,10 +1406,8 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
 				  boolean_type_node, tem, null_pointer_node);
 	  if (present)
 	    {
-	      tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
-				     present, null_pointer_node);
 	      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
-				      boolean_type_node, tem, cond);
+				      boolean_type_node, present, cond);
 	    }
 	  gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
 						     void_type_node, cond,
@@ -2380,9 +2409,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		TREE_ADDRESSABLE (decl) = 1;
 	      if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
 		{
-		  tree present = (gfc_omp_is_optional_argument (decl)
-				  ? gfc_omp_check_optional_argument (decl, true)
-				  : NULL_TREE);
+		  tree present = gfc_omp_check_optional_argument (decl, true);
 		  if (POINTER_TYPE_P (TREE_TYPE (decl))
 		      && (gfc_omp_privatize_by_reference (decl)
 			  || GFC_DECL_GET_SCALAR_POINTER (decl)
@@ -2392,6 +2419,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 					(TREE_TYPE (TREE_TYPE (decl)))))
 		    {
 		      tree orig_decl = decl;
+
+		      /* For nonallocatable, nonpointer arrays, a temporary
+			 variable is generated, but this one is only defined if
+			 the variable is present; hence, we now set it to NULL
+			 to avoid accessing undefined variables.  We cannot use
+			 a temporary variable here as otherwise the replacement
+			 of the variables in omp-low.c will not work.  */
+		      if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))
+			{
+			  tree tmp = fold_build2_loc (input_location,
+						      MODIFY_EXPR,
+						      void_type_node, decl,
+						      null_pointer_node);
+			  tree cond = fold_build1_loc (input_location,
+						       TRUTH_NOT_EXPR,
+						       boolean_type_node,
+						       present);
+			  gfc_add_expr_to_block (block,
+						 build3_loc (input_location,
+							     COND_EXPR,
+							     void_type_node,
+							     cond, tmp,
+							     NULL_TREE));
+			}
 		      node4 = build_omp_clause (input_location,
 						OMP_CLAUSE_MAP);
 		      OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
@@ -2469,17 +2520,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 						  boolean_type_node,
 						  tem, null_pointer_node);
 			  if (present)
-			    {
-			      tree tmp = fold_build2_loc (input_location,
-							  NE_EXPR,
-							  boolean_type_node,
-							  present,
-							  null_pointer_node);
-			      cond = fold_build2_loc (input_location,
-						      TRUTH_ANDIF_EXPR,
-						      boolean_type_node,
-						      tmp, cond);
-			    }
+			    cond = fold_build2_loc (input_location,
+						    TRUTH_ANDIF_EXPR,
+						    boolean_type_node,
+						    present, cond);
 			  gfc_add_expr_to_block (block,
 						 build3_loc (input_location,
 							     COND_EXPR,
@@ -2498,16 +2542,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 			    {
 			      tree var = gfc_create_var (gfc_array_index_type,
 							 NULL);
-			      tree cond = fold_build2_loc (input_location,
-							   NE_EXPR,
-							   boolean_type_node,
-							   present,
-							   null_pointer_node);
 			      gfc_add_modify (&cond_block, var, size);
-			      cond = build3_loc (input_location, COND_EXPR,
-						 void_type_node, cond,
-						 gfc_finish_block (&cond_block),
-						 NULL_TREE);
+			      tree cond_body = gfc_finish_block (&cond_block);
+			      tree cond = build3_loc (input_location, COND_EXPR,
+						      void_type_node, present,
+						      cond_body, NULL_TREE);
 			      gfc_add_expr_to_block (block, cond);
 			      OMP_CLAUSE_SIZE (node) = var;
 			    }
diff --git a/libgomp/testsuite/libgomp.fortran/optional-map.f90 b/libgomp/testsuite/libgomp.fortran/optional-map.f90
index eebe58cc45c..b06efcc90d1 100644
--- a/libgomp/testsuite/libgomp.fortran/optional-map.f90
+++ b/libgomp/testsuite/libgomp.fortran/optional-map.f90
@@ -1,11 +1,24 @@
 ! { dg-do run }
 !
 implicit none (type, external)
+integer, allocatable :: a_ii, a_ival, a_iarr(:)
+integer, pointer :: p_ii, p_ival, p_iarr(:)
+
+nullify (p_ii, p_ival, p_iarr)
+
 call sub()
 call sub2()
 call call_present_1()
 call call_present_2()
 
+! unallocated/disassociated actual arguments to nonallocatable, nonpointer
+! dummy arguments are regarded as absent
+! Skipping 'ival' dummy argument due to PR fortran/92887
+call sub(ii=a_ii, iarr=a_iarr)
+call sub(ii=p_ii, iarr=p_iarr)
+call sub2(ii=a_ii, iarr=a_iarr)
+call sub2(ii=p_ii, iarr=p_iarr)
+
 contains
 
 subroutine call_present_1()
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90 b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90
index d33b7d1cce0..641ebd98962 100644
--- a/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90
+++ b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90
@@ -3,8 +3,19 @@
 program main
  use iso_c_binding, only: c_ptr, c_loc, c_associated
  implicit none (type, external)
+ integer, allocatable :: a_w, a_x(:)
+ integer, pointer :: p_w, p_x(:)
+
+ nullify (p_w, p_x)
  call foo()
+
+ ! unallocated/disassociated actual arguments to nonallocatable, nonpointer
+ ! dummy arguments are regarded as absent
+ call foo (w=a_w, x=a_x)
+ call foo (w=p_w, x=p_x)
+
 contains
+
   subroutine foo(v, w, x, y, z, cptr, cptr_in)
     integer, target, optional, value :: v
     integer, target, optional :: w
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90 b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90
new file mode 100644
index 00000000000..f2e1a60757f
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90
@@ -0,0 +1,140 @@
+! Check whether absent optional arguments are properly
+! handled with use_device_{addr,ptr}.
+program main
+  use iso_c_binding, only: c_ptr, c_loc, c_associated, c_f_pointer
+  implicit none (type, external)
+
+  integer, target :: u
+  integer, target :: v
+  integer, target :: w
+  integer, target :: x(4)
+  integer, target, allocatable :: y
+  integer, target, allocatable :: z(:)
+  type(c_ptr), target :: cptr
+  type(c_ptr), target :: cptr_in
+  integer :: dummy
+
+  u = 42
+  v = 5
+  w = 7
+  x = [3,4,6,2]
+  y = 88
+  z = [1,2,3]
+
+  !$omp target enter data map(to:u)
+  !$omp target data map(to:dummy) use_device_addr(u)
+   cptr_in = c_loc(u) ! Has to be outside 'foo' due to 'intent(in)'
+  !$omp end target data
+
+  call foo (u, v, w, x, y, z, cptr, cptr_in)
+  deallocate (y, z)
+contains
+  subroutine foo (u, v, w, x, y, z, cptr, cptr_in)
+    integer, target, optional, value :: v
+    integer, target, optional :: u, w
+    integer, target, optional :: x(:)
+    integer, target, optional, allocatable :: y
+    integer, target, optional, allocatable :: z(:)
+    type(c_ptr), target, optional, value :: cptr
+    type(c_ptr), target, optional, value, intent(in) :: cptr_in
+    integer :: d
+
+    type(c_ptr) :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in
+
+    !$omp target enter data map(to:w, x, y, z)
+    !$omp target data map(dummy) use_device_addr(x)
+      cptr = c_loc(x)
+    !$omp end target data
+
+    ! Need to map per-VALUE arguments, if present
+    if (present(v)) then
+      !$omp target enter data map(to:v)
+    else
+      stop 1
+    end if
+    if (present(cptr)) then
+      !$omp target enter data map(to:cptr)
+    else
+      stop 2
+    end if
+    if (present(cptr_in)) then
+      !$omp target enter data map(to:cptr_in)
+    else
+      stop 3
+    end if
+
+    !$omp target data map(d) use_device_addr(u, v, w, x, y, z)
+    !$omp target data map(d) use_device_addr(cptr, cptr_in)
+      if (.not. present(u)) stop 10
+      if (.not. present(v)) stop 11
+      if (.not. present(w)) stop 12
+      if (.not. present(x)) stop 13
+      if (.not. present(y)) stop 14
+      if (.not. present(z)) stop 15
+      if (.not. present(cptr)) stop 16
+      if (.not. present(cptr_in)) stop 17
+      p_u = c_loc(u)
+      p_v = c_loc(v)
+      p_w = c_loc(w)
+      p_x = c_loc(x)
+      p_y = c_loc(y)
+      p_z = c_loc(z)
+      p_cptr = c_loc(cptr)
+      p_cptr_in = c_loc(cptr_in)
+    !$omp end target data
+    !$omp end target data
+    call check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, size(x), size(z))
+  end subroutine foo
+
+  subroutine check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, Nx, Nz)
+    type(c_ptr), value :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in
+    integer, value :: Nx, Nz
+    integer, pointer :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:)
+    type(c_ptr), pointer :: c_cptr(:), c_cptr_in(:)
+
+    ! As is_device_ptr does not handle scalars, we map them to a size-1 array
+    call c_f_pointer(p_u, c_u, shape=[1])
+    call c_f_pointer(p_v, c_v, shape=[1])
+    call c_f_pointer(p_w, c_w, shape=[1])
+    call c_f_pointer(p_x, c_x, shape=[Nx])
+    call c_f_pointer(p_y, c_y, shape=[1])
+    call c_f_pointer(p_z, c_z, shape=[Nz])
+    call c_f_pointer(p_cptr, c_cptr, shape=[1])
+    call c_f_pointer(p_cptr_in, c_cptr_in, shape=[1])
+    call run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
+  end subroutine check
+
+  subroutine run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
+    integer, target :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:)
+    type(c_ptr) :: c_cptr(:), c_cptr_in(:)
+    integer, value :: Nx, Nz
+    !$omp target is_device_ptr(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in) map(to:Nx, Nz)
+      call target_fn(c_u(1), c_v(1), c_w(1), c_x, c_y(1), c_z, c_cptr(1), c_cptr_in(1), Nx, Nz)
+    !$omp end target
+  end subroutine run_target
+
+  subroutine target_fn(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
+    !$omp declare target
+    integer, target :: c_u, c_v, c_w, c_x(:), c_y, c_z(:)
+    type(c_ptr), value :: c_cptr, c_cptr_in
+    integer, value :: Nx, Nz
+    integer, pointer :: u, x(:)
+    if (c_u /= 42) stop 30
+    if (c_v /= 5) stop 31
+    if (c_w /= 7) stop 32
+    if (Nx /= 4) stop 33
+    if (any (c_x /= [3,4,6,2])) stop 34
+    if (c_y /= 88) stop 35
+    if (Nz /= 3) stop 36
+    if (any (c_z /= [1,2,3])) stop 37
+    if (.not. c_associated (c_cptr)) stop 38
+    if (.not. c_associated (c_cptr_in)) stop 39
+    if (.not. c_associated (c_cptr, c_loc(c_x))) stop 40
+    if (.not. c_associated (c_cptr_in, c_loc(c_u))) stop 41
+    call c_f_pointer(c_cptr_in, u)
+    call c_f_pointer(c_cptr, x, shape=[Nx])
+    if (u /= c_u .or. u /= 42)  stop 42
+    if (any (x /= c_x))  stop 43
+    if (any (x /= [3,4,6,2]))  stop 44
+  end subroutine target_fn
+end program main

Reply via email to