2011-03-19 Tobias Burnus <burnus@net-b.de>
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.
@@ -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;
@@ -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,
@@ -166,7 +166,7 @@ and warnings}.
-fwhole-file -fsecond-underscore @gol
-fbounds-check -fcheck-array-temporaries -fmax-array-constructor =@var{n} @gol
-fcheck=@var{<all|array-temps|bounds|do|mem|pointer|recursion>} @gol
--fcoarray=@var{<none|single>} -fmax-stack-var-size=@var{n} @gol
+-fcoarray=@var{<none|single|lib>} -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{<zero|inf|-inf|nan|snan>} @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
@@ -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;
+ }
}
@@ -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;
@@ -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
@@ -515,6 +515,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);
}
@@ -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;
@@ -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),
@@ -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 <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -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:
@@ -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);
}
@@ -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. */