diff mbox series

(general Fortran + OpenMP) [Fortran] Fix/modify present() handling for assumed-shape optional (PR 94672)

Message ID 248b8834-b830-9130-c80f-64a81dd95a59@codesourcery.com
State New
Headers show
Series (general Fortran + OpenMP) [Fortran] Fix/modify present() handling for assumed-shape optional (PR 94672) | expand

Commit Message

Tobias Burnus May 7, 2020, 1:11 p.m. UTC 
The main purpose of this patch is to fix OpenMP, but it modifies
the general Fortran handling of assumed-shape optional arguments.

For assumed shape, gfortran generates an "arg.0 = arg->data"
artificial variable – and with optional one has something like

if (arg != NULL && arg->data != NULL)
   {
     arg.0 = arg->data;
     lbound.0 = ...
   }

And an "if (present(arg))" becomes
"if (arg != NULL && arg->data != NULL)".

The proposed change changes the init to:

if (arg != NULL && arg->data != NULL)
   {
     arg.0 = arg->data;
     lbound.0 = ...
   }
else
   arg.0 = NULL;  // <-- new

Such that an "if (present(arg))" becomes "if (arg.0 != NULL)".

I think for Fortran code itself, it does not really make any
difference. However, for OpenMP (and OpenACC) it does.

Currently,
   !$omp …
     if (present(arg)) stop 1
   !$omp end …

has decl = "arg.0" and SAVED_DESCRIPTOR(decl) == "arg" such
that inside the omp block everything is "arg.0" – except for
"if (present(arg))" which is converted to the "!arg && !arg->data".

This causes the problems shown in the PR (PR94672).

For optional & 'omp target' where one has to map the variable and
has to check it inside the target function, I even ended up setting
"arg.0 = NULL" explicitly as this was much simpler than adding more
checking in gcc/omp-low.c.


Thus: I think either variant (checking arg directly vs. checking arg.0
plus setting it to NULL) works equally well with normal Fortran code;
one can probably design code where one or the other is slightly faster,
but at the end it should not matter.
And for OpenMP/OpenACC, the new variant avoids several problems.

Hence:
OK for the trunk – and GCC 10 (regression, rejects valid code)?

Tobias

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter

Comments

Thomas Koenig May 10, 2020, 7:11 a.m. UTC | #1 
Hi Tobias,

> For assumed shape, gfortran generates an "arg.0 = arg->data"
> artificial variable – and with optional one has something like
> 
> if (arg != NULL && arg->data != NULL)
>    {
>      arg.0 = arg->data;
>      lbound.0 = ...
>    }
> 
> And an "if (present(arg))" becomes
> "if (arg != NULL && arg->data != NULL)".
> 
> The proposed change changes the init to:
> 
> if (arg != NULL && arg->data != NULL)
>    {
>      arg.0 = arg->data;
>      lbound.0 = ...
>    }
> else
>    arg.0 = NULL;  // <-- new

I think this is a good idea in general. We later use the arg.0
variable to access the contents of the argument, so this generates
a clear segfault for all cases where the user accesses non-present
opiontal arguments instead of something random.

Also, this avoids potential warnings about undefined variables.


> Thus: I think either variant (checking arg directly vs. checking arg.0
> plus setting it to NULL) works equally well with normal Fortran code;

Like I said, I think it is better :-)

> one can probably design code where one or the other is slightly faster,
> but at the end it should not matter.
> And for OpenMP/OpenACC, the new variant avoids several problems.
> 
> Hence:
> OK for the trunk – and GCC 10 (regression, rejects valid code)?

OK for both, and thanks for the patch!

Regards

	Thomas
diff mbox series

Patch

[Fortran] Fix/modify present() handling for assumed-shape optional (PR 94672)

gcc/fortran/
2020-05-07  Tobias Burnus  <tobias@codesourcery.com>

	PR fortran/94672
	* trans.h (gfc_conv_expr_present): Add use_saved_decl=false argument.
	* trans-expr.c (gfc_conv_expr_present): Likewise; use DECL directly
	and only if use_saved_decl is true, use the actual PARAM_DECL arg (saved
	descriptor).
	* trans-array.c (gfc_trans_dummy_array_bias): Set local 'arg.0'
	variable to NULL if 'arg' is not present.
	* trans-openmp.c (gfc_omp_check_optional_argument): Simplify by checking
	'arg.0' instead of the true PARM_DECL.
	(gfc_omp_finish_clause): Remove setting 'arg.0' to NULL.

