Fortran: Add code gen for do,concurrent's LOCAL/LOCAL_INIT [PR101602]
Implement LOCAL and LOCAL_INIT; we locally replace the tree declaration by a local declaration of the outer variable. The 'local_init' then assigns the value at the beginning of each loop iteration from the outer declaration. Note that the current implementation does not handle LOCAL with types that have a default initializer and LOCAL/LOCAL_INIT for assumed-shape arrays; this is diagnosed with a sorry error. PR fortran/101602 gcc/fortran/ChangeLog: * resolve.cc (resolve_locality_spec): Remove 'sorry, unimplemented'. * trans-stmt.cc (struct symbol_and_tree_t): New. (gfc_trans_concurrent_locality_spec): New. (gfc_trans_forall_1): Call it; update to handle local and local_init. * trans-decl.cc (gfc_start_saved_local_decls, gfc_stop_saved_local_decls): New; moved code from ... (gfc_process_block_locals): ... here. Call it. * trans.h (gfc_start_saved_local_decls, gfc_stop_saved_local_decls): Declare. gcc/testsuite/ChangeLog: * gfortran.dg/do_concurrent_8_f2023.f90: Update for removed 'sorry, unimplemented'. * gfortran.dg/do_concurrent_9.f90: Likewise. * gfortran.dg/do_concurrent_all_clauses.f90: Likewise. * gfortran.dg/do_concurrent_local_init.f90: Likewise. * gfortran.dg/do_concurrent_locality_specs.f90: Likewise. * gfortran.dg/do_concurrent_11.f90: New test. * gfortran.dg/do_concurrent_12.f90: New test. * gfortran.dg/do_concurrent_13.f90: New test. * gfortran.dg/do_concurrent_14.f90: New test. * gfortran.dg/do_concurrent_15.f90: New test.
This commit is contained in:
Tobias Burnus
parent
94438ca827
commit
2d7e1d6e40
14 changed files with 808 additions and 31 deletions
|
|
@ -8422,13 +8422,6 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
|
|||
plist = &((*plist)->next);
|
||||
}
|
||||
}
|
||||
|
||||
if (code->ext.concur.locality[LOCALITY_LOCAL]
|
||||
|| code->ext.concur.locality[LOCALITY_LOCAL_INIT])
|
||||
{
|
||||
gfc_error ("Sorry, LOCAL and LOCAL_INIT are not yet supported for "
|
||||
"%<do concurrent%> constructs at %L", &code->loc);
|
||||
}
|
||||
}
|
||||
|
||||
/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
|
||||
|
|
|
|||
|
|
@ -8361,23 +8361,17 @@ gfc_generate_block_data (gfc_namespace * ns)
|
|||
rest_of_decl_compilation (decl, 1, 0);
|
||||
}
|
||||
|
||||
|
||||
/* Process the local variables of a BLOCK construct. */
|
||||
void
|
||||
gfc_start_saved_local_decls ()
|
||||
{
|
||||
gcc_checking_assert (current_function_decl != NULL_TREE);
|
||||
saved_local_decls = NULL_TREE;
|
||||
}
|
||||
|
||||
void
|
||||
gfc_process_block_locals (gfc_namespace* ns)
|
||||
gfc_stop_saved_local_decls ()
|
||||
{
|
||||
tree decl;
|
||||
|
||||
saved_local_decls = NULL_TREE;
|
||||
has_coarray_vars_or_accessors = caf_accessor_head != NULL;
|
||||
|
||||
generate_local_vars (ns);
|
||||
|
||||
if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
|
||||
generate_coarray_init (ns);
|
||||
|
||||
decl = nreverse (saved_local_decls);
|
||||
tree decl = nreverse (saved_local_decls);
|
||||
while (decl)
|
||||
{
|
||||
tree next;
|
||||
|
|
@ -8390,5 +8384,20 @@ gfc_process_block_locals (gfc_namespace* ns)
|
|||
saved_local_decls = NULL_TREE;
|
||||
}
|
||||
|
||||
/* Process the local variables of a BLOCK construct. */
|
||||
|
||||
void
|
||||
gfc_process_block_locals (gfc_namespace* ns)
|
||||
{
|
||||
gfc_start_saved_local_decls ();
|
||||
has_coarray_vars_or_accessors = caf_accessor_head != NULL;
|
||||
|
||||
generate_local_vars (ns);
|
||||
|
||||
if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
|
||||
generate_coarray_init (ns);
|
||||
gfc_stop_saved_local_decls ();
|
||||
}
|
||||
|
||||
|
||||
#include "gt-fortran-trans-decl.h"
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ You should have received a copy of the GNU General Public License
|
|||
along with GCC; see the file COPYING3. If not see
|
||||
<http://www.gnu.org/licenses/>. */
|
||||
|
||||
|
||||
#define INCLUDE_VECTOR
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#include "coretypes.h"
|
||||
|
|
@ -5093,6 +5093,138 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
|
|||
}
|
||||
}
|
||||
|
||||
/* For saving the outer-variable data when doing
|
||||
LOCAL and LOCAL_INIT substitution. */
|
||||
struct symbol_and_tree_t
|
||||
{
|
||||
gfc_symbol *sym;
|
||||
gfc_expr *value;
|
||||
tree decl;
|
||||
symbol_attribute attr;
|
||||
};
|
||||
|
||||
/* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be
|
||||
called twice, once with after_body=false - and then after the loop
|
||||
body has been processed with after_body=true.
|
||||
|
||||
Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT
|
||||
locality specifiers of 'do concurrent' - and use it in the original
|
||||
gfc_symbol. The declaration is then reset by after_body=true.
|
||||
|
||||
Variables in LOCAL_INIT are set in every loop iteration. */
|
||||
|
||||
void
|
||||
gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body,
|
||||
std::vector<symbol_and_tree_t> *saved_decls,
|
||||
gfc_expr_list **locality_list)
|
||||
{
|
||||
if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT])
|
||||
return;
|
||||
|
||||
if (after_body)
|
||||
{
|
||||
for (unsigned i = 0; i < saved_decls->size (); i++)
|
||||
{
|
||||
(*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl;
|
||||
(*saved_decls)[i].sym->attr = (*saved_decls)[i].attr;
|
||||
(*saved_decls)[i].sym->value = (*saved_decls)[i].value;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
gfc_expr_list *el;
|
||||
int cnt = 0;
|
||||
for (int i = 0; i <= 1; i++)
|
||||
for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT];
|
||||
el; el = el->next)
|
||||
{
|
||||
gfc_symbol *outer_sym = el->expr->symtree->n.sym;
|
||||
if (!outer_sym->backend_decl)
|
||||
outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym);
|
||||
cnt++;
|
||||
}
|
||||
saved_decls->resize (cnt);
|
||||
|
||||
/* The variables have to be created in the scope of the loop body. */
|
||||
if (!body->has_scope)
|
||||
{
|
||||
gcc_checking_assert (body->head == NULL_TREE);
|
||||
gfc_start_block (body);
|
||||
}
|
||||
gfc_start_saved_local_decls ();
|
||||
|
||||
cnt = 0;
|
||||
static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1);
|
||||
for (int type = LOCALITY_LOCAL;
|
||||
type <= LOCALITY_LOCAL_INIT; type++)
|
||||
for (el = locality_list[type]; el; el = el->next)
|
||||
{
|
||||
gfc_symbol *sym = el->expr->symtree->n.sym;
|
||||
(*saved_decls)[cnt].sym = sym;
|
||||
(*saved_decls)[cnt].attr = sym->attr;
|
||||
(*saved_decls)[cnt].value = sym->value;
|
||||
(*saved_decls)[cnt].decl = sym->backend_decl;
|
||||
|
||||
if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE)
|
||||
{
|
||||
gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs "
|
||||
"is not yet supported",
|
||||
type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT",
|
||||
&el->expr->where, sym->name);
|
||||
continue;
|
||||
}
|
||||
|
||||
gfc_symbol outer_sym = *sym;
|
||||
|
||||
/* Create the inner local variable. */
|
||||
sym->backend_decl = NULL;
|
||||
sym->value = NULL;
|
||||
sym->attr.save = SAVE_NONE;
|
||||
sym->attr.value = 0;
|
||||
sym->attr.dummy = 0;
|
||||
sym->attr.optional = 0;
|
||||
|
||||
{
|
||||
/* Slightly ugly hack for adding the decl via add_decl_as_local. */
|
||||
gfc_symbol dummy_block_sym;
|
||||
dummy_block_sym.attr.flavor = FL_LABEL;
|
||||
gfc_symbol *saved_proc_name = sym->ns->proc_name;
|
||||
sym->ns->proc_name = &dummy_block_sym;
|
||||
|
||||
gfc_get_symbol_decl (sym);
|
||||
DECL_SOURCE_LOCATION (sym->backend_decl)
|
||||
= gfc_get_location (&el->expr->where);
|
||||
|
||||
sym->ns->proc_name = saved_proc_name;
|
||||
}
|
||||
|
||||
symbol_attribute attr = gfc_expr_attr (el->expr);
|
||||
if (type == LOCALITY_LOCAL
|
||||
&& !attr.pointer
|
||||
&& sym->ts.type == BT_DERIVED
|
||||
&& gfc_has_default_initializer (sym->ts.u.derived))
|
||||
/* Cf. PR fortran/ */
|
||||
gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with"
|
||||
" default initializer is not yet supported",
|
||||
&el->expr->where, sym->name);
|
||||
if (type == LOCALITY_LOCAL_INIT)
|
||||
{
|
||||
/* LOCAL_INIT: local_var = outer_var. */
|
||||
gfc_symtree st = *el->expr->symtree;
|
||||
st.n.sym = &outer_sym;
|
||||
gfc_expr expr = *el->expr;
|
||||
expr.symtree = &st;
|
||||
tree t = (attr.pointer
|
||||
? gfc_trans_pointer_assignment (el->expr, &expr)
|
||||
: gfc_trans_assignment (el->expr, &expr, false, false,
|
||||
false, false));
|
||||
gfc_add_expr_to_block (body, t);
|
||||
}
|
||||
cnt++;
|
||||
}
|
||||
gfc_stop_saved_local_decls ();
|
||||
}
|
||||
|
||||
|
||||
/* FORALL and WHERE statements are really nasty, especially when you nest
|
||||
them. All the rhs of a forall assignment must be evaluated before the
|
||||
|
|
@ -5348,9 +5480,19 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
|
|||
gfc_init_block (&body);
|
||||
cycle_label = gfc_build_label_decl (NULL_TREE);
|
||||
code->cycle_label = cycle_label;
|
||||
|
||||
/* Handle LOCAL and LOCAL_INIT. */
|
||||
std::vector<symbol_and_tree_t> saved_decls;
|
||||
gfc_trans_concurrent_locality_spec (false, &body, &saved_decls,
|
||||
code->ext.concur.locality);
|
||||
|
||||
/* Translate the body. */
|
||||
tmp = gfc_trans_code (code->block->next);
|
||||
gfc_add_expr_to_block (&body, tmp);
|
||||
|
||||
/* Reset locality variables. */
|
||||
gfc_trans_concurrent_locality_spec (true, &body, &saved_decls,
|
||||
code->ext.concur.locality);
|
||||
if (TREE_USED (cycle_label))
|
||||
{
|
||||
tmp = build1_v (LABEL_EXPR, cycle_label);
|
||||
|
|
|
|||
|
|
@ -804,6 +804,8 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
|
|||
tree rettype, int nargs, ...);
|
||||
|
||||
/* Process the local variable decls of a block construct. */
|
||||
void gfc_start_saved_local_decls ();
|
||||
void gfc_stop_saved_local_decls ();
|
||||
void gfc_process_block_locals (gfc_namespace*);
|
||||
|
||||
/* Output initialization/clean-up code that was deferred. */
|
||||
|
|
|
|||
53
gcc/testsuite/gfortran.dg/do_concurrent_11.f90
Normal file
53
gcc/testsuite/gfortran.dg/do_concurrent_11.f90
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
! { dg-do run }
|
||||
! { dg-additional-options "-fdump-tree-original" }
|
||||
|
||||
module m
|
||||
implicit none
|
||||
contains
|
||||
subroutine sub(y,str)
|
||||
integer :: y, x, i
|
||||
character(len=5) :: str
|
||||
character(len=5) :: z = "abcde"
|
||||
logical :: error = .false.
|
||||
|
||||
x = 5
|
||||
z = "12345"
|
||||
do concurrent (i = 1: 3) local_init(x) local_init(z) shared(error)default(none)
|
||||
if (x /= 5) error = .true.
|
||||
if (z /= "12345") error = .true.
|
||||
x = 99
|
||||
z = "XXXXX"
|
||||
end do
|
||||
if (x /= 5 .or. z /= "12345") stop 1
|
||||
if (error) stop 2
|
||||
|
||||
do concurrent (i = 1: 3) local(y) local(str) shared(error) default(none)
|
||||
y = 99
|
||||
str = "XXXXX"
|
||||
end do
|
||||
if (y /= 42 .or. str /= "ABCDE") stop 3
|
||||
end
|
||||
end
|
||||
|
||||
use m
|
||||
implicit none
|
||||
character(len=5) :: chars = "ABCDE"
|
||||
integer :: fourtytwo = 42
|
||||
call sub(fourtytwo, chars)
|
||||
end
|
||||
|
||||
|
||||
! { dg-final { scan-tree-dump-times " integer\\(kind=4\\) x;" 2 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " static character\\(kind=1\\) z\\\[1:5\\\] = .abcde.;" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " character\\(kind=1\\) z\\\[1:5\\\];" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " integer\\(kind=4\\) y;" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " character\\(kind=1\\) str\\\[1:5\\\];" 1 "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-times " x = 5;" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &z, \\(void \\*\\) &.12345.\\\[1\\\]\{lb: 1 sz: 1\}, 5\\);" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " x = x;" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &z, \\(void \\*\\)\\ &z, 5\\);" 1 "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-not " y = y;" "original" } }
|
||||
! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &str, \\(void \\*\\)\\ &.XXXXX.\\\[1\\\]\{lb: 1 sz: 1\}, 5\\);" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &str," 1 "original" } }
|
||||
175
gcc/testsuite/gfortran.dg/do_concurrent_12.f90
Normal file
175
gcc/testsuite/gfortran.dg/do_concurrent_12.f90
Normal file
|
|
@ -0,0 +1,175 @@
|
|||
! { dg-do compile }
|
||||
|
||||
! Fails to compile because default initializers aren't supported.
|
||||
! cf. do_concurrent_14.f90 and PR fortran/101602 (comment 6)
|
||||
|
||||
module m
|
||||
implicit none
|
||||
type t
|
||||
integer :: y = 44
|
||||
integer, pointer :: ptr(:) => null()
|
||||
end type t
|
||||
|
||||
contains
|
||||
|
||||
subroutine sub(x, y)
|
||||
integer :: i
|
||||
type(t) :: x, y(4)
|
||||
type(t) :: a, b(3)
|
||||
logical :: error = .false.
|
||||
integer, target :: tgt(6)
|
||||
integer, target :: tgt2(7)
|
||||
|
||||
x%y = 100
|
||||
x%ptr => tgt
|
||||
y(1)%y = 101
|
||||
y(2)%y = 102
|
||||
y(3)%y = 103
|
||||
y(4)%y = 104
|
||||
y(1)%ptr => tgt
|
||||
y(2)%ptr => tgt
|
||||
y(3)%ptr => tgt
|
||||
y(4)%ptr => tgt
|
||||
|
||||
a%y = 105
|
||||
a%ptr => tgt
|
||||
b(1)%y = 106
|
||||
b(2)%y = 107
|
||||
b(3)%y = 108
|
||||
b(1)%ptr => tgt
|
||||
b(2)%ptr => tgt
|
||||
b(3)%ptr => tgt
|
||||
|
||||
do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2) default(none)
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
error = .true.
|
||||
|
||||
x%y = 900
|
||||
x%ptr => tgt
|
||||
y(1)%y = 901
|
||||
y(2)%y = 902
|
||||
y(3)%y = 903
|
||||
y(4)%y = 904
|
||||
y(1)%ptr => tgt2
|
||||
y(2)%ptr => tgt2
|
||||
y(3)%ptr => tgt2
|
||||
y(4)%ptr => tgt2
|
||||
|
||||
a%y = 905
|
||||
a%ptr => tgt
|
||||
b(1)%y = 906
|
||||
b(2)%y = 907
|
||||
b(3)%y = 908
|
||||
b(1)%ptr => tgt2
|
||||
b(2)%ptr => tgt2
|
||||
b(3)%ptr => tgt2
|
||||
end do
|
||||
|
||||
if (error) stop 1
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
stop 2
|
||||
|
||||
do concurrent (i = 1: 3) local(x,y,a,b) shared(error,tgt,tgt2) default(none)
|
||||
! { dg-error "34: Sorry, LOCAL specifier at .1. for 'x' of derived type with default initializer is not yet supported" "" { target *-*-* } .-1 }
|
||||
! { dg-error "36: Sorry, LOCAL specifier at .1. for 'y' of derived type with default initializer is not yet supported" "" { target *-*-* } .-2 }
|
||||
! { dg-error "38: Sorry, LOCAL specifier at .1. for 'a' of derived type with default initializer is not yet supported" "" { target *-*-* } .-3 }
|
||||
! { dg-error "40: Sorry, LOCAL specifier at .1. for 'b' of derived type with default initializer is not yet supported" "" { target *-*-* } .-4 }
|
||||
|
||||
if (x%y /= 44) error = .true.
|
||||
if (any(y(:)%y /= 44)) error = .true.
|
||||
if (a%y /= 44) error = .true.
|
||||
if (any (b(:)%y /= 44)) error = .true.
|
||||
|
||||
if (associated(x%ptr)) error = .true.
|
||||
if (associated(y(1)%ptr)) error = .true.
|
||||
if (associated(y(2)%ptr)) error = .true.
|
||||
if (associated(y(3)%ptr)) error = .true.
|
||||
if (associated(y(4)%ptr)) error = .true.
|
||||
if (associated(a%ptr)) error = .true.
|
||||
if (associated(b(1)%ptr)) error = .true.
|
||||
if (associated(b(2)%ptr)) error = .true.
|
||||
if (associated(b(3)%ptr)) error = .true.
|
||||
|
||||
x%y = 900
|
||||
x%ptr => tgt
|
||||
y(1)%y = 901
|
||||
y(2)%y = 902
|
||||
y(3)%y = 903
|
||||
y(4)%y = 904
|
||||
y(1)%ptr => tgt2
|
||||
y(2)%ptr => tgt2
|
||||
y(3)%ptr => tgt2
|
||||
y(4)%ptr => tgt2
|
||||
|
||||
a%y = 905
|
||||
a%ptr => tgt
|
||||
b(1)%y = 906
|
||||
b(2)%y = 907
|
||||
b(3)%y = 908
|
||||
b(1)%ptr => tgt2
|
||||
b(2)%ptr => tgt2
|
||||
b(3)%ptr => tgt2
|
||||
end do
|
||||
|
||||
if (error) stop 3
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
stop 4
|
||||
end
|
||||
end
|
||||
|
||||
use m
|
||||
implicit none
|
||||
type(t) :: q, r(4)
|
||||
call sub(q,r)
|
||||
end
|
||||
211
gcc/testsuite/gfortran.dg/do_concurrent_13.f90
Normal file
211
gcc/testsuite/gfortran.dg/do_concurrent_13.f90
Normal file
|
|
@ -0,0 +1,211 @@
|
|||
! { dg-do run }
|
||||
! { dg-additional-options "-fdump-tree-original" }
|
||||
|
||||
module m
|
||||
implicit none
|
||||
type t
|
||||
integer :: y = 44
|
||||
integer, pointer :: ptr(:) => null()
|
||||
end type t
|
||||
|
||||
contains
|
||||
|
||||
subroutine sub(x, y)
|
||||
integer :: i
|
||||
type(t), pointer :: x, y(:)
|
||||
type(t), pointer :: a, b(:)
|
||||
logical :: error = .false.
|
||||
integer, target :: tgt(6)
|
||||
integer, target :: tgt2(7)
|
||||
|
||||
type(t), pointer :: x_saved
|
||||
type(t), pointer :: y_saved(:)
|
||||
type(t), pointer :: a_saved
|
||||
type(t), pointer :: b_saved(:)
|
||||
|
||||
allocate(a, b(3))
|
||||
|
||||
x_saved => x
|
||||
y_saved => y
|
||||
a_saved => a
|
||||
b_saved => b
|
||||
|
||||
x%y = 100
|
||||
x%ptr => tgt
|
||||
y(1)%y = 101
|
||||
y(2)%y = 102
|
||||
y(3)%y = 103
|
||||
y(4)%y = 104
|
||||
y(1)%ptr => tgt
|
||||
y(2)%ptr => tgt
|
||||
y(3)%ptr => tgt
|
||||
y(4)%ptr => tgt
|
||||
|
||||
a%y = 105
|
||||
a%ptr => tgt
|
||||
b(1)%y = 106
|
||||
b(2)%y = 107
|
||||
b(3)%y = 108
|
||||
b(1)%ptr => tgt
|
||||
b(2)%ptr => tgt
|
||||
b(3)%ptr => tgt
|
||||
|
||||
do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2,x_saved,y_saved,a_saved,b_saved) default(none)
|
||||
if (.not.associated(x,x_saved)) error = .true.
|
||||
if (.not.associated(y,y_saved)) error = .true.
|
||||
if (.not.associated(a,a_saved)) error = .true.
|
||||
if (.not.associated(b,b_saved)) error = .true.
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
error = .true.
|
||||
|
||||
if (i == 3) then
|
||||
! This is a hack - assuming no concurrency!
|
||||
x%y = 900
|
||||
y(1)%y = 901
|
||||
a%y = 905
|
||||
b(1)%y = 906
|
||||
endif
|
||||
x => null()
|
||||
y => null()
|
||||
a => null()
|
||||
b => null()
|
||||
end do
|
||||
|
||||
if (error) stop 1
|
||||
if (.not.associated(x,x_saved)) stop 2
|
||||
if (.not.associated(y,y_saved)) stop 3
|
||||
if (.not.associated(a,a_saved)) stop 4
|
||||
if (.not.associated(b,b_saved)) stop 5
|
||||
! Value a bit changed because of the hack above!
|
||||
if (x%y /= 900 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 901 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 905 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 906 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
stop 6
|
||||
|
||||
! Reset
|
||||
x%y = 100
|
||||
y(1)%y = 101
|
||||
a%y = 105
|
||||
b(1)%y = 106
|
||||
|
||||
do concurrent (i = 1: 3) local(x,y,a,b) shared(error) default(none)
|
||||
x => null()
|
||||
y => null()
|
||||
a => null()
|
||||
b => null()
|
||||
end do
|
||||
|
||||
if (.not.associated(x,x_saved)) stop 7
|
||||
if (.not.associated(y,y_saved)) stop 8
|
||||
if (.not.associated(a,a_saved)) stop 9
|
||||
if (.not.associated(b,b_saved)) stop 10
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
stop 11
|
||||
|
||||
do concurrent (i = 1: 3) local(x,y,a,b) shared(error,tgt,tgt2,x_saved,y_saved,a_saved,b_saved) default(none)
|
||||
x => a_saved
|
||||
y => b_saved
|
||||
a => x_saved
|
||||
b => y_saved
|
||||
if (a%y /= 100 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 101 &
|
||||
.or. b(2)%y /= 102 &
|
||||
.or. b(3)%y /= 103 &
|
||||
.or. b(4)%y /= 104 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt) &
|
||||
.or. .not.associated (b(4)%ptr, tgt) &
|
||||
.or. x%y /= 105 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 106 &
|
||||
.or. y(2)%y /= 107 &
|
||||
.or. y(3)%y /= 108 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt)) &
|
||||
error = .true.
|
||||
end do
|
||||
|
||||
if (.not.associated(x,x_saved)) stop 12
|
||||
if (.not.associated(y,y_saved)) stop 13
|
||||
if (.not.associated(a,a_saved)) stop 14
|
||||
if (.not.associated(b,b_saved)) stop 15
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
stop 16
|
||||
end
|
||||
end
|
||||
|
||||
use m
|
||||
implicit none
|
||||
type(t), pointer :: q, r(:)
|
||||
allocate(q, r(4))
|
||||
call sub(q,r)
|
||||
end
|
||||
176
gcc/testsuite/gfortran.dg/do_concurrent_14.f90
Normal file
176
gcc/testsuite/gfortran.dg/do_concurrent_14.f90
Normal file
|
|
@ -0,0 +1,176 @@
|
|||
! { dg-do run }
|
||||
|
||||
module m
|
||||
implicit none
|
||||
type t
|
||||
integer :: y = 44
|
||||
integer, pointer :: ptr(:) => null()
|
||||
end type t
|
||||
|
||||
! No default initializers, cf. do_concurrent_12.f90
|
||||
! and PR fortran/101602 (comment 6)
|
||||
type t2
|
||||
integer :: y
|
||||
integer, pointer :: ptr(:)
|
||||
end type t2
|
||||
|
||||
contains
|
||||
|
||||
subroutine sub(x, y)
|
||||
integer :: i
|
||||
type(t) :: x, y(4)
|
||||
type(t) :: a, b(3)
|
||||
type(t2) :: x2, y2(4)
|
||||
type(t2) :: a2, b2(3)
|
||||
logical :: error = .false.
|
||||
integer, target :: tgt(6)
|
||||
integer, target :: tgt2(7)
|
||||
|
||||
x%y = 100
|
||||
x%ptr => tgt
|
||||
y(1)%y = 101
|
||||
y(2)%y = 102
|
||||
y(3)%y = 103
|
||||
y(4)%y = 104
|
||||
y(1)%ptr => tgt
|
||||
y(2)%ptr => tgt
|
||||
y(3)%ptr => tgt
|
||||
y(4)%ptr => tgt
|
||||
|
||||
a%y = 105
|
||||
a%ptr => tgt
|
||||
b(1)%y = 106
|
||||
b(2)%y = 107
|
||||
b(3)%y = 108
|
||||
b(1)%ptr => tgt
|
||||
b(2)%ptr => tgt
|
||||
b(3)%ptr => tgt
|
||||
|
||||
! Copy values from 't' to associated 't2' variables
|
||||
x2%y = x%y
|
||||
x2%ptr => x%ptr
|
||||
a2%y = a%y
|
||||
a2%ptr => a%ptr
|
||||
y2(:)%y = y(:)%y
|
||||
do i = 1, size(y)
|
||||
y2(i)%ptr => y(i)%ptr
|
||||
end do
|
||||
b2(:)%y = b(:)%y
|
||||
do i = 1, size(b)
|
||||
b2(i)%ptr => b(i)%ptr
|
||||
end do
|
||||
|
||||
do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2) default(none)
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
error = .true.
|
||||
|
||||
x%y = 900
|
||||
x%ptr => tgt
|
||||
y(1)%y = 901
|
||||
y(2)%y = 902
|
||||
y(3)%y = 903
|
||||
y(4)%y = 904
|
||||
y(1)%ptr => tgt2
|
||||
y(2)%ptr => tgt2
|
||||
y(3)%ptr => tgt2
|
||||
y(4)%ptr => tgt2
|
||||
|
||||
a%y = 905
|
||||
a%ptr => tgt
|
||||
b(1)%y = 906
|
||||
b(2)%y = 907
|
||||
b(3)%y = 908
|
||||
b(1)%ptr => tgt2
|
||||
b(2)%ptr => tgt2
|
||||
b(3)%ptr => tgt2
|
||||
end do
|
||||
|
||||
if (error) stop 1
|
||||
if (x%y /= 100 &
|
||||
.or. .not.associated (x%ptr, tgt) &
|
||||
.or. y(1)%y /= 101 &
|
||||
.or. y(2)%y /= 102 &
|
||||
.or. y(3)%y /= 103 &
|
||||
.or. y(4)%y /= 104 &
|
||||
.or. .not.associated (y(1)%ptr, tgt) &
|
||||
.or. .not.associated (y(2)%ptr, tgt) &
|
||||
.or. .not.associated (y(3)%ptr, tgt) &
|
||||
.or. .not.associated (y(4)%ptr, tgt) &
|
||||
.or. a%y /= 105 &
|
||||
.or. .not.associated (a%ptr, tgt) &
|
||||
.or. b(1)%y /= 106 &
|
||||
.or. b(2)%y /= 107 &
|
||||
.or. b(3)%y /= 108 &
|
||||
.or. .not.associated (b(1)%ptr, tgt) &
|
||||
.or. .not.associated (b(2)%ptr, tgt) &
|
||||
.or. .not.associated (b(3)%ptr, tgt)) &
|
||||
stop 2
|
||||
|
||||
! Use version without default initializers
|
||||
do concurrent (i = 1: 3) local(x2,y2,a2,b2) shared(error,tgt,tgt2) default(none)
|
||||
x2%y = 900
|
||||
x2%ptr => tgt
|
||||
y2(1)%y = 901
|
||||
y2(2)%y = 902
|
||||
y2(3)%y = 903
|
||||
y2(4)%y = 904
|
||||
y2(1)%ptr => tgt2
|
||||
y2(2)%ptr => tgt2
|
||||
y2(3)%ptr => tgt2
|
||||
y2(4)%ptr => tgt2
|
||||
|
||||
a2%y = 905
|
||||
a2%ptr => tgt
|
||||
b2(1)%y = 906
|
||||
b2(2)%y = 907
|
||||
b2(3)%y = 908
|
||||
b2(1)%ptr => tgt2
|
||||
b2(2)%ptr => tgt2
|
||||
b2(3)%ptr => tgt2
|
||||
end do
|
||||
|
||||
if (error) stop 3
|
||||
if (x2%y /= 100 &
|
||||
.or. .not.associated (x2%ptr, tgt) &
|
||||
.or. y2(1)%y /= 101 &
|
||||
.or. y2(2)%y /= 102 &
|
||||
.or. y2(3)%y /= 103 &
|
||||
.or. y2(4)%y /= 104 &
|
||||
.or. .not.associated (y2(1)%ptr, tgt) &
|
||||
.or. .not.associated (y2(2)%ptr, tgt) &
|
||||
.or. .not.associated (y2(3)%ptr, tgt) &
|
||||
.or. .not.associated (y2(4)%ptr, tgt) &
|
||||
.or. a2%y /= 105 &
|
||||
.or. .not.associated (a2%ptr, tgt) &
|
||||
.or. b2(1)%y /= 106 &
|
||||
.or. b2(2)%y /= 107 &
|
||||
.or. b2(3)%y /= 108 &
|
||||
.or. .not.associated (b2(1)%ptr, tgt) &
|
||||
.or. .not.associated (b2(2)%ptr, tgt) &
|
||||
.or. .not.associated (b2(3)%ptr, tgt)) &
|
||||
stop 4
|
||||
end
|
||||
end
|
||||
|
||||
use m
|
||||
implicit none
|
||||
type(t) :: q, r(4)
|
||||
call sub(q,r)
|
||||
end
|
||||
20
gcc/testsuite/gfortran.dg/do_concurrent_15.f90
Normal file
20
gcc/testsuite/gfortran.dg/do_concurrent_15.f90
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
! { dg-do compile }
|
||||
|
||||
! Fails to compile because assumed-size arrays are not yet
|
||||
! handled with LOCAL / LOCAL_INIT, cf. PR fortran/101602 (comment 6)
|
||||
|
||||
subroutine test_it(xx, yy)
|
||||
implicit none
|
||||
integer :: xx(:), yy(:,:)
|
||||
integer :: i, sz1, sz2
|
||||
|
||||
sz1 = size(xx)
|
||||
do , concurrent (i = 1 : sz1) local(xx) ! { dg-error "39: Sorry, LOCAL specifier at .1. for assumed-size array 'xx' is not yet supported" }
|
||||
xx(i) = 1
|
||||
end do
|
||||
|
||||
sz2 = size(yy,dim=1)
|
||||
do , concurrent (i=1:sz2) local_init(yy) ! { dg-error "40: Sorry, LOCAL_INIT specifier at .1. for assumed-size array 'yy' is not yet supported" }
|
||||
yy(i,:) = 1
|
||||
end do
|
||||
end
|
||||
|
|
@ -8,10 +8,8 @@ program do_concurrent_complex
|
|||
product = 1
|
||||
do concurrent (i = 1:10) local(j) shared(sum) reduce(+:sum)
|
||||
! { dg-error "Variable .sum. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 }
|
||||
! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 }
|
||||
do concurrent (j = 1:10) local(k) shared(product) reduce(*:product)
|
||||
! { dg-error "Variable .product. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 }
|
||||
! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 }
|
||||
do concurrent (k = 1:10)
|
||||
array(i,j,k) = i * j * k
|
||||
sum = sum + array(i,j,k)
|
||||
|
|
@ -20,4 +18,4 @@ program do_concurrent_complex
|
|||
end do
|
||||
end do
|
||||
print *, sum, product
|
||||
end program do_concurrent_complex
|
||||
end program do_concurrent_complex
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ program do_concurrent_default_none
|
|||
x = 0
|
||||
y = 0
|
||||
z = 0
|
||||
do concurrent (i = 1:10) default(none) shared(x) local(y) ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported" }
|
||||
do concurrent (i = 1:10) default(none) shared(x) local(y)
|
||||
! { dg-error "Variable 'z' .* not specified in a locality spec .* but required due to DEFAULT \\(NONE\\)" "" { target *-*-* } .-1 }
|
||||
x = x + i
|
||||
y = i * 2
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ program do_concurrent_all_clauses
|
|||
shared(arr, squared, sum, max_val) &
|
||||
reduce(+:sum) & ! { dg-error "Variable 'sum' at \\(1\\) has already been specified in a locality-spec" }
|
||||
reduce(max:max_val) ! { dg-error "Variable 'max_val' at \\(1\\) has already been specified in a locality-spec" }
|
||||
! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported*" "" { target *-*-* } .-1 }
|
||||
block
|
||||
integer :: temp2
|
||||
temp = i * 2
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
program do_concurrent_local_init
|
||||
implicit none
|
||||
integer :: i, arr(10), temp
|
||||
do concurrent (i = 1:10) local_init(temp) ! { dg-error "LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" }
|
||||
do concurrent (i = 1:10) local_init(temp)
|
||||
temp = i
|
||||
arr(i) = temp
|
||||
end do
|
||||
print *, arr
|
||||
end program do_concurrent_local_init
|
||||
end program do_concurrent_local_init
|
||||
|
|
|
|||
|
|
@ -6,9 +6,8 @@ do , concurrent (i = 1:5) shared(j,jj) local(k,kk) local_init(ll,lll)
|
|||
! { dg-warning "Variable 'kk' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-1 }
|
||||
! { dg-warning "Variable 'll' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-2 }
|
||||
! { dg-warning "Variable 'jj' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-3 }
|
||||
! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-4 }
|
||||
j = 5
|
||||
k = 7
|
||||
lll = 8
|
||||
end do
|
||||
end
|
||||
end
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue