From 34186331bdeedb5a8ecae0a9a95d87e8624ea726 Mon Sep 17 00:00:00 2001 From: Nicolas Koenig Date: Sun, 8 Nov 2020 17:07:48 +0100 Subject: Implement stat and errmsg. gcc/fortran/ChangeLog: * trans-decl.c (gfc_sym_mangled_function_id): Whitespace fix. (gfc_build_builtin_function_decls): Correct fn specs. * trans-intrinsic.c (trans_argument): Re-apply fix (?) (conv_cas_reduce): Likewise. (conv_co_collective): Likewise. libgfortran/ChangeLog: * Makefile.am: Add counter_barrier.c and counter_barrier.h * Makefile.in: Regenerate. * generated/nca_minmax_i1.c: Regenerated. * generated/nca_minmax_i16.c: Regenerated. * generated/nca_minmax_i2.c: Regenerated. * generated/nca_minmax_i4.c: Regenerated. * generated/nca_minmax_i8.c: Regenerated. * generated/nca_minmax_r10.c: Regenerated. * generated/nca_minmax_r16.c: Regenerated. * generated/nca_minmax_r4.c: Regenerated. * generated/nca_minmax_r8.c: Regenerated. * generated/nca_minmax_s1.c: Regenerated. * generated/nca_minmax_s4.c: Regenerated. * m4/nca-minmax-s.m4: Add stat and errmsg. * m4/nca_minmax.m4: Likewise. * nca/coarraynative.c (get_master): New function. (test_for_cas_errors): New function. (master_is_image_active): New function. (master_get_num_active_images): New function. (master_bind_active_image_barrier): New function. (error_on_missing_images): New function. (cas_master): New function. * nca/collective_subroutine.c (collsub_sync): Replace pthread_barrier_wait by counter_barrier. (collsub_reduce_array): Add error_on_missing_images. Adjust to number of images. (collsub_reduce_scalar): Likewise. (collsub_iface_init): Likewise. * nca/collective_subroutine.h: Replace pthread_barrier_t by counter_barrier. * nca/libcoarraynative.h: Include counter_barrier.h. Add handling for failed images, stat and errmsg. * nca/sync.c (sync_all_init): Replace pthread_barrir by counter_barrier. (sync_iface_init): Adjust handling to total_num_images. (sync_table): Likewise. (sync_all): LIkewise. * nca/sync.h: Include some theaders, adjust to counter_barrier. * nca/util.h: Add internal_proto to unpack_array_finish. * nca/wrapper.c (cas_collsub_reduce_array): Adjust to total_num_images, handle status and errmsg. (cas_collsub_reduce_scalar): Likewise. (cas_collsub_broadcast_array): Likewise. (cas_collsub_broadcast_scalar): Likewise. (cas_coarray_alloc): Likewise. (cas_coarray_free): Likewise. (cas_coarray_num_images): Likewise. (cas_coarray_sync_all): Likewise. (cas_sync_images): Likewise. * nca/counter_barrier.c: New file. * nca/counter_barrier.h: New file. --- gcc/fortran/trans-decl.c | 47 ++++++++++++++++++++++------------- gcc/fortran/trans-intrinsic.c | 58 ++++++++++++++++++++++++++++++++----------- 2 files changed, 73 insertions(+), 32 deletions(-) (limited to 'gcc') diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ff429d9..4f5b8f0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -460,7 +460,7 @@ gfc_sym_mangled_function_id (gfc_symbol * sym) return get_identifier (sym->binding_label); if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL - || (sym->module != NULL && (sym->attr.external + || (sym->module != NULL && (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY))) && !sym->attr.module_procedure) { @@ -4141,39 +4141,52 @@ gfc_build_builtin_function_decls (void) get_identifier (PREFIX("cas_coarray_sync_all")), ". X ", void_type_node, 1, build_pointer_type (integer_type_node), NULL_TREE); gfor_fndecl_cas_sync_images = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("cas_sync_images")), ". R R X X X ", + get_identifier (PREFIX("cas_sync_images")), ". R R w w . ", void_type_node, 5, integer_type_node, pint_type, pint_type, - pchar_type_node, size_type_node, NULL_TREE); + pchar_type_node, size_type_node); gfor_fndecl_cas_lock = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("cas_lock")), ". w ", void_type_node, 1, - pvoid_type_node, NULL_TREE); + pvoid_type_node); gfor_fndecl_cas_unlock = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("cas_unlock")), ". w ", void_type_node, 1, - pvoid_type_node, NULL_TREE); + pvoid_type_node); gfor_fndecl_cas_reduce_scalar = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("cas_collsub_reduce_scalar")), ". w r W ", - void_type_node, 3, pvoid_type_node, + get_identifier (PREFIX("cas_collsub_reduce_scalar")), ". w . r r w w . ", + void_type_node, 7, pvoid_type_node, /* object. */ + size_type_node, /* elem_size. */ build_pointer_type (build_function_type_list (void_type_node, - pvoid_type_node, pvoid_type_node, NULL_TREE)), - pint_type, NULL_TREE); + pvoid_type_node, pvoid_type_node, NULL_TREE)), /* assign function. */ + pint_type, /* result_image. */ + pint_type, /* stat. */ + pchar_type_node, /* errmsg. */ + size_type_node /* errmsg_len. */); gfor_fndecl_cas_reduce_array = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("cas_collsub_reduce_array")), ". w r W R ", - void_type_node, 4, pvoid_type_node, + get_identifier (PREFIX("cas_collsub_reduce_array")), ". W r r w w . ", + void_type_node, 6, pvoid_type_node /* desc. */, build_pointer_type (build_function_type_list (void_type_node, - pvoid_type_node, pvoid_type_node, NULL_TREE)), - pint_type, integer_type_node, NULL_TREE); + pvoid_type_node, pvoid_type_node, NULL_TREE)) /* assign function. */, + pint_type, /* result_image. */ + pint_type, /* stat. */ + pchar_type_node, /* errmsg. */ + size_type_node /* errmsg_len. */ ); gfor_fndecl_cas_broadcast_scalar = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX ("cas_collsub_broadcast_scalar")), ". w . . ", - void_type_node, 3, pvoid_type_node, size_type_node, integer_type_node); + get_identifier (PREFIX ("cas_collsub_broadcast_scalar")), ". w . . w w . ", + void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, + pint_type, /* stat. */ + pchar_type_node, /* errmsg. */ + size_type_node /* errmsg_len. */ ); gfor_fndecl_cas_broadcast_array = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX ("cas_collsub_broadcast_array")), ". W . ", - void_type_node, 2, pvoid_type_node, integer_type_node); + get_identifier (PREFIX ("cas_collsub_broadcast_array")), ". W . w w . ", + void_type_node, 5, pvoid_type_node, integer_type_node, + pint_type, /* stat. */ + pchar_type_node, /* errmsg. */ + size_type_node /* errmsg_len. */ ); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index f9df1c9..7824dcf 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -11098,34 +11098,42 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, } } -/* Helper function - translate an argument and advance to the next. - Coarrays are irrelevant here, since we just translate normal arguments. */ +/* Helper function - translate an argument and advance to the next. + Coarrays are irrelevant here, since we just translate normal + arguments. */ static tree trans_argument (gfc_actual_arglist **curr_al, stmtblock_t *blk, stmtblock_t *postblk, gfc_se *argse, tree def) { - if (!(*curr_al)->expr) + gfc_expr *expr = (*curr_al)->expr; + + *curr_al = (*curr_al)->next; + + if (expr == NULL) return def; - if ((*curr_al)->expr->rank > 0) - gfc_conv_expr_descriptor (argse, (*curr_al)->expr); + + if (expr->rank > 0) + gfc_conv_expr_descriptor (argse, expr); else - gfc_conv_expr (argse, (*curr_al)->expr); + gfc_conv_expr (argse, expr); + gfc_add_block_to_block (blk, &argse->pre); gfc_add_block_to_block (postblk, &argse->post); - *curr_al = (*curr_al)->next; + return argse->expr; } -/* Convert CO_REDUCE for native coarrays. */ +/* Convert CO_REDUCE for shared coarrays. */ static tree conv_cas_reduce (gfc_code *code, stmtblock_t *blk, stmtblock_t *postblk) { gfc_actual_arglist *curr_al; - tree var, reduce_op, result_image, elem_size; + tree var, reduce_op, result_image, elem_size, stat, errmsg, errmsg_len; gfc_se argse; int is_array; + bool has_errmsg; curr_al = code->ext.actual; @@ -11144,14 +11152,34 @@ conv_cas_reduce (gfc_code *code, stmtblock_t *blk, stmtblock_t *postblk) argse.want_pointer = 1; result_image = trans_argument (&curr_al, blk, postblk, &argse, null_pointer_node); - + + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + stat = trans_argument (&curr_al, blk, postblk, &argse, null_pointer_node); + + has_errmsg = curr_al->expr != NULL; + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + errmsg = trans_argument (&curr_al, blk, postblk, &argse, null_pointer_node); + + if (has_errmsg) + { + errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + errmsg_len = build_zero_cst (size_type_node); + } + if (is_array) return build_call_expr_loc (input_location, gfor_fndecl_cas_reduce_array, - 3, var, reduce_op, result_image); + 6, var, reduce_op, result_image, stat, errmsg, + errmsg_len); elem_size = size_in_bytes(TREE_TYPE(TREE_TYPE(var))); - return build_call_expr_loc (input_location, gfor_fndecl_cas_reduce_scalar, 4, - var, elem_size, reduce_op, result_image); + return build_call_expr_loc (input_location, gfor_fndecl_cas_reduce_scalar, 7, + var, elem_size, reduce_op, result_image, stat, + errmsg, errmsg_len); } static tree @@ -11184,7 +11212,7 @@ conv_cas_broadcast (gfc_code *code, stmtblock_t *blk, stmtblock_t *postblk) static tree conv_co_collective (gfc_code *); -/* Convert collective subroutines for native coarrays. */ +/* Convert collective subroutines for shared coarrays. */ static tree conv_cas_collective (gfc_code *code) @@ -11336,7 +11364,7 @@ conv_co_collective (gfc_code *code) errmsg_len = build_zero_cst (size_type_node); } - /* For native coarrays, we only come here for CO_BROADCAST. */ + /* For shared coarrays, we only come here for CO_BROADCAST. */ gcc_assert (code->resolved_isym->id == GFC_ISYM_CO_BROADCAST || flag_coarray != GFC_FCOARRAY_SHARED); -- cgit v1.1