gcc/testsuite/
2020-05-07  Jakub Jelinek  <jakub@redhat.com>
	    Tobias Burnus  <tobias@codesourcery.com>

	PR fortran/94672
	* gfortran.dg/gomp/pr94672.f90: New.
	* gfortran.dg/missing_optional_dummy_6a.f90: Update scan-tree.

 gcc/fortran/trans-array.c                          |   8 +-
 gcc/fortran/trans-expr.c                           |  22 ++--
 gcc/fortran/trans-openmp.c                         |  42 +------
 gcc/fortran/trans.h                                |   2 +-
 gcc/testsuite/gfortran.dg/gomp/pr94672.f90         | 127 +++++++++++++++++++++
 .../gfortran.dg/missing_optional_dummy_6a.f90      |   3 +-
 6 files changed, 152 insertions(+), 52 deletions(-)

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 9c928d04e0a..434960c5bc7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6787,9 +6787,11 @@  gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
 		      && sym->attr.dummy));
   if (optional_arg)
     {
-      tmp = gfc_conv_expr_present (sym);
-      stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
-			   build_empty_stmt (input_location));
+      tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
+      zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+				   tmpdesc, zero_init);
+      tmp = gfc_conv_expr_present (sym, true);
+      stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
     }
 
   /* Cleanup code.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 030edc1e5ce..33fc061d89b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1712,12 +1712,12 @@  gfc_make_safe_expr (gfc_se * se)
    Also used for arguments to procedures with multiple entry points.  */
 
 tree
-gfc_conv_expr_present (gfc_symbol * sym)
+gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
 {
-  tree decl, cond;
+  tree decl, orig_decl, cond;
 
   gcc_assert (sym->attr.dummy);
-  decl = gfc_get_symbol_decl (sym);
+  orig_decl = decl = gfc_get_symbol_decl (sym);
 
   /* Intrinsic scalars with VALUE attribute which are passed by value
      use a hidden argument to denote the present status.  */
@@ -1744,10 +1744,13 @@  gfc_conv_expr_present (gfc_symbol * sym)
       return cond;
     }
 
