[PATCH, v2, OpenMP, Fortran] Support in_reduction for Fortran
Hi Jakub,
On 2021/9/18 12:11 AM, Jakub Jelinek wrote:
@@ -3496,7 +3509,8 @@ static match
match_omp (gfc_exec_op op, const omp_mask mask)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
+ if (gfc_match_omp_clauses (&c, mask, true, true, false,
+(op == EXEC_OMP_TARGET)) != MATCH_YES)
The ()s around op == EXEC_OMP_TARGET are unnecessary.
Fixed.
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -6391,12 +6391,17 @@ gfc_trans_omp_task (gfc_code *code)
static tree
gfc_trans_omp_taskgroup (gfc_code *code)
{
+ stmtblock_t block;
+ gfc_start_block (&block);
tree body = gfc_trans_code (code->block->next);
tree stmt = make_node (OMP_TASKGROUP);
TREE_TYPE (stmt) = void_type_node;
OMP_TASKGROUP_BODY (stmt) = body;
- OMP_TASKGROUP_CLAUSES (stmt) = NULL_TREE;
- return stmt;
+ OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block,
+ code->ext.omp_clauses,
+ code->loc);
+ gfc_add_expr_to_block (&block, stmt);
If this was missing, then I'm afraid we lack a lot of testsuite coverage for
Fortran task reductions. It doesn't need to be covered in this patch, but
would be
good to cover it incrementally. Because the above means nothing with
taskgroup with task_reduction clause(s) could work properly at runtime.
Actually, the testcases do somewhat exercise taskgroup task_reductions, but
like you
said, only lightly.
--- a/gcc/omp-low.c
+++ b/gcc/omp-low.c
@@ -1317,9 +1317,13 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
if (is_omp_target (ctx->stmt))
{
tree at = decl;
+ omp_context *scan_ctx = ctx;
if (ctx->outer)
- scan_omp_op (&at, ctx->outer);
- tree nt = omp_copy_decl_1 (at, ctx);
+ {
+ scan_omp_op (&at, ctx->outer);
+ scan_ctx = ctx->outer;
+ }
+ tree nt = omp_copy_decl_1 (at, scan_ctx);
splay_tree_insert (ctx->field_map,
(splay_tree_key) &DECL_CONTEXT (decl),
(splay_tree_value) nt);
You're right that the var remembered with &DECL_CONTEXT (whatever) key is
used outside of the target construct rather than inside of it.
So, if ctx->outer is non-NULL, it seems right to create the var in that
outer context. But, if ctx->outer is NULL, which can happen if the
target construct is orphaned, consider e.g.
extern int &x;
extern int &y;
void
foo ()
{
#pragma omp target in_reduction (+: x, y)
{
x = x + 8;
y = y + 16;
}
}
void
bar ()
{
#pragma omp taskgroup task_reduction (+: x, y)
foo ();
}
then those artificial decls (copies of x and y) should appear
to be at the function scope and not inside of the target region.
Therefore, I wonder if omp_copy_decl_2 shouldn't do the
DECL_CONTEXT (copy) = current_function_decl;
DECL_CHAIN (copy) = ctx->block_vars;
ctx->block_vars = copy;
(the last one can be moved next to the others) only if ctx != NULL
and otherwise call gimple_add_tmp_var (copy); instead
and then just call omp_copy_decl_1 at that spot with unconditional
ctx->outer.
I see what you mean. I tried gimple_add_tmp_var but didn't work due to a
!DECL_SEEN_IN_BIND_EXPR_P() assert fail, but record_vars() appears to work.
Also, this isn't the only place that should have such a change,
there is also
if (ctx->outer)
scan_omp_op (&at, ctx->outer);
tree nt = omp_copy_decl_1 (at, ctx);
splay_tree_insert (ctx->field_map,
(splay_tree_key) &DECL_CONTEXT (t),
(splay_tree_value) nt);
a few lines above this and I'd expect that it should be (at, ctx->outer)
as well.
Fixed.
@@ -1339,7 +1343,9 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
if (!is_global_var (maybe_lookup_decl_in_outer_ctx (decl, ctx)))
{
by_ref = use_pointer_for_field (decl, ctx);
- if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_IN_REDUCTION)
+ if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_IN_REDUCTION
+ && !splay_tree_lookup (ctx->field_map,
+(splay_tree_key) decl))
install_var_field (decl, by_ref, 3, ctx);
}
install_var_local (decl, ctx);
When exactly do you need this? It doesn't trigger on the new libgomp
testcase...
I remember there was a testcase with triggered an ICE without this, but for some
reason can't find it anymore. I don't have any more evidence this is needed, so
removed now.
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-in-reduction-1.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+
+subrouti
[Patch, committed] Fortran: Fix "str" to scalar descriptor conversion [PR92482]
Here, the problem is that the param.expr was:
&"abc" -> type: "char*"
as that's an ADDR_EXPR, the previous code dereferrenced it:
*&"abc" -> type *(char*)
but that's the type 'char'. Thus, at the end, the result
was
scalar = 'a' -> type char
instead of
scalar "abc" -> type char array of size 3
Solution: Do what the comment does – remove the ADDR_EXPR
insead of dereferrencing the result.
Build + regtested on x86_64-gnu-linux
+ installed as r12-4505-g6920d5a1a2834e9c62d441b8f4c6186b01107d13
Tobias
-
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634
München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas
Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht
München, HRB 106955
commit 6920d5a1a2834e9c62d441b8f4c6186b01107d13
Author: Tobias Burnus
Date: Tue Oct 19 15:16:01 2021 +0200
Fortran: Fix "str" to scalar descriptor conversion [PR92482]
PR fortran/92482
gcc/fortran/ChangeLog:
* trans-expr.c (gfc_conv_procedure_call): Use TREE_OPERAND not
build_fold_indirect_ref_loc to undo an ADDR_EXPR.
gcc/testsuite/ChangeLog:
* gfortran.dg/bind-c-char-descr.f90: Remove xfail; extend a bit.
---
gcc/fortran/trans-expr.c| 2 +-
gcc/testsuite/gfortran.dg/bind-c-char-descr.f90 | 57 -
2 files changed, 39 insertions(+), 20 deletions(-)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 01389373065..29697e69e75 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6640,7 +6640,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tmp = parmse.expr;
if (TREE_CODE (tmp) == ADDR_EXPR)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = TREE_OPERAND (tmp, 0);
parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
fsym->attr);
parmse.expr = gfc_build_addr_expr (NULL_TREE,
diff --git a/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90 b/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90
index 3b01ad3b63d..8829fd1f71b 100644
--- a/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90
+++ b/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90
@@ -2,7 +2,6 @@
!
! Contributed by José Rui Faustino de Sousa
!
-! Note the xfail issue below for 'strg_print_2("abc")
program strp_p
@@ -24,13 +23,18 @@ program strp_p
if (len(str) /= 3 .or. str /= "abc") stop 1
if (len(strp_1) /= 3 .or. strp_1 /= "abc") stop 2
if (len(strp_2) /= 3 .or. strp_2 /= "abc") stop 3
- call strg_print_0("abc") ! Error (10.0.0) or segmentation fault (9.1.0)
- call strg_print_0(str) ! Error (10.0.0) or segmentation fault (9.1.0)
- call strg_print_0(strp_1) ! Error (10.0.0) or segmentation fault (9.1.0)
- call strg_print_0(strp_2) ! Error (10.0.0) or segmentation fault (9.1.0)
- call strg_print_1(strp_1) ! Not yet supported
+ call strg_print_0("abc")
+ call strg_print_0(str)
+ call strg_print_0(strp_1)
+ call strg_print_0(strp_2)
+ call strg_print_0_c("abc")
+ call strg_print_0_c(str)
+ call strg_print_0_c(strp_1)
+ call strg_print_0_c(strp_2)
+ call strg_print_1(strp_1)
+ call strg_print_1_c(strp_1)
- call strg_print_2("abc", xfail=.true.)
+ call strg_print_2("abc")
call strg_print_2(str)
call strg_print_2(strp_1)
call strg_print_2(strp_2)
@@ -42,14 +46,21 @@ program strp_p
contains
- subroutine strg_print_0(this) bind(c) ! Error (10.0.0 20191106) or warning (9.1.0) issued with bind(c)
+ subroutine strg_print_0 (this)
character(len=*, kind=c_char), target, intent(in) :: this
if (len (this) /= 3) stop 10
if (this /= "abc") stop 11
end subroutine strg_print_0
+
+ subroutine strg_print_0_c (this) bind(c)
+character(len=*, kind=c_char), target, intent(in) :: this
+
+if (len (this) /= 3) stop 10
+if (this /= "abc") stop 11
+ end subroutine strg_print_0_c
- subroutine strg_print_1(this) bind(c) ! Not yet supported with bind(c)
+ subroutine strg_print_1 (this) bind(c)
character(len=:, kind=c_char), pointer, intent(in) :: this
character(len=:), pointer :: strn
@@ -63,26 +74,34 @@ contains
if (this /= "abc") stop 25
end if
end subroutine strg_print_1
+
+ subroutine strg_print_1_c (this) bind(c)
+character(len=:, kind=c_char), pointer, intent(in) :: this
+character(len=:), pointer :: strn
+
+if (.not. associated (this)) stop 20
+if (len (this) /= 3) stop 21
+if (this /= "abc") stop 22
+ strn => this
+ if (.not. associated (strn)) stop 23
+ if(associated(strn))then
+ if (len (this) /= 3) stop 24
+ if (this /= "abc") stop 25
+ end if
+ end subroutine strg_print_1_c
- subroutine strg_print_2(this, xfail)
+ subroutine strg_print_2(this)
use, intrinsic :: iso_c_binding, only: &
c_loc, c_f_pointer
type(*), target, intent(in) :: this(..)
-logical, opt
Re: [PATCH, v2, OpenMP, Fortran] Support in_reduction for Fortran
On Tue, Oct 19, 2021 at 09:03:06PM +0800, Chung-Lin Tang wrote: > 2021-10-19 Chung-Lin Tang > > gcc/fortran/ChangeLog: > > * openmp.c (gfc_match_omp_clause_reduction): Add 'openmp_target' default > false parameter. Add 'always,tofrom' map for OMP_LIST_IN_REDUCTION case. > (gfc_match_omp_clauses): Add 'openmp_target' default false parameter, > adjust call to gfc_match_omp_clause_reduction. > (match_omp): Adjust call to gfc_match_omp_clauses > * trans-openmp.c (gfc_trans_omp_taskgroup): Add call to > gfc_match_omp_clause, create and return block. > > gcc/ChangeLog: > > * omp-low.c (omp_copy_decl_2): For !ctx, use record_vars to add new copy > as local variable. > (scan_sharing_clauses): Place copy of OMP_CLAUSE_IN_REDUCTION decl in > ctx->outer instead of ctx. > > gcc/testsuite/ChangeLog: > > * gfortran.dg/gomp/reduction4.f90: Adjust omp target in_reduction' scan > pattern. > > libgomp/ChangeLog: > > * testsuite/libgomp.fortran/target-in-reduction-1.f90: New test. > * testsuite/libgomp.fortran/target-in-reduction-2.f90: New test. LGTM, thanks. Jakub
[Patch, committed] Fortran: Fix 'fn spec' for deferred character length (was: Re: [r12-4457 Regression] FAIL: gfortran.dg/deferred_type_param_6.f90 -Os execution test on Linux/x86_64)
On 16.10.21 20:54, Jan Hubicka wrote:
I wrote:
Fortran has for a long time 'character(len=5), allocatable" or
"character(len=*)". In the first case, the "5" can be ignored as both
caller and callee know the length. In the second case, the length is
determined by the argument, but it cannot be changed.
Since a not-that-short while, 'len=:' together with allocatable/pointer
is supported.
In the latter case, the value can be change when the array
association/allocation is changed.
...
+ if (!sym->ts.u.cl->length
+ && ((sym->attr.allocatable && sym->attr.target)
+ || sym->attr.pointer))
+spec[spec_len++] = '.';
+ if (!sym->ts.u.cl->length && sym->attr.allocatable)
+spec[spec_len++] = 'w';
+ else
+spec[spec_len++] = 'R';
Also escaping is quite important bit of information so it would be
good to figure out if it really can escape rather than playing safe.
The pointer to the string length variable itself does not escape,
only its integer string value:
subroutine foo(x)
character(len=:), pointer :: x
character(len=:), pointer :: y
y => x
has in the dump:
.y = *_x;
y = (character(kind=1)[1:.y] *) *x;
Thus, 'w' can always be used.
Committed as obvious as r12-4511-gff0eec94e87dfb7dc387f120ca5ade2707aecf50
Tobias
-
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634
München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas
Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht
München, HRB 106955
commit ff0eec94e87dfb7dc387f120ca5ade2707aecf50
Author: Tobias Burnus
Date: Tue Oct 19 16:38:56 2021 +0200
Fortran: Fix 'fn spec' for deferred character length
Shows now up with gfortran.dg/deferred_type_param_6.f90 due to more ME
optimizations, causing fails without this commit.
gcc/fortran/ChangeLog:
* trans-types.c (create_fn_spec): For allocatable/pointer
character(len=:), use 'w' not 'R' as fn spec for the length dummy
argument.
---
gcc/fortran/trans-types.c | 6 +-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 50fceebc941..42778067dbe 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -3014,7 +3014,11 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
}
if (sym->ts.type == BT_CHARACTER)
{
- spec[spec_len++] = 'R';
+ if (!sym->ts.u.cl->length
+ && (sym->attr.allocatable || sym->attr.pointer))
+ spec[spec_len++] = 'w';
+ else
+ spec[spec_len++] = 'R';
spec[spec_len++] = ' ';
}
}
gfortran.dg/bind-c-contiguous-5.c: Big-endian fix [PR102815]
Endian fix – but not well tested on big endian - hence, reports
whether it now passes are highly welcome (thanks!).
Committed as r12-4528-gd4044db034b40c275b5f287d5854a102d22e07c0
Tobias
-
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634
München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas
Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht
München, HRB 106955
commit d4044db034b40c275b5f287d5854a102d22e07c0
Author: Tobias Burnus
Date: Wed Oct 20 08:32:16 2021 +0200
gfortran.dg/bind-c-contiguous-5.c: Big-endian fix
gcc/testsuite/
PR fortran/102815
* gfortran.dg/bind-c-contiguous-5.c (do_call, reset_var): Handle
big andian.
---
gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c | 101
1 file changed, 101 insertions(+)
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c
index 48c03d4e02e..0b7bae8a381 100644
--- a/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c
@@ -88,6 +88,7 @@ do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
basic_check (z, is_cont || num == 2);
if (!is_cont && num == 1)
{
+#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
@@ -97,24 +98,55 @@ do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+#elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
+ check_str (x, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero);
+ check_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one);
+ check_str (x, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two);
+ check_str (y, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero);
+ check_str (y, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one);
+ check_str (y, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two);
+ check_str (z, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero);
+ check_str (z, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one);
+ check_str (z, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two);
+#else
+#error "Unsupported __BYTE_ORDER__"
+#endif
}
else if (num == 1)
{
+#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
if (memcmp ((const char*) x->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
__builtin_abort ();
if (memcmp ((const char*) y->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
__builtin_abort ();
if (memcmp ((const char*) z->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
__builtin_abort ();
+#else
+ if (memcmp ((const char*) x->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) y->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) z->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0)
+ __builtin_abort ();
+#endif
}
else if (num == 2)
{
+#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
if (memcmp ((const char*) x->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0)
__builtin_abort ();
if (memcmp ((const char*) y->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0)
__builtin_abort ();
if (memcmp ((const char*) z->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0)
__builtin_abort ();
+#else
+ if (memcmp ((const char*) x->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) y->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) z->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0)
+ __builtin_abort ();
+#endif
}
else
__builtin_abort ();
@@ -144,6 +176,7 @@ do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
// intent_in
if (intent_in && !is_cont && num == 1)
{
+#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
@@ -153,24 +186,53 @@ do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two)
