OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/44646 ([F08] Implement DO CONCURRENT) 

gcc/fortran/
2011-09-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44646
        * decl.c (gfc_match_entry, gfc_match_end): Handle
        * COMP_DO_CONCURRENT.
        * dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT.
        * gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT.
        * match.c (gfc_match_critical, match_exit_cycle,
        * gfc_match_stopcode,
        lock_unlock_statement, sync_statement, gfc_match_allocate,
        gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic.
        (gfc_match_do): Match DO CONCURRENT.
        (match_derived_type_spec, match_type_spec, gfc_free_forall_iterator,
        match_forall_iterator, match_forall_header, match_simple_forall,
        gfc_match_forall): Move up in the file.
        * parse.c (check_do_closure, parse_do_block): Handle do
        * concurrent.
        * parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT.
        * resolve.c (do_concurrent_flag): New global variable.
        (resolve_function, pure_subroutine, resolve_branch,
        gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent
        diagnostic.
        * st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT.
        * trans-stmt.c (gfc_trans_do_concurrent): New function.
        (gfc_trans_forall_1): Handle do concurrent.
        * trans-stmt.h (gfc_trans_do_concurrent): New function
        * prototype.
        * trans.c (trans_code): Call it.
        * frontend-passes.c (gfc_code_walker): Handle
        * EXEC_DO_CONCURRENT.

gcc/testsuite/
2011-09-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44646
        * gfortran.dg/do_concurrent_1.f90: New.
        * gfortran.dg/do_concurrent_2.f90: New.

From-SVN: r178677
This commit is contained in:
Tobias Burnus 2011-09-08 08:38:13 +02:00 committed by Tobias Burnus
parent 1542d97a4e
commit 8c6a85e33b
16 changed files with 808 additions and 448 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View File

@ -1,3 +1,29 @@
2011-09-08 Tobias Burnus <burnus@net-b.de>
PR fortran/44646
* decl.c (gfc_match_entry, gfc_match_end): Handle COMP_DO_CONCURRENT.
* dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT.
* gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT.
* match.c (gfc_match_critical, match_exit_cycle, gfc_match_stopcode,
lock_unlock_statement, sync_statement, gfc_match_allocate,
gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic.
(gfc_match_do): Match DO CONCURRENT.
(match_derived_type_spec, match_type_spec, gfc_free_forall_iterator,
match_forall_iterator, match_forall_header, match_simple_forall,
gfc_match_forall): Move up in the file.
* parse.c (check_do_closure, parse_do_block): Handle do concurrent.
* parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT.
* resolve.c (do_concurrent_flag): New global variable.
(resolve_function, pure_subroutine, resolve_branch,
gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent
diagnostic.
* st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT.
* trans-stmt.c (gfc_trans_do_concurrent): New function.
(gfc_trans_forall_1): Handle do concurrent.
* trans-stmt.h (gfc_trans_do_concurrent): New function prototype.
* trans.c (trans_code): Call it.
* frontend-passes.c (gfc_code_walker): Handle EXEC_DO_CONCURRENT.
2011-09-07 Janus Weil <janus@gcc.gnu.org>
PR fortran/48095

2
gcc/fortran/decl.c
View File

@ -5248,6 +5248,7 @@ gfc_match_entry (void)
"an IF-THEN block");
break;
case COMP_DO:
case COMP_DO_CONCURRENT:
gfc_error ("ENTRY statement at %C cannot appear within "
"a DO block");
break;
@ -5853,6 +5854,7 @@ gfc_match_end (gfc_statement *st)
break;
case COMP_DO:
case COMP_DO_CONCURRENT:
*st = ST_ENDDO;
target = " do";
eos_ok = 0;

22
gcc/fortran/dump-parse-tree.c
View File

@ -1611,6 +1611,28 @@ show_code_node (int level, gfc_code *c)
fputs ("END DO", dumpfile);
break;
case EXEC_DO_CONCURRENT:
fputs ("DO CONCURRENT ", dumpfile);
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
{
show_expr (fa->var);
fputc (' ', dumpfile);
show_expr (fa->start);
fputc (':', dumpfile);
show_expr (fa->end);
fputc (':', dumpfile);
show_expr (fa->stride);
if (fa->next != NULL)
fputc (',', dumpfile);
}
show_expr (c->expr1);
show_code (level + 1, c->block->next);
code_indent (level, c->label1);
fputs ("END DO", dumpfile);
break;
case EXEC_DO_WHILE:
fputs ("DO WHILE ", dumpfile);
show_expr (c->expr1);

1
gcc/fortran/frontend-passes.c
View File

@ -1103,6 +1103,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
}
case EXEC_FORALL:
case EXEC_DO_CONCURRENT:
{
gfc_forall_iterator *fa;
for (fa = co->ext.forall_iterator; fa; fa = fa->next)

8
gcc/fortran/gfortran.h
View File

@ -2052,10 +2052,10 @@ typedef enum
EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP,
EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE,
EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE,
EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,

985
gcc/fortran/match.c
View File

File diff suppressed because it is too large Load Diff

10
gcc/fortran/parse.c
View File

@ -3154,7 +3154,7 @@ check_do_closure (void)
return 0;
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO)
if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
break;
if (p == NULL)
@ -3172,7 +3172,8 @@ check_do_closure (void)
/* At this point, the label doesn't terminate the innermost loop.
Make sure it doesn't terminate another one. */
for (; p; p = p->previous)
if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
&& p->ext.end_do_label == gfc_statement_label)
{
gfc_error ("End of nonblock DO statement at %C is interwoven "
"with another DO loop");
@ -3387,7 +3388,9 @@ parse_do_block (void)
gfc_code *top;
gfc_state_data s;
gfc_symtree *stree;
gfc_exec_op do_op;
do_op = new_st.op;
s.ext.end_do_label = new_st.label1;
if (new_st.ext.iterator != NULL)
@ -3398,7 +3401,8 @@ parse_do_block (void)
accept_statement (ST_DO);
top = gfc_state_stack->tail;
push_state (&s, COMP_DO, gfc_new_block);
push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
gfc_new_block);
s.do_variable = stree;

2
gcc/fortran/parse.h
View File

@ -30,7 +30,7 @@ typedef enum
COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
}
gfc_compile_state;

47
gcc/fortran/resolve.c
View File

@ -58,9 +58,10 @@ code_stack;
static code_stack *cs_base = NULL;
/* Nonzero if we're inside a FORALL block. */
/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
static int forall_flag;
static int do_concurrent_flag;
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@ -3159,11 +3160,18 @@ resolve_function (gfc_expr *expr)
{
if (forall_flag)
{
gfc_error ("reference to non-PURE function '%s' at %L inside a "
gfc_error ("Reference to non-PURE function '%s' at %L inside a "
"FORALL %s", name, &expr->where,
forall_flag == 2 ? "mask" : "block");
t = FAILURE;
}
else if (do_concurrent_flag)
{
gfc_error ("Reference to non-PURE function '%s' at %L inside a "
"DO CONCURRENT %s", name, &expr->where,
do_concurrent_flag == 2 ? "mask" : "block");
t = FAILURE;
}
else if (gfc_pure (NULL))
{
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
@ -3230,6 +3238,9 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
if (forall_flag)
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
sym->name, &c->loc);
else if (do_concurrent_flag)
gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
"PURE", sym->name, &c->loc);
else if (gfc_pure (NULL))
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
&c->loc);
@ -8385,10 +8396,16 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
whether the label is still visible outside of the CRITICAL block,
which is invalid. */
for (stack = cs_base; stack; stack = stack->prev)
if (stack->current->op == EXEC_CRITICAL
&& bitmap_bit_p (stack->reachable_labels, label->value))
gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
" at %L", &code->loc, &label->where);
{
if (stack->current->op == EXEC_CRITICAL
&& bitmap_bit_p (stack->reachable_labels, label->value))
gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
"label at %L", &code->loc, &label->where);
else if (stack->current->op == EXEC_DO_CONCURRENT
&& bitmap_bit_p (stack->reachable_labels, label->value))
gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
"for label at %L", &code->loc, &label->where);
}
return;
}
@ -8409,6 +8426,12 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
" at %L", &code->loc, &label->where);
return;
}
else if (stack->current->op == EXEC_DO_CONCURRENT)
{
gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
"label at %L", &code->loc, &label->where);
return;
}
}
if (stack)
@ -8832,6 +8855,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
case EXEC_DO_CONCURRENT:
case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
@ -9071,7 +9095,7 @@ static void
resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
int forall_save;
int forall_save, do_concurrent_save;
code_stack frame;
gfc_try t;
@ -9085,6 +9109,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
{
frame.current = code;
forall_save = forall_flag;
do_concurrent_save = do_concurrent_flag;
if (code->op == EXEC_FORALL)
{
@ -9117,6 +9142,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
/* Blocks are handled in resolve_select_type because we have
to transform the SELECT TYPE into ASSOCIATE first. */
break;
case EXEC_DO_CONCURRENT:
do_concurrent_flag = 1;
gfc_resolve_blocks (code->block, ns);
do_concurrent_flag = 2;
break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 1;
@ -9134,6 +9164,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr1);
forall_flag = forall_save;
do_concurrent_flag = do_concurrent_save;
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
@ -9401,6 +9432,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
resolve_transfer (code);
break;
case EXEC_DO_CONCURRENT:
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
@ -13570,6 +13602,7 @@ resolve_types (gfc_namespace *ns)
}
forall_flag = 0;
do_concurrent_flag = 0;
gfc_check_interfaces (ns);
gfc_traverse_ns (ns, resolve_values);

