2014-07-12 Tobias Burnus <burnus@net-b.de>

gcc/fortran/
        * libgfortran.h (libcaf_atomic_codes): Add.
        * trans-decl.c (gfor_fndecl_caf_atomic_def,
        gfor_fndecl_caf_atomic_ref, gfor_fndecl_caf_atomic_cas,
        gfor_fndecl_caf_atomic_op): New variables.
        (gfc_build_builtin_function_decls): Initialize them.
        * trans.h (gfor_fndecl_caf_atomic_def,
        gfor_fndecl_caf_atomic_ref, gfor_fndecl_caf_atomic_cas,
        gfor_fndecl_caf_atomic_op): New variables.
        * trans-intrinsic.c (conv_intrinsic_atomic_op,
        conv_intrinsic_atomic_ref, conv_intrinsic_atomic_cas):
        Add library calls with -fcoarray=lib.

libgfortran/
        * caf/libcaf.h (_gfortran_caf_atomic_define,
        _gfortran_caf_atomic_ref, _gfortran_caf_atomic_op,
        _gfortran_caf_atomic_cas): New prototypes.
        * caf/single.c (_gfortran_caf_atomic_define,
        _gfortran_caf_atomic_ref, _gfortran_caf_atomic_op,
        _gfortran_caf_atomic_cas): New functions.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@212484 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 270 insertions, 81 deletions

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a285e9d6723..57b7f4d1b30 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7007,7 +7007,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
     gfc_conv_expr_reference (se, arg_expr);
   else
     gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
-  se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
+  se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
    
   /* Create a temporary variable for loc return value.  Without this, 
      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
@@ -8341,11 +8341,11 @@ conv_co_minmaxsum (gfc_code *code)
 static tree
 conv_intrinsic_atomic_op (gfc_code *code)
 {
-  gfc_se atom, value, old;
-  tree tmp;
+  gfc_se argse;
+  tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
   stmtblock_t block, post_block;
   gfc_expr *atom_expr = code->ext.actual->expr;
-  gfc_expr *stat;
+  gfc_expr *stat_expr;
   built_in_function fn;
 
   if (atom_expr->expr_type == EXPR_FUNCTION
@@ -8355,15 +8355,129 @@ conv_intrinsic_atomic_op (gfc_code *code)
 
   gfc_start_block (&block);
   gfc_init_block (&post_block);
-  gfc_init_se (&atom, NULL);
-  gfc_init_se (&value, NULL);
-  atom.want_pointer = 1;
-  gfc_conv_expr (&atom, atom_expr);
-  gfc_add_block_to_block (&block, &atom.pre);
-  gfc_add_block_to_block (&post_block, &atom.post);
-  gfc_conv_expr (&value, code->ext.actual->next->expr);
-  gfc_add_block_to_block (&block, &value.pre);
-  gfc_add_block_to_block (&post_block, &value.post);
+
+  gfc_init_se (&argse, NULL);
+  argse.want_pointer = 1;
+  gfc_conv_expr (&argse, atom_expr);
+  gfc_add_block_to_block (&block, &argse.pre);
+  gfc_add_block_to_block (&post_block, &argse.post);
+  atom = argse.expr;
+
+  gfc_init_se (&argse, NULL);
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB
+      && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
+    argse.want_pointer = 1;
+  gfc_conv_expr (&argse, code->ext.actual->next->expr);
+  gfc_add_block_to_block (&block, &argse.pre);
+  gfc_add_block_to_block (&post_block, &argse.post);
+  value = argse.expr;
+
+  switch (code->resolved_isym->id)
+    {
+    case GFC_ISYM_ATOMIC_ADD:
+    case GFC_ISYM_ATOMIC_AND:
+    case GFC_ISYM_ATOMIC_DEF:
+    case GFC_ISYM_ATOMIC_OR:
+    case GFC_ISYM_ATOMIC_XOR:
+      stat_expr = code->ext.actual->next->next->expr;
+      if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+	old = null_pointer_node;
+      break;
+    default:
+      gfc_init_se (&argse, NULL);
+      if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+	argse.want_pointer = 1;
+      gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
+      gfc_add_block_to_block (&block, &argse.pre);
+      gfc_add_block_to_block (&post_block, &argse.post);
+      old = argse.expr;
+      stat_expr = code->ext.actual->next->next->next->expr;
+    }
+
+  /* STAT=  */
+  if (stat_expr != NULL)
+    {
+      gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+	argse.want_pointer = 1;
+      gfc_conv_expr_val (&argse, stat_expr);
+      gfc_add_block_to_block (&block, &argse.pre);
+      gfc_add_block_to_block (&post_block, &argse.post);
+      stat = argse.expr;
+    }
+  else if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    stat = null_pointer_node;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree image_index, caf_decl, offset, token;
+      int op;
+
+      switch (code->resolved_isym->id)
+	{
+	case GFC_ISYM_ATOMIC_ADD:
+	case GFC_ISYM_ATOMIC_FETCH_ADD:
+	  op = (int) GFC_CAF_ATOMIC_ADD;
+	  break;
+	case GFC_ISYM_ATOMIC_AND:
+	case GFC_ISYM_ATOMIC_FETCH_AND:
+	  op = (int) GFC_CAF_ATOMIC_AND;
+	  break;
+	case GFC_ISYM_ATOMIC_OR:
+	case GFC_ISYM_ATOMIC_FETCH_OR:
+	  op = (int) GFC_CAF_ATOMIC_OR;
+	  break;
+	case GFC_ISYM_ATOMIC_XOR:
+	case GFC_ISYM_ATOMIC_FETCH_XOR:
+	  op = (int) GFC_CAF_ATOMIC_XOR;
+	  break;
+	case GFC_ISYM_ATOMIC_DEF:
+	  op = 0;  /* Unused.  */
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+
+      caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
+      if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
+	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
+
+      if (gfc_is_coindexed (atom_expr))
+	image_index = caf_get_image_index (&block, atom_expr, caf_decl);
+      else
+	image_index = integer_zero_node;
+
+      if (TREE_TYPE (TREE_TYPE (atom)) != TREE_TYPE (TREE_TYPE (value)))
+	{
+	  tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
+	  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
+          value = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
+
+      if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
+	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
+				   token, offset, image_index, value, stat,
+				   build_int_cst (integer_type_node,
+						  (int) atom_expr->ts.type),
+				   build_int_cst (integer_type_node,
+						  (int) atom_expr->ts.kind));
+      else
+	tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
+				   build_int_cst (integer_type_node, op),
+				   token, offset, image_index, value, old, stat,
+				   build_int_cst (integer_type_node,
+						  (int) atom_expr->ts.type),
+				   build_int_cst (integer_type_node,
+						  (int) atom_expr->ts.kind));
+
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&block, &post_block);
+      return gfc_finish_block (&block);
+    }
+
 
   switch (code->resolved_isym->id)
     {
@@ -8390,12 +8504,12 @@ conv_intrinsic_atomic_op (gfc_code *code)
       gcc_unreachable ();
     }
 
-  tmp = TREE_TYPE (TREE_TYPE (atom.expr));
+  tmp = TREE_TYPE (TREE_TYPE (atom));
   fn = (built_in_function) ((int) fn
 			    + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
 			    + 1);
   tmp = builtin_decl_explicit (fn);
-  tree itype = TREE_TYPE (TREE_TYPE (atom.expr));
+  tree itype = TREE_TYPE (TREE_TYPE (atom));
   tmp = builtin_decl_explicit (fn);
 
   switch (code->resolved_isym->id)
@@ -8405,37 +8519,21 @@ conv_intrinsic_atomic_op (gfc_code *code)
     case GFC_ISYM_ATOMIC_DEF:
     case GFC_ISYM_ATOMIC_OR:
     case GFC_ISYM_ATOMIC_XOR:
-      stat = code->ext.actual->next->next->expr;
-      tmp = build_call_expr_loc (input_location, tmp, 3, atom.expr,
-				 fold_convert (itype, value.expr),
+      tmp = build_call_expr_loc (input_location, tmp, 3, atom,
+				 fold_convert (itype, value),
 				 build_int_cst (NULL, MEMMODEL_RELAXED));
       gfc_add_expr_to_block (&block, tmp);
       break;
     default:
-      stat = code->ext.actual->next->next->next->expr;
-      gfc_init_se (&old, NULL);
-      gfc_conv_expr (&old, code->ext.actual->next->next->expr);
-      gfc_add_block_to_block (&block, &old.pre);
-      gfc_add_block_to_block (&post_block, &old.post);
-      tmp = build_call_expr_loc (input_location, tmp, 3, atom.expr,
-				 fold_convert (itype, value.expr),
+      tmp = build_call_expr_loc (input_location, tmp, 3, atom,
+				 fold_convert (itype, value),
 				 build_int_cst (NULL, MEMMODEL_RELAXED));
-      gfc_add_modify (&block, old.expr,
-		      fold_convert (TREE_TYPE (old.expr), tmp));
+      gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
       break;
     }
 
-  /* STAT=  */
-  if (stat != NULL)
-    {
-      gcc_assert (stat->expr_type == EXPR_VARIABLE);
-      gfc_init_se (&value, NULL);
-      gfc_conv_expr_val (&value, stat);
-      gfc_add_block_to_block (&block, &value.pre);
-      gfc_add_block_to_block (&post_block, &value.post);
-      gfc_add_modify (&block, value.expr,
-		      build_int_cst (TREE_TYPE (value.expr), 0));
-    }
+  if (stat != NULL_TREE)
+    gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
   gfc_add_block_to_block (&block, &post_block);
   return gfc_finish_block (&block);
 }
