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

gcc/fortran/ChangeLog

+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

gcc/fortran/decl.c

@@ -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;

gcc/fortran/dump-parse-tree.c

@@ -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);

gcc/fortran/frontend-passes.c

@@ -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)

gcc/fortran/gfortran.h

@@ -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,

gcc/fortran/parse.c

@@ -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;
 

gcc/fortran/parse.h

@@ -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;
 

gcc/fortran/resolve.c

@@ -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);

gcc/fortran/st.c

@@ -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;

gcc/fortran/trans-stmt.c

@@ -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

gcc/fortran/trans-stmt.h

@@ -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);

gcc/fortran/trans.c

@@ -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;

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/do_concurrent_1.f90

+! { 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

gcc/testsuite/gfortran.dg/do_concurrent_2.f90

+! { 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