1
gcc/fortran/st.c
View File

@ -178,6 +178,7 @@ gfc_free_statement (gfc_code *p)
be freed. */
break;
case EXEC_DO_CONCURRENT:
case EXEC_FORALL:
gfc_free_forall_iterator (p->ext.forall_iterator);
break;

30
gcc/fortran/trans-stmt.c
View File

@ -3514,6 +3514,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
tree maskindex;
tree mask;
tree pmask;
tree cycle_label = NULL_TREE;
int n;
int nvar;
int need_temp;
@ -3703,6 +3704,26 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
gfc_add_expr_to_block (&block, tmp);
}
if (code->op == EXEC_DO_CONCURRENT)
{
gfc_init_block (&body);
cycle_label = gfc_build_label_decl (NULL_TREE);
code->cycle_label = cycle_label;
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&body, tmp);
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_finish_block (&body);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (&block, tmp);
goto done;
}
c = code->block->next;
/* TODO: loop merging in FORALL statements. */
@ -3783,6 +3804,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
c = c->next;
}
done:
/* Restore the original index variables. */
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
@ -3829,6 +3851,14 @@ tree gfc_trans_forall (gfc_code * code)
}
/* Translate the DO CONCURRENT construct. */
tree gfc_trans_do_concurrent (gfc_code * code)
{
return gfc_trans_forall_1 (code, NULL);
}
/* Evaluate the WHERE mask expression, copy its value to a temporary.
If the WHERE construct is nested in FORALL, compute the overall temporary
needed by the WHERE mask expression multiplied by the iterator number of

1
gcc/fortran/trans-stmt.h
View File

@ -51,6 +51,7 @@ tree gfc_trans_if (gfc_code *);
tree gfc_trans_arithmetic_if (gfc_code *);
tree gfc_trans_block_construct (gfc_code *);
tree gfc_trans_do (gfc_code *, tree);
tree gfc_trans_do_concurrent (gfc_code *);
tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);

4
gcc/fortran/trans.c
View File

@ -1303,6 +1303,10 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_do (code, cond);
break;
case EXEC_DO_CONCURRENT:
res = gfc_trans_do_concurrent (code);
break;
case EXEC_DO_WHILE:
res = gfc_trans_do_while (code);
break;

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2011-09-08 Tobias Burnus <burnus@net-b.de>
PR fortran/44646
* gfortran.dg/do_concurrent_1.f90: New.
* gfortran.dg/do_concurrent_2.f90: New.
2011-09-08 Jakub Jelinek <jakub@redhat.com>
PR target/50310

71
gcc/testsuite/gfortran.dg/do_concurrent_1.f90 Normal file
View File

@ -0,0 +1,71 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! PR fortran/44646
!
! DO CONCURRENT
!
implicit none
integer :: i, j
outer: do, concurrent ( i = 1 : 4)
do j = 1, 5
if (j == 1) cycle ! OK
cycle outer ! OK: C821 FIXME
exit outer ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" }
end do
end do outer
do concurrent (j = 1:5)
cycle ! OK
end do
outer2: do j = 1, 7
do concurrent (j=1:5:2) ! cycle outer2 - bad: C821
cycle outer2 ! { dg-error "leaves DO CONCURRENT construct" }
end do
end do outer2
do concurrent ( i = 1 : 4)
exit ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" }
end do
end
subroutine foo()
do concurrent ( i = 1 : 4)
return ! { dg-error "Image control statement RETURN" }
sync all ! { dg-error "Image control statement SYNC" }
call test () ! { dg-error "Subroutine call to .test. in DO CONCURRENT block at .1. is not PURE" }
stop ! { dg-error "Image control statement STOP" }
end do
do concurrent ( i = 1 : 4)
critical ! { dg-error "Image control statement CRITICAL at .1. in DO CONCURRENT block" }
print *, i
! end critical
end do
critical
do concurrent ( i = 1 : 4) ! OK
end do
end critical
end
subroutine caf()
use iso_fortran_env
implicit none
type(lock_type), allocatable :: lock[:]
integer :: i
do, concurrent (i = 1:3)
allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in DO CONCURRENT block" }
lock(lock) ! { dg-error "Image control statement LOCK" }
unlock(lock) ! { dg-error "Image control statement UNLOCK" }
deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in DO CONCURRENT block" }
end do
critical
allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in CRITICAL block" }
lock(lock) ! { dg-error "Image control statement LOCK" }
unlock(lock) ! { dg-error "Image control statement UNLOCK" }
deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in CRITICAL block" }
end critical
end subroutine caf

40
gcc/testsuite/gfortran.dg/do_concurrent_2.f90 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do run }
!
! PR fortran/44646
!
! DO CONCURRENT
!
implicit none
integer :: i, j
integer :: A(5,5)
A = 0.0
do concurrent (i=1:5, j=1:5, (i/=j))
if (i == 5) cycle
A(i,j) = i*j
end do
if (any (A(:,1) /= [0, 2, 3, 4, 0])) call abort()
if (any (A(:,2) /= [2, 0, 6, 8, 0])) call abort()
if (any (A(:,3) /= [3, 6, 0, 12, 0])) call abort()
if (any (A(:,4) /= [4, 8, 12, 0, 0])) call abort()
if (any (A(:,5) /= [5, 10, 15, 20, 0])) call abort()
A = -99
do concurrent (i = 1 : 5)
forall (j=1:4, i/=j)
A(i,j) = i*j
end forall
if (i == 5) then
A(i,i) = -i
end if
end do
if (any (A(:,1) /= [-99, 2, 3, 4, 5])) call abort ()
if (any (A(:,2) /= [ 2, -99, 6, 8, 10])) call abort ()
if (any (A(:,3) /= [ 3, 6, -99, 12, 15])) call abort ()
if (any (A(:,4) /= [ 4, 8, 12, -99, 20])) call abort ()
if (any (A(:,5) /= [-99, -99, -99, -99, -5])) call abort ()
end