-  if (TREE_CODE (decl) != PARM_DECL)
+  /* Assumed-shape arrays use a local variable for the array data;
+     the actual PARAM_DECL is in a saved decl.  As the local variable
+     is NULL, it can be checked instead, unless use_saved_desc is
+     requested.  */
+
+  if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
     {
-      /* Array parameters use a temporary descriptor, we want the real
-         parameter.  */
       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
@@ -1761,9 +1764,12 @@  gfc_conv_expr_present (gfc_symbol * sym)
      we thus also need to check the array descriptor.  For BT_CLASS, it
      can also occur for scalars and F2003 due to type->class wrapping and
      class->class wrapping.  Note further that BT_CLASS always uses an
-     array descriptor for arrays, also for explicit-shape/assumed-size.  */
+     array descriptor for arrays, also for explicit-shape/assumed-size.
+     For assumed-rank arrays, no local variable is generated, hence,
+     the following also applies with !use_saved_desc.  */
 
-  if (!sym->attr.allocatable
+  if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
+      && !sym->attr.allocatable
       && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
 	  || (sym->ts.type == BT_CLASS
 	      && !CLASS_DATA (sym)->attr.allocatable
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 66669550499..42ecd0a9cbb 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -90,16 +90,13 @@  gfc_omp_check_optional_argument (tree decl, bool for_present_check)
   if (!DECL_LANG_SPECIFIC (decl))
     return NULL_TREE;
 
-  bool is_array_type = false;
+  tree orig_decl = decl;
 
   /* 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))))
-    {
-      is_array_type = true;
-      decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
-    }
+    decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
 
   if (decl == NULL_TREE
       || TREE_CODE (decl) != PARM_DECL
@@ -132,23 +129,8 @@  gfc_omp_check_optional_argument (tree decl, bool for_present_check)
       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;
+  return fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			  orig_decl, null_pointer_node);
 }
 
 
@@ -1287,22 +1269,6 @@  gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
 	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;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 69171f3d0f2..bd96cdf86fc 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -561,7 +561,7 @@  void gfc_trans_common (gfc_namespace *);
 void gfc_conv_structure (gfc_se *, gfc_expr *, int);
 
 /* Return an expression which determines if a dummy parameter is present.  */
-tree gfc_conv_expr_present (gfc_symbol *);
+tree gfc_conv_expr_present (gfc_symbol *, bool use_saved_decl = false);
 /* Convert a missing, dummy argument into a null or zero.  */
 void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int);
 
diff --git a/gcc/testsuite/gfortran.dg/gomp/pr94672.f90 b/gcc/testsuite/gfortran.dg/gomp/pr94672.f90
new file mode 100644
index 00000000000..7b89c5df249
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/pr94672.f90
@@ -0,0 +1,127 @@ 
+! { dg-do compile }
+
+SUBROUTINE foo(n,array)
+    IMPLICIT NONE
+    INTEGER, INTENT (IN) :: n
+    REAL, INTENT(INOUT),OPTIONAL:: array(:)
+    INTEGER:: i
+
+    !$OMP PARALLEL DO DEFAULT(none) SHARED(array,n) PRIVATE(i)
+    DO i = 1,n
+       IF (PRESENT(array)) THEN
+          array(i) = array(i) + i
+       ENDIF
+    ENDDO
+    !$OMP END PARALLEL DO
+END SUBROUTINE foo
+
+subroutine s1 (array)
+  real, optional :: array(:)
+  !$omp parallel default(none) firstprivate (array)
+  if (present (array)) array(:) = 3
+  !$omp end parallel
+end subroutine
+
+subroutine s2 (array)
+  real, optional :: array(:)
+  !$omp parallel default(none) shared (array)
+  !$omp master
+  if (present (array)) array(:) = 3
+  !$omp end master
+  !$omp end parallel
+end subroutine
+
+subroutine s3 (array)
+  real, optional :: array(:)
+  !$omp parallel default(none) private (array)
+  if (present (array)) array(:) = 3
+  !$omp end parallel
+end subroutine
+
+subroutine s4 (arg)
+  real, optional :: arg
+  !$omp parallel default(none) firstprivate (arg)
+  if (present (arg)) arg = 3
+  !$omp end parallel
+end subroutine
+
+subroutine s5 (arg)
+  real, optional :: arg
+  !$omp parallel default(none) shared (arg)
+  !$omp master
+  if (present (arg)) arg = 3
+  !$omp end master
+  !$omp end parallel
+end subroutine
+
+subroutine s6 (arg)
+  real, optional :: arg
+  !$omp parallel default(none) private (arg)
+  if (present (arg)) arg = 3
+  !$omp end parallel
+end subroutine
+
+subroutine s7 (arg)
+  real, value, optional :: arg
+  !$omp parallel default(none) firstprivate (arg)
+  if (present (arg)) arg = 3
+  !$omp end parallel
+end subroutine
+
+subroutine s8 (arg)
+  real, value, optional :: arg
+  !$omp parallel default(none) shared (arg)
+  !$omp master
+  if (present (arg)) arg = 3
+  !$omp end master
+  !$omp end parallel
+end subroutine
+
+subroutine s9 (arg)
+  real, value, optional :: arg
+  !$omp parallel default(none) private (arg)
+  if (present (arg)) arg = 3
+  !$omp end parallel
+end subroutine
+
+subroutine s10 (arg)
+  real, optional :: arg(..)
+  !$omp parallel default(none) private (arg)
+  if (present (arg)) stop 10
+  !$omp end parallel
+end subroutine
+
+subroutine w1 (array)
+  real, optional :: array(:)
+  !$omp parallel default(none)     ! { dg-error "enclosing 'parallel'" }
+  if (.not.present (array)) stop 1 ! { dg-error "'array' not specified in enclosing 'parallel'" }
+  !$omp end parallel
+end subroutine
+
+subroutine w2 (array2)
+  real, optional :: array2(*)
+  !$omp parallel default(none)      ! { dg-error "enclosing 'parallel'" "TODO" { xfail *-*-* } }
+  if (.not.present (array2)) stop 2 ! { dg-error "'array2' not specified in enclosing 'parallel'" "TODO" { xfail *-*-* } }
+  !$omp end parallel
+end subroutine
+
+subroutine w3 (arg)
+  real, optional :: arg
+  !$omp parallel default(none)    ! { dg-error "enclosing 'parallel'" }
+  if (.not.present (arg)) stop 3  ! { dg-error "'arg' not specified in enclosing 'parallel'" }
+  !$omp end parallel
+end subroutine
+
+subroutine w4 (arg2)
+  real, value, optional :: arg2
+  !$omp parallel default(none)     ! { dg-error "enclosing 'parallel" "TODO" { xfail *-*-* } }
+  if (.not.present (arg2)) stop 4  ! { dg-error "'arg2' not specified in enclosing 'parallel'" "TODO" { xfail *-*-*} }
+  !$omp end parallel
+end subroutine
+
+subroutine w5 (array3)
+  real, optional :: array3(..)
+  !$omp parallel default(none)      ! { dg-error "enclosing 'parallel'" }
+  if (.not.present (array3)) stop 5 ! { dg-error "'array3' not specified in enclosing 'parallel'" }
+  !$omp end parallel
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
index 0e08ed3aa0c..c08c97a2c7e 100644
--- a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
+++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
@@ -53,7 +53,6 @@  end program test
 ! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } }
 ! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } }
 
-! { dg-final { scan-tree-dump-times "= as1 != 0B" 2 "original" } }
+! { dg-final { scan-tree-dump-times "= as1.0 != 0B" 2 "original" } }
 ! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } }
 ! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } }
-