@@ -8444,8 +8542,8 @@ conv_intrinsic_atomic_op (gfc_code *code)
 static tree
 conv_intrinsic_atomic_ref (gfc_code *code)
 {
-  gfc_se atom, value;
-  tree tmp;
+  gfc_se argse;
+  tree tmp, atom, value, stat = NULL_TREE;
   stmtblock_t block, post_block;
   built_in_function fn;
   gfc_expr *atom_expr = code->ext.actual->next->expr;
@@ -8457,39 +8555,75 @@ conv_intrinsic_atomic_ref (gfc_code *code)
 
   gfc_start_block (&block);
   gfc_init_block (&post_block);
-  gfc_init_se (&atom, NULL);
-  gfc_init_se (&value, NULL);
-  atom.want_pointer = 1;
-  gfc_conv_expr (&value, code->ext.actual->expr);
-  gfc_add_block_to_block (&block, &value.pre);
-  gfc_add_block_to_block (&post_block, &value.post);
-  gfc_conv_expr (&atom, atom_expr);
-  gfc_add_block_to_block (&block, &atom.pre);
-  gfc_add_block_to_block (&post_block, &atom.post);
-
-  tmp = TREE_TYPE (TREE_TYPE (atom.expr));
-  fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
-			    + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
-			    + 1);
-  tmp = builtin_decl_explicit (fn);
-  tmp = build_call_expr_loc (input_location, tmp, 2, atom.expr,
-			     build_int_cst (integer_type_node,
-					    MEMMODEL_RELAXED));
-  gfc_add_modify (&block, value.expr,
-		  fold_convert (TREE_TYPE (value.expr), tmp));
-  
+  gfc_init_se (&argse, NULL);
+  argse.want_pointer = 1;
+  gfc_conv_expr (&argse, atom_expr);
+  gfc_add_block_to_block (&block, &argse.pre);
+  gfc_add_block_to_block (&post_block, &argse.post);
+  atom = argse.expr;
+
+  gfc_init_se (&argse, NULL);
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    argse.want_pointer = 1;
+  gfc_conv_expr (&argse, code->ext.actual->expr);
+  gfc_add_block_to_block (&block, &argse.pre);
+  gfc_add_block_to_block (&post_block, &argse.post);
+  value = argse.expr;
+
   /* STAT=  */
   if (code->ext.actual->next->next->expr != NULL)
     {
       gcc_assert (code->ext.actual->next->next->expr->expr_type
 		  == EXPR_VARIABLE);
-      gfc_init_se (&value, NULL);
-      gfc_conv_expr_val (&value, code->ext.actual->next->next->expr);
-      gfc_add_block_to_block (&block, &value.pre);
-      gfc_add_block_to_block (&post_block, &value.post);
-      gfc_add_modify (&block, value.expr,
-		      build_int_cst (TREE_TYPE (value.expr), 0));
+      gfc_init_se (&argse, NULL);
+      if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+	argse.want_pointer = 1;
+      gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
+      gfc_add_block_to_block (&block, &argse.pre);
+      gfc_add_block_to_block (&post_block, &argse.post);
+      stat = argse.expr;
+    }
+  else if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    stat = null_pointer_node;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree image_index, caf_decl, offset, token;
+
+      caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
+      if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
+	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
+
+      if (gfc_is_coindexed (atom_expr))
+	image_index = caf_get_image_index (&block, atom_expr, caf_decl);
+      else
+	image_index = integer_zero_node;
+
+      get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
+				 token, offset, image_index, value, stat,
+				 build_int_cst (integer_type_node,
+						(int) atom_expr->ts.type),
+				 build_int_cst (integer_type_node,
+						(int) atom_expr->ts.kind));
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&block, &post_block);
+      return gfc_finish_block (&block);
     }
+
+  tmp = TREE_TYPE (TREE_TYPE (atom));
+  fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
+			    + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
+			    + 1);
+  tmp = builtin_decl_explicit (fn);
+  tmp = build_call_expr_loc (input_location, tmp, 2, atom,
+			     build_int_cst (integer_type_node,
+					    MEMMODEL_RELAXED));
+  gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
+
+  if (stat != NULL_TREE)
+    gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
   gfc_add_block_to_block (&block, &post_block);
   return gfc_finish_block (&block);
 }
@@ -8499,7 +8633,7 @@ static tree
 conv_intrinsic_atomic_cas (gfc_code *code)
 {
   gfc_se argse;
-  tree tmp, atom, old, new_val, comp;
+  tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
   stmtblock_t block, post_block;
   built_in_function fn;
   gfc_expr *atom_expr = code->ext.actual->expr;
@@ -8517,23 +8651,89 @@ conv_intrinsic_atomic_cas (gfc_code *code)
   atom = argse.expr;
 
   gfc_init_se (&argse, NULL);
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    argse.want_pointer = 1;
   gfc_conv_expr (&argse, code->ext.actual->next->expr);
   gfc_add_block_to_block (&block, &argse.pre);
   gfc_add_block_to_block (&post_block, &argse.post);
   old = argse.expr;
 
   gfc_init_se (&argse, NULL);
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    argse.want_pointer = 1;
   gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
   gfc_add_block_to_block (&block, &argse.pre);
   gfc_add_block_to_block (&post_block, &argse.post);
   comp = argse.expr;
 
   gfc_init_se (&argse, NULL);
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB
+      && code->ext.actual->next->next->next->expr->ts.kind
+	 == atom_expr->ts.kind)
+    argse.want_pointer = 1;
   gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
   gfc_add_block_to_block (&block, &argse.pre);
   gfc_add_block_to_block (&post_block, &argse.post);
   new_val = argse.expr;
 
+  /* STAT=  */
+  if (code->ext.actual->next->next->next->next->expr != NULL)
+    {
+      gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
+		  == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+	argse.want_pointer = 1;
+      gfc_conv_expr_val (&argse,
+			 code->ext.actual->next->next->next->next->expr);
+      gfc_add_block_to_block (&block, &argse.pre);
+      gfc_add_block_to_block (&post_block, &argse.post);
+      stat = argse.expr;
+    }
+  else if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    stat = null_pointer_node;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree image_index, caf_decl, offset, token;
+
+      caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
+      if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
+	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
+
+      if (gfc_is_coindexed (atom_expr))
+	image_index = caf_get_image_index (&block, atom_expr, caf_decl);
+      else
+	image_index = integer_zero_node;
+
+      if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
+	{
+	  tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
+	  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
+          new_val = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      /* Convert a constant to a pointer.  */
+      if (!POINTER_TYPE_P (TREE_TYPE (comp)))
+	{
+	  tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
+	  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
+          comp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
+				 token, offset, image_index, old, comp, new_val,
+				 stat, build_int_cst (integer_type_node,
+						      (int) atom_expr->ts.type),
+				 build_int_cst (integer_type_node,
+						(int) atom_expr->ts.kind));
+      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&block, &post_block);
+      return gfc_finish_block (&block);
+    }
+
   tmp = TREE_TYPE (TREE_TYPE (atom));
   fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
 			    + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
@@ -8549,19 +8749,8 @@ conv_intrinsic_atomic_cas (gfc_code *code)
 			     build_int_cst (NULL, MEMMODEL_RELAXED));
   gfc_add_expr_to_block (&block, tmp);
   
-  /* STAT=  */
-  if (code->ext.actual->next->next->next->next->expr != NULL)
-    {
-      gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
-		  == EXPR_VARIABLE);
-      gfc_init_se (&argse, NULL);
-      gfc_conv_expr_val (&argse,
-			 code->ext.actual->next->next->next->next->expr);
-      gfc_add_block_to_block (&block, &argse.pre);
-      gfc_add_block_to_block (&post_block, &argse.post);
-      gfc_add_modify (&block, argse.expr,
-		      build_int_cst (TREE_TYPE (argse.expr), 0));
-    }
+  if (stat != NULL_TREE)
+    gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
   gfc_add_block_to_block (&block, &post_block);
   return gfc_finish_block (&block);
 }