From 60386f50ceca766476f4e22f1c78c56865d9bc9d Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sun, 27 Mar 2011 10:30:28 +0200 Subject: [PATCH] re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 2011-03-27 Tobias Burnus PR fortran/18918 * gfortran.h (gfc_isym_id): Rename GFC_ISYM_NUMIMAGES to GFC_ISYM_NUM_IMAGES. (gfc_fcoarray): Add GFC_FCOARRAY_LIB. * intrinsic.c (add_functions): Update due to GFC_ISYM_NUM_IMAGES rename. * invoke.texi (-fcoarray=): Document "lib" argument. * iresolve.c (gfc_resolve_this_image): Fix THIS IMAGE(). * libgfortran.h (libgfortran_stat_codes): Add comments. * options.c (gfc_handle_coarray_option): Add -fcoarray=lib. * simplify.c (gfc_simplify_num_images, gfc_simplify_this_image): Handle GFC_FCOARRAY_LIB. * trans.h (gfc_init_coarray_decl): New prototype. (gfor_fndecl_caf_init, gfor_fndecl_caf_finalize, gfor_fndecl_caf_critical, gfor_fndecl_caf_end_critical, gfor_fndecl_caf_sync_all, gfor_fndecl_caf_sync_images, gfor_fndecl_caf_error_stop, gfor_fndecl_caf_error_stop_str, gfort_gvar_caf_num_images, gfort_gvar_caf_this_image): New global variables. * trans-decl.c: Declare several CAF functions (cf. above). (gfc_build_builtin_function_decls): Initialize those. (gfc_init_coarray_decl): New function. (create_main_function): Call CAF init/finalize functions. * trans-intrinsic.c (trans_this_image, trans_num_images): New. (gfc_conv_intrinsic_function): Call those. * trans-stmt.c (gfc_trans_stop, gfc_trans_sync, * gfc_trans_critical): Add code for GFC_FCOARRAY_LIB. From-SVN: r171568 --- gcc/fortran/ChangeLog | 30 ++++++ gcc/fortran/gfortran.h | 5 +- gcc/fortran/intrinsic.c | 3 +- gcc/fortran/invoke.texi | 6 +- gcc/fortran/iresolve.c | 12 ++- gcc/fortran/libgfortran.h | 5 +- gcc/fortran/options.c | 4 +- gcc/fortran/simplify.c | 6 ++ gcc/fortran/trans-decl.c | 124 +++++++++++++++++++++++ gcc/fortran/trans-intrinsic.c | 24 ++++- gcc/fortran/trans-stmt.c | 185 ++++++++++++++++++++++++++++++---- gcc/fortran/trans.h | 21 +++- 12 files changed, 394 insertions(+), 31 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8f44a093275..e266fc3db72 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,33 @@ +2011-03-27 Tobias Burnus + + PR fortran/18918 + * gfortran.h (gfc_isym_id): Rename GFC_ISYM_NUMIMAGES to + GFC_ISYM_NUM_IMAGES. + (gfc_fcoarray): Add GFC_FCOARRAY_LIB. + * intrinsic.c (add_functions): Update due to GFC_ISYM_NUM_IMAGES + rename. + * invoke.texi (-fcoarray=): Document "lib" argument. + * iresolve.c (gfc_resolve_this_image): Fix THIS IMAGE(). + * libgfortran.h (libgfortran_stat_codes): Add comments. + * options.c (gfc_handle_coarray_option): Add -fcoarray=lib. + * simplify.c (gfc_simplify_num_images, gfc_simplify_this_image): + Handle GFC_FCOARRAY_LIB. + * trans.h (gfc_init_coarray_decl): New prototype. + (gfor_fndecl_caf_init, gfor_fndecl_caf_finalize, + gfor_fndecl_caf_critical, gfor_fndecl_caf_end_critical, + gfor_fndecl_caf_sync_all, gfor_fndecl_caf_sync_images, + gfor_fndecl_caf_error_stop, gfor_fndecl_caf_error_stop_str, + gfort_gvar_caf_num_images, gfort_gvar_caf_this_image): + New global variables. + * trans-decl.c: Declare several CAF functions (cf. above). + (gfc_build_builtin_function_decls): Initialize those. + (gfc_init_coarray_decl): New function. + (create_main_function): Call CAF init/finalize functions. + * trans-intrinsic.c (trans_this_image, trans_num_images): New. + (gfc_conv_intrinsic_function): Call those. + * trans-stmt.c (gfc_trans_stop, gfc_trans_sync, gfc_trans_critical): + Add code for GFC_FCOARRAY_LIB. + 2011-03-26 Janus Weil PR fortran/48291 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cd71f3b1de3..eec737c10c0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -458,7 +458,7 @@ enum gfc_isym_id GFC_ISYM_NORM2, GFC_ISYM_NOT, GFC_ISYM_NULL, - GFC_ISYM_NUMIMAGES, + GFC_ISYM_NUM_IMAGES, GFC_ISYM_OR, GFC_ISYM_PACK, GFC_ISYM_PARITY, @@ -572,7 +572,8 @@ init_local_integer; typedef enum { GFC_FCOARRAY_NONE = 0, - GFC_FCOARRAY_SINGLE + GFC_FCOARRAY_SINGLE, + GFC_FCOARRAY_LIB } gfc_fcoarray; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 80dbaa8dd4a..0fea0786e9c 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2358,7 +2358,8 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); - add_sym_0 ("num_images", GFC_ISYM_NUMIMAGES, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + add_sym_0 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, NULL, gfc_simplify_num_images, NULL); add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index d7388d0616c..5441dbcc121 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -166,7 +166,7 @@ and warnings}. -fwhole-file -fsecond-underscore @gol -fbounds-check -fcheck-array-temporaries -fmax-array-constructor =@var{n} @gol -fcheck=@var{} @gol --fcoarray=@var{} -fmax-stack-var-size=@var{n} @gol +-fcoarray=@var{} -fmax-stack-var-size=@var{n} @gol -fpack-derived -frepack-arrays -fshort-enums -fexternal-blas @gol -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol -finit-integer=@var{n} -finit-real=@var{} @gol @@ -1249,6 +1249,10 @@ statements will produce a compile-time error. (Default) @item @samp{single} Single-image mode, i.e. @code{num_images()} is always one. + +@item @samp{lib} +Library-based coarray parallelization; a suitable GNU Fortran coarray +library needs to be linked. @end table diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index d8309d27f85..5042db37944 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1,6 +1,6 @@ /* Intrinsic function resolution. Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, - 2009, 2010 + 2009, 2010, 2011 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb @@ -2556,7 +2556,15 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, void gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim) { - resolve_bound (f, array, dim, NULL, "__this_image", true); + static char this_image[] = "__this_image"; + if (array) + resolve_bound (f, array, dim, NULL, "__this_image", true); + else + { + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; + } } diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 85a73d8166c..09524d00357 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -1,5 +1,5 @@ /* Header file to the Fortran front-end and runtime library - Copyright (C) 2007, 2008, 2009, 2010 + Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This file is part of GCC. @@ -98,12 +98,13 @@ typedef enum } libgfortran_error_codes; +/* Must kept in sync with libgfortrancaf.h. */ typedef enum { GFC_STAT_UNLOCKED = 0, GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, - GFC_STAT_STOPPED_IMAGE + GFC_STAT_STOPPED_IMAGE /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ } libgfortran_stat_codes; diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 172fed8b49a..cb14c3ad296 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -1,6 +1,6 @@ /* Parse and display command line options. Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, - 2009, 2010 + 2009, 2010, 2011 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -516,6 +516,8 @@ gfc_handle_coarray_option (const char *arg) gfc_option.coarray = GFC_FCOARRAY_NONE; else if (strcmp (arg, "single") == 0) gfc_option.coarray = GFC_FCOARRAY_SINGLE; + else if (strcmp (arg, "lib") == 0) + gfc_option.coarray = GFC_FCOARRAY_LIB; else gfc_fatal_error ("Argument to -fcoarray is not valid: %s", arg); } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index bb8b575ded8..69edad8e0b5 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4591,6 +4591,9 @@ gfc_simplify_num_images (void) return &gfc_bad_expr; } + if (gfc_option.coarray != GFC_FCOARRAY_SINGLE) + return NULL; + /* FIXME: gfc_current_locus is wrong. */ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); @@ -6313,6 +6316,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) gfc_array_spec *as; int d; + if (gfc_option.coarray != GFC_FCOARRAY_SINGLE) + return NULL; + if (coarray == NULL) { gfc_expr *result; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 08207e09832..a0bbe537795 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -111,6 +111,22 @@ tree gfor_fndecl_in_unpack; tree gfor_fndecl_associated; +/* Coarray run-time library function decls. */ +tree gfor_fndecl_caf_init; +tree gfor_fndecl_caf_finalize; +tree gfor_fndecl_caf_critical; +tree gfor_fndecl_caf_end_critical; +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; + +/* Coarray global variables for num_images/this_image. */ + +tree gfort_gvar_caf_num_images; +tree gfort_gvar_caf_this_image; + + /* Math functions. Many other math functions are handled in trans-intrinsic.c. */ @@ -3003,6 +3019,50 @@ gfc_build_builtin_function_decls (void) DECL_PURE_P (gfor_fndecl_associated) = 1; TREE_NOTHROW (gfor_fndecl_associated) = 1; + /* Coarray library calls. */ + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tree pint_type, pppchar_type; + + pint_type = build_pointer_type (integer_type_node); + pppchar_type + = build_pointer_type (build_pointer_type (pchar_type_node)); + + gfor_fndecl_caf_init = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_init")), void_type_node, + 4, pint_type, pppchar_type, pint_type, pint_type); + + gfor_fndecl_caf_finalize = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_finalize")), void_type_node, 0); + + gfor_fndecl_caf_critical = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_critical")), void_type_node, 0); + + gfor_fndecl_caf_end_critical = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_end_critical")), void_type_node, 0); + + gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sync_all")), ".W", integer_type_node, + 2, build_pointer_type (pchar_type_node), integer_type_node); + + gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sync_images")), ".RRW", integer_type_node, + 4, integer_type_node, pint_type, build_pointer_type (pchar_type_node), + integer_type_node); + + gfor_fndecl_caf_error_stop = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_error_stop")), + void_type_node, 1, gfc_int4_type_node); + /* CAF's ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1; + + gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_error_stop_str")), ".R.", + void_type_node, 2, pchar_type_node, gfc_int4_type_node); + /* CAF's ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1; + } + gfc_build_intrinsic_function_decls (); gfc_build_intrinsic_lib_fndecls (); gfc_build_io_library_fndecls (); @@ -4405,6 +4465,40 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) } +void +gfc_init_coarray_decl (void) +{ + tree save_fn_decl = current_function_decl; + + if (gfc_option.coarray != GFC_FCOARRAY_LIB) + return; + + if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images) + return; + + save_fn_decl = current_function_decl; + current_function_decl = NULL_TREE; + push_cfun (cfun); + + gfort_gvar_caf_this_image = gfc_create_var (integer_type_node, + PREFIX("caf_this_image")); + DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1; + TREE_USED (gfort_gvar_caf_this_image) = 1; + TREE_PUBLIC (gfort_gvar_caf_this_image) = 1; + TREE_STATIC (gfort_gvar_caf_this_image) = 1; + + gfort_gvar_caf_num_images = gfc_create_var (integer_type_node, + PREFIX("caf_num_images")); + DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1; + TREE_USED (gfort_gvar_caf_num_images) = 1; + TREE_PUBLIC (gfort_gvar_caf_num_images) = 1; + TREE_STATIC (gfort_gvar_caf_num_images) = 1; + + pop_cfun (); + current_function_decl = save_fn_decl; +} + + static void create_main_function (tree fndecl) { @@ -4484,6 +4578,23 @@ create_main_function (tree fndecl) /* Call some libgfortran initialization routines, call then MAIN__(). */ + /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */ + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tree pint_type, pppchar_type; + pint_type = build_pointer_type (integer_type_node); + pppchar_type + = build_pointer_type (build_pointer_type (pchar_type_node)); + + gfc_init_coarray_decl (); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4, + gfc_build_addr_expr (pint_type, argc), + gfc_build_addr_expr (pppchar_type, argv), + gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image), + gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images)); + gfc_add_expr_to_block (&body, tmp); + } + /* Call _gfortran_set_args (argc, argv). */ TREE_USED (argc) = 1; TREE_USED (argv) = 1; @@ -4601,6 +4712,19 @@ create_main_function (tree fndecl) /* Mark MAIN__ as used. */ TREE_USED (fndecl) = 1; + /* Coarray: Call _gfortran_caf_finalize(void). */ + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + /* Per F2008, 8.5.1 END of the main program implies a + SYNC MEMORY. */ + tmp = built_in_decls [BUILT_IN_SYNCHRONIZE]; + tmp = build_call_expr_loc (input_location, tmp, 0); + gfc_add_expr_to_block (&body, tmp); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0); + gfc_add_expr_to_block (&body, tmp); + } + /* "return 0". */ tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main), diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 403aa3068b7..fa3e4c2c060 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1,5 +1,5 @@ /* Intrinsic translation - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -918,6 +918,20 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) se->expr = fold_convert (type, res); } +static void +trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED) +{ + gfc_init_coarray_decl (); + se->expr = gfort_gvar_caf_this_image; +} + +static void +trans_num_images (gfc_se * se) +{ + gfc_init_coarray_decl (); + se->expr = gfort_gvar_caf_num_images; +} + /* Evaluate a single upper or lower bound. */ /* TODO: bound intrinsic generates way too much unnecessary code. */ @@ -6111,6 +6125,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_loc (se, expr); break; + case GFC_ISYM_THIS_IMAGE: + trans_this_image (se, expr); + break; + + case GFC_ISYM_NUM_IMAGES: + trans_num_images (se); + break; + case GFC_ISYM_ACCESS: case GFC_ISYM_CHDIR: case GFC_ISYM_CHMOD: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 98fb74c4578..2d43627fd18 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -599,11 +599,25 @@ gfc_trans_stop (gfc_code *code, bool error_stop) gfc_init_se (&se, NULL); gfc_start_block (&se.pre); + if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop) + { + /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */ + tmp = built_in_decls [BUILT_IN_SYNCHRONIZE]; + tmp = build_call_expr_loc (input_location, tmp, 0); + gfc_add_expr_to_block (&se.pre, tmp); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0); + gfc_add_expr_to_block (&se.pre, tmp); + } + if (code->expr1 == NULL) { tmp = build_int_cst (gfc_int4_type_node, 0); tmp = build_call_expr_loc (input_location, - error_stop ? gfor_fndecl_error_stop_string + error_stop + ? (gfc_option.coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop_str + : gfor_fndecl_error_stop_string) : gfor_fndecl_stop_string, 2, build_int_cst (pchar_type_node, 0), tmp); } @@ -611,7 +625,10 @@ gfc_trans_stop (gfc_code *code, bool error_stop) { gfc_conv_expr (&se, code->expr1); tmp = build_call_expr_loc (input_location, - error_stop ? gfor_fndecl_error_stop_numeric + error_stop + ? (gfc_option.coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop + : gfor_fndecl_error_stop_numeric) : gfor_fndecl_stop_numeric_f08, 1, fold_convert (gfc_int4_type_node, se.expr)); } @@ -619,7 +636,10 @@ gfc_trans_stop (gfc_code *code, bool error_stop) { gfc_conv_expr_reference (&se, code->expr1); tmp = build_call_expr_loc (input_location, - error_stop ? gfor_fndecl_error_stop_string + error_stop + ? (gfc_option.coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop_str + : gfor_fndecl_error_stop_string) : gfor_fndecl_stop_string, 2, se.expr, se.string_length); } @@ -633,14 +653,51 @@ gfc_trans_stop (gfc_code *code, bool error_stop) tree -gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) +gfc_trans_sync (gfc_code *code, gfc_exec_op type) { - gfc_se se; + gfc_se se, argse; + tree tmp; + tree images = NULL_TREE, stat = NULL_TREE, + errmsg = NULL_TREE, errmsglen = NULL_TREE; - if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) + /* Short cut: For single images without bound checking or without STAT=, + return early. (ERRMSG= is always untouched for -fcoarray=single.) */ + if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && gfc_option.coarray != GFC_FCOARRAY_LIB) + return NULL_TREE; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + if (code->expr1 && code->expr1->rank == 0) { - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + images = argse.expr; + } + + if (code->expr2) + { + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + stat = argse.expr; + } + + if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB + && type != EXEC_SYNC_MEMORY) + { + gcc_assert (code->expr3->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->expr3); + gfc_conv_string_parameter (&argse); + errmsg = argse.expr; + errmsglen = argse.string_length; + } + else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY) + { + errmsg = null_pointer_node; + errmsglen = build_int_cst (integer_type_node, 0); } /* Check SYNC IMAGES(imageset) for valid image index. @@ -649,27 +706,100 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) && code->expr1->rank == 0) { tree cond; - gfc_conv_expr (&se, code->expr1); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - se.expr, build_int_cst (TREE_TYPE (se.expr), 1)); + if (gfc_option.coarray != GFC_FCOARRAY_LIB) + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + images, build_int_cst (TREE_TYPE (images), 1)); + else + { + tree cond2; + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + images, gfort_gvar_caf_num_images); + cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + images, + build_int_cst (TREE_TYPE (images), 1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, cond2); + } gfc_trans_runtime_check (true, false, cond, &se.pre, &code->expr1->where, "Invalid image number " "%d in SYNC IMAGES", fold_convert (integer_type_node, se.expr)); } - /* If STAT is present, set it to zero. */ - if (code->expr2) + /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the + image control statements SYNC IMAGES and SYNC ALL. */ + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tmp = built_in_decls [BUILT_IN_SYNCHRONIZE]; + tmp = build_call_expr_loc (input_location, tmp, 0); + gfc_add_expr_to_block (&se.pre, tmp); + } + + if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY) { - gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); - gfc_conv_expr (&se, code->expr2); - gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + /* Set STAT to zero. */ + if (code->expr2) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); + } + else if (type == EXEC_SYNC_ALL) + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 2, errmsg, errmsglen); + if (code->expr2) + gfc_add_modify (&se.pre, stat, fold_convert (TREE_TYPE (stat), tmp)); + else + gfc_add_expr_to_block (&se.pre, tmp); + } + else + { + tree len; + + gcc_assert (type == EXEC_SYNC_IMAGES); + + if (!code->expr1) + { + len = build_int_cst (integer_type_node, -1); + images = null_pointer_node; + } + else if (code->expr1->rank == 0) + { + len = build_int_cst (integer_type_node, 1); + images = gfc_build_addr_expr (NULL_TREE, images); + } + else + { + /* FIXME. */ + if (code->expr1->ts.kind != gfc_c_int_kind) + gfc_fatal_error ("Sorry, only support for integer kind %d " + "implemented for image-set at %L", + gfc_c_int_kind, &code->expr1->where); + + gfc_conv_array_parameter (&se, code->expr1, + gfc_walk_expr (code->expr1), true, NULL, + NULL, &len); + images = se.expr; + + tmp = gfc_typenode_for_spec (&code->expr1->ts); + if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp)) + tmp = gfc_get_element_type (tmp); + + len = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + TREE_TYPE (len), len, + fold_convert (TREE_TYPE (len), + TYPE_SIZE_UNIT (tmp))); + len = fold_convert (integer_type_node, len); + } + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 4, + fold_convert (integer_type_node, len), images, + errmsg, errmsglen); + if (code->expr2) + gfc_add_modify (&se.pre, stat, fold_convert (TREE_TYPE (stat), tmp)); + else + gfc_add_expr_to_block (&se.pre, tmp); } - if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) - return gfc_finish_block (&se.pre); - - return NULL_TREE; + return gfc_finish_block (&se.pre); } @@ -870,9 +1000,24 @@ gfc_trans_critical (gfc_code *code) tree tmp; gfc_start_block (&block); + + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0); + gfc_add_expr_to_block (&block, tmp); + } + tmp = gfc_trans_code (code->block->next); gfc_add_expr_to_block (&block, tmp); + if (gfc_option.coarray == GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical, + 0); + gfc_add_expr_to_block (&block, tmp); + } + + return gfc_finish_block (&block); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1536f2e806a..19e86bb951a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -1,5 +1,5 @@ /* Header for code translation functions - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. Contributed by Paul Brook @@ -452,6 +452,9 @@ bool gfc_get_module_backend_decl (gfc_symbol *); /* Return the variable decl for a symbol. */ tree gfc_get_symbol_decl (gfc_symbol *); +/* Initialize coarray global variables. */ +void gfc_init_coarray_decl (void); + /* Build a static initializer. */ tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool); @@ -613,6 +616,22 @@ extern GTY(()) tree gfor_fndecl_in_pack; extern GTY(()) tree gfor_fndecl_in_unpack; extern GTY(()) tree gfor_fndecl_associated; + +/* Coarray run-time library function decls. */ +extern GTY(()) tree gfor_fndecl_caf_init; +extern GTY(()) tree gfor_fndecl_caf_finalize; +extern GTY(()) tree gfor_fndecl_caf_critical; +extern GTY(()) tree gfor_fndecl_caf_end_critical; +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; + +/* Coarray global variables for num_images/this_image. */ +extern GTY(()) tree gfort_gvar_caf_num_images; +extern GTY(()) tree gfort_gvar_caf_this_image; + + /* Math functions. Many other math functions are handled in trans-intrinsic.c. */