Hi Thomas,
On 1/3/20 7:18 PM, Thomas König wrote:
Build on x86-64-gnu-linux.
OK for the trunk – and for GCC 9? [It's a 9/10 regression]
Is is now okay?
If you add this, it would be good to add a test (for example counting
while statements in the *.original dump) that the copyback does not
happen.
I have now added something, which hopefully correctly captures this. I
added 'xxx' to have some example how a copy out could look like. (That
way, I also test whether a copy out happens.)
That creating a well-working pattern is difficult as get_var() also uses
atmp. – However, looking at the dump, I found that the copy out will
call get_var again! That's now PR 93148.
Generally, if we are passing an expression, the call to
gfc_conv_subref_array_arg is not needed - we will generate an array
temporary for the expression anyway, and this will always be contiguous.
True – but one needs to call some function. Whether
gfc_conv_subref_array_arg with INTENT_IN or gfc_conv_array_parameter
does not matter.
As a variant, I now use the latter (via the else branch). Either variant
produces the same original tree. One can argue which variant is clearer;
I think both are fine – pick one.
Tobias
PR fortran/91640
* trans-expr.c (gfc_conv_procedure_call): Avoid copy-out for nonvariable
arguments to contiguous dummy args. Avoid re-checking whether fsym is
NULL.
PR fortran/91640
* gfortran.dg/contiguous_10.f90: New.
gcc/fortran/trans-expr.c | 18 ++++----
gcc/testsuite/gfortran.dg/contiguous_10.f90 | 69 +++++++++++++++++++++++++++++
2 files changed, 78 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f2fe538a511..e1c0fb271de 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6177,37 +6177,37 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else if (gfc_is_class_array_ref (e, NULL)
- && fsym && fsym->ts.type == BT_DERIVED)
+ && fsym && fsym->ts.type == BT_DERIVED)
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
written back after the procedure call.
OOP-TODO: Insert code so that if the dynamic type is
the same as the declared type, copy-in/copy-out does
not occur. */
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym ? fsym->attr.intent : INTENT_INOUT,
- fsym && fsym->attr.pointer);
+ fsym->attr.intent,
+ fsym->attr.pointer);
else if (gfc_is_class_array_function (e)
- && fsym && fsym->ts.type == BT_DERIVED)
+ && fsym && fsym->ts.type == BT_DERIVED)
/* See previous comment. For function actual argument,
the write out is not needed so the intent is set as
intent in. */
{
e->must_finalize = 1;
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- INTENT_IN,
- fsym && fsym->attr.pointer);
+ INTENT_IN, fsym->attr.pointer);
}
else if (fsym && fsym->attr.contiguous
- && !gfc_is_simply_contiguous (e, false, true))
+ && !gfc_is_simply_contiguous (e, false, true)
+ && gfc_expr_is_variable (e))
{
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym ? fsym->attr.intent : INTENT_INOUT,
- fsym && fsym->attr.pointer);
+ fsym->attr.intent,
+ fsym->attr.pointer);
}
else
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
sym->name, NULL);
diff --git a/gcc/testsuite/gfortran.dg/contiguous_10.f90 b/gcc/testsuite/gfortran.dg/contiguous_10.f90
new file mode 100644
index 00000000000..82b8ed54f5b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/contiguous_10.f90
@@ -0,0 +1,69 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/91640
+!
+! Based on G. Steinmetz's test case
+!
+program p
+ implicit none (type, external)
+ real, target :: z(3) = 1.0
+ real :: res(3)
+ real, pointer :: xxx(:)
+
+ res = 42.0
+ call sub (-z, res)
+ if (any (abs (res - (-1.0)) > epsilon(res))) stop 1
+ if (any (abs (z - 1.0) > epsilon(z))) stop 2
+
+ res = 43.0
+ call sub (z*2.0, res)
+ if (any (abs (res - 2.0) > epsilon(res))) stop 3
+ if (any (abs (z - 1.0) > epsilon(z))) stop 4
+
+ res = 44.0
+ call sub(get_var(), res)
+ if (any (abs (res - 1.0) > epsilon(res))) stop 5
+ if (any (abs (z - 1.0) > epsilon(z))) stop 6
+
+ call double(get_var())
+ if (any (abs (z - 2.0) > epsilon(z))) stop 7
+
+ call double(get_var_cont())
+ if (any (abs (z - 4.0) > epsilon(z))) stop 8
+
+ ! For cross check for copy-out:
+ xxx => z
+ if (any (abs (z - 4.0) > epsilon(z))) stop 10
+ if (any (abs (xxx - 4.0) > epsilon(z))) stop 11
+ call double (xxx)
+ if (any (abs (z - 8.0) > epsilon(z))) stop 12
+ if (any (abs (xxx - 8.0) > epsilon(z))) stop 13
+
+contains
+ subroutine sub (x, res)
+ real, contiguous :: x(:)
+ real :: res(3)
+ res = x
+ end
+ subroutine double (x)
+ real, contiguous :: x(:)
+ x = x * 2.0
+ end
+ function get_var()
+ real, pointer :: get_var(:)
+ get_var => z
+ end
+ function get_var_cont()
+ real, pointer, contiguous :: get_var_cont(:)
+ get_var_cont => z
+ end
+end
+
+! only 'xxx' should have a copy out:
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\].* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\].*xxx\\.span.* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } }
+
+! Only once 'z... = ' – for: static real(kind=4) z[3] = {[0 ... 2]=1.0e+0};
+! but don't match '(si)ze'
+! { dg-final { scan-tree-dump-times "z\[^e\].* = " 1 "original" } }
