git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

libgfortran.h (libcaf_atomic_codes): Add. 

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.

From-SVN: r212484
This commit is contained in:
Tobias Burnus 2014-07-12 21:02:57 +02:00 committed by Tobias Burnus
parent 7f4aaf912b
commit 42a8246dbd
8 changed files with 429 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View File

@ -1,3 +1,17 @@
2014-07-12 Tobias Burnus <burnus@net-b.de>
* 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.
2014-07-12 Tobias Burnus <burnus@net-b.de>
* check.c (gfc_check_atomic): Update for STAT=.

8
gcc/fortran/libgfortran.h
View File

@ -120,6 +120,14 @@ typedef enum
}
libgfortran_stat_codes;
typedef enum
{
GFC_CAF_ATOMIC_ADD = 1,
GFC_CAF_ATOMIC_AND,
GFC_CAF_ATOMIC_OR,
GFC_CAF_ATOMIC_XOR
} libcaf_atomic_codes;
/* Default unit number for preconnected standard input and output. */
#define GFC_STDIN_UNIT_NUMBER 5
#define GFC_STDOUT_UNIT_NUMBER 6

26
gcc/fortran/trans-decl.c
View File

@ -141,6 +141,10 @@ tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_images;
tree gfor_fndecl_caf_error_stop;
tree gfor_fndecl_caf_error_stop_str;
tree gfor_fndecl_caf_atomic_def;
tree gfor_fndecl_caf_atomic_ref;
tree gfor_fndecl_caf_atomic_cas;
tree gfor_fndecl_caf_atomic_op;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
tree gfor_fndecl_co_sum;
@ -3391,6 +3395,28 @@ gfc_build_builtin_function_decls (void)
/* CAF's ERROR STOP doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_atomic_define")), "R..RW",
void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
pvoid_type_node, pint_type, integer_type_node, integer_type_node);
gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_atomic_ref")), "R..WW",
void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
pvoid_type_node, pint_type, integer_type_node, integer_type_node);
gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_atomic_cas")), "R..WRRW",
void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node,
pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type,
integer_type_node, integer_type_node);
gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_atomic_op")), ".R..RWW",
void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node,
integer_type_node, pvoid_type_node, pvoid_type_node, pint_type,
integer_type_node, integer_type_node);
gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_max")), "W.WW",
void_type_node, 6, pvoid_type_node, integer_type_node,

349
gcc/fortran/trans-intrinsic.c
View File

@ -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);
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;
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));
/* 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);
}

4
gcc/fortran/trans.h
View File

@ -720,6 +720,10 @@ extern GTY(()) tree gfor_fndecl_caf_sync_all;
extern GTY(()) tree gfor_fndecl_caf_sync_images;
extern GTY(()) tree gfor_fndecl_caf_error_stop;
extern GTY(()) tree gfor_fndecl_caf_error_stop_str;
extern GTY(()) tree gfor_fndecl_caf_atomic_def;
extern GTY(()) tree gfor_fndecl_caf_atomic_ref;
extern GTY(()) tree gfor_fndecl_caf_atomic_cas;
extern GTY(()) tree gfor_fndecl_caf_atomic_op;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
extern GTY(()) tree gfor_fndecl_co_sum;

9
libgfortran/ChangeLog
View File

@ -1,3 +1,12 @@
2014-07-12 Tobias Burnus <burnus@net-b.de>
* 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.
2014-07-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* config/fpu-*.h (get_fpu_rounding_mode, set_fpu_rounding_mode,

9
libgfortran/caf/libcaf.h
View File

@ -128,4 +128,13 @@ void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *,
void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, caf_token_t, size_t, int,
gfc_descriptor_t *, caf_vector_t *, int, int);
void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *,
int, int);
void _gfortran_caf_atomic_ref (caf_token_t, size_t, int, void *, int *,
int, int);
void _gfortran_caf_atomic_cas (caf_token_t, size_t, int, void *, void *,
void *, int *, int, int);
void _gfortran_caf_atomic_op (int, caf_token_t, size_t, int, void *, void *,
int *, int, int);
#endif /* LIBCAF_H */

90
libgfortran/caf/single.c
View File

@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include <stdlib.h> /* For exit and malloc. */
#include <string.h> /* For memcpy and memset. */
#include <stdarg.h> /* For variadic arguments. */
#include <assert.h>
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
@ -774,3 +775,92 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
src, dst_len, src_len);
GFC_DESCRIPTOR_DATA (src) = src_base;
}
void
_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
void *value, int *stat,
int type __attribute__ ((unused)), int kind)
{
assert(kind == 4);
uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
__atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
if (stat)
*stat = 0;
}
void
_gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
void *value, int *stat,
int type __attribute__ ((unused)), int kind)
{
assert(kind == 4);
uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
__atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
if (stat)
*stat = 0;
}
void
_gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
void *old, void *compare, void *new_val, int *stat,
int type __attribute__ ((unused)), int kind)
{
assert(kind == 4);
uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
*(uint32_t *) old = *(uint32_t *) compare;
(void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
*(uint32_t *) new_val, false,
__ATOMIC_RELAXED, __ATOMIC_RELAXED);
if (stat)
*stat = 0;
}
void
_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
void *value, void *old, int *stat,
int type __attribute__ ((unused)), int kind)
{
assert(kind == 4);
uint32_t res;
uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
switch (op)
{
case GFC_CAF_ATOMIC_ADD:
res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
break;
case GFC_CAF_ATOMIC_AND:
res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
break;
case GFC_CAF_ATOMIC_OR:
res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
break;
case GFC_CAF_ATOMIC_XOR:
res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
break;
default:
__builtin_unreachable();
}
if (old)
*(uint32_t *) old = res;
if (stat)
*stat = 0;
}