This patch adds a first support for a coarray communication library.
Note: The patch does not yet allow communication (i.e. access to remote
coarrays); thus it is only of limited practical use. (If you restrict
yourself to barriers and this_image/num_images, you can already
parallelize.)
This patch contains two parts: (a) The front end part, which mainly adds
some library calls. (b) Two communication library implementations.
(Single-image library and a very initial MPI version.)
To (a): The patch adds library calls for
- Initialization and finalization
- STOP/ERROR STOP
- SYNC ALL/SYNC IMAGES
- CRITICAL block
- num_images() and this_image()*
- Additionally, SYNC MEMORY is handled (via BUILT_IN_SYNCHRONIZE)
(* only no-argument version)
To (b): The MPI library currently requires MPI 2.x, does not work for
SYNC IMAGE(<images>), and is very rough.
The single-image library version is the library equivalent to
-fcoarray=single, but less efficient. Its purpose is for testing - and
to avoid recompilation (e.g. if you do not have the source code).
My idea is to place those library into libgfortran/caf. The user has to
compile them themselves and link it then to their "gfortran
-fcoarray=lib" compiled program. (Cf.
http://gcc.gnu.org/ml/fortran/2011-03/msg00003.html).
Build and regtested on x86-64-linux.
(a) Is the patch OK for the 4.7 trunk?
(b) Are the libgfortrancaf.h, libgfortrancaf_mpi.c and
libgfortrancaf_single.c OK for inclusion at libgfortran/caf?
* * *
TODO:
- Documentation about the usage of coarrays - and in particular calling
the library for programs with a non-gfortran main program
- Add test-suite support, where the user specifies (e.g. via environment
variables?) the to-be-linked coarray communication library (e.g.
"-lgfortrancaf_mpi") and the command to run it (e.g. "mpiexec -n 3")
- autoconf work: Allow to automatically build the communication library
(statically), in particular the single-image version.
And the obvious extensions:
- Implement ATOMIC, LOCK, coarray registration/communication, and other
left overs
- Properly implement an MPI version.
(I plan to concentrate on the front-end (FE) version - and will only do
a minimal version for the single/MPI library. I hope that someone else
will take over that part. If not, I might do it after the FE part is
implemented. Maybe, one also finds a student, who wants to work on it
via Google's Summer of Code program.)
Tobias
2011-03-19 Tobias Burnus <bur...@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.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b64fa20..9a6907e 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 80dbaa8..0fea078 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 22245c9..f226039 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{<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
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index d8309d2..5042db3 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 85a73d8..09524d0 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 c116103..656cbca 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
@@ -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);
}
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index bb8b575..69edad8 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 08207e0..a0bbe53 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 403aa30..fa3e4c2 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 <p...@nowt.org>
and Steven Bosscher <s.bossc...@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:
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 98fb74c..2d43627 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 1536f2e..19e86bb 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. */
/* Common declarations for all of libgfortrancaf implementations.
Copyright (C) 2011
Free Software Foundation, Inc.
Contributed by Tobias Burnus <bur...@net-b.de>
This file is part of the GNU Fortran Coarray Runtime library
(libgfortrancaf).
Libgfortrancaf is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
Libgfortrancaf is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#ifndef LIBGFOR_CAF_H
#define LIBGFOR_CAF_H
#include <stdint.h>
#include <string.h>
/* Definitions of the Fortran 2008 standard; need to kept in sync with
ISO_FORTRAN_ENV, cf. libgfortran.h. */
#define STAT_UNLOCKED 0
#define STAT_LOCKED 1
#define STAT_LOCKED_OTHER_IMAGE 2
#define STAT_STOPPED_IMAGE 3
void _gfortran_caf_init (int *, char ***, int *, int *);
void _gfortran_caf_finalize (void);
int _gfortran_caf_sync_all (char *, int);
int _gfortran_caf_sync_images (int count, int images[], char *, int);
void _gfortran_caf_critical (void);
void _gfortran_caf_end_critical (void);
void _gfortran_caf_error_stop_str (const char *, int32_t) __attribute__ ((noreturn));
void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
#endif /* LIBGFOR_CAF_H */
/* Single-image implementation of GNU Fortran CAF
Copyright (C) 2011
Free Software Foundation, Inc.
Contributed by Tobias Burnus <bur...@net-b.de>
This file is part of the GNU Fortran Coarray Runtime library
(libgfortrancaf).
Libgfortrancaf is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
Libgfortrancaf is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortrancaf.h"
#include <stdio.h> /* For fputs and fprintf. */
#include <stdlib.h> /* For exit. */
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
/* Single-image implementation of the CAF library.
Note: For performance reasons -fcoarry=single should be used
rather than this library. */
void
_gfortran_caf_init (int *argc __attribute__ ((unused)),
char ***argv __attribute__ ((unused)),
int *this_image, int *num_images)
{
*this_image = 1;
*num_images = 1;
}
void
_gfortran_caf_finalize (void)
{
}
int
_gfortran_caf_sync_all (char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
return 0;
}
int
_gfortran_caf_sync_images (int count __attribute__ ((unused)),
int images[] __attribute__ ((unused)),
char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
#ifdef GFC_CAF_CHECK
int i;
for (i = 0; i < count; i++)
if (image[i] < 1 || image[i] > num_images)
{
fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
"IMAGES");
error_stop (1);
}
#endif
return 0;
}
void
_gfortran_caf_critical (void)
{
}
void
_gfortran_caf_end_critical (void)
{
}
void
_gfortran_caf_error_stop_str (const char *string, int32_t len)
{
fputs ("ERROR STOP ", stderr);
while (len--)
fputc (*(string++), stderr);
fputs ("\n", stderr);
exit (1);
}
void
_gfortran_caf_error_stop (int32_t error)
{
fprintf (stderr, "ERROR STOP %d\n", error);
exit (error);
}
/* MPI implementation of GNU Fortran CAF
Copyright (C) 2011
Free Software Foundation, Inc.
Contributed by Tobias Burnus <bur...@net-b.de>
This file is part of the GNU Fortran Coarray Runtime library
(libgfortrancaf).
Libgfortrancaf is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
Libgfortrancaf is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortrancaf.h"
#include <stdio.h>
#include <stdlib.h>
#include <mpi.h>
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
static void error_stop (int error) __attribute__ ((noreturn));
/* Global variables. */
static int caf_this_image;
static int caf_num_images;
static MPI_Win caf_world_window;
/* Initialize coarray program. This routine assumes that no other
MPI initialization happened before; otherwise MPI_Initialized
had to be used. As the MPI library might modify the command-line
arguments, the routine should be called before the run-time
libaray is initialized. */
void
_gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images)
{
int flag;
/* The following is only the case if one does not have a Fortran
main program. */
MPI_Initialized (&flag);
if (!flag)
MPI_Init (argc, argv);
MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image);
*this_image = caf_this_image + 1;
MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images);
*num_images = caf_num_images;
/* Obtain window for CRITICAL section locking. */
MPI_Win_create (NULL, 0, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
&caf_world_window);
}
/* Finalize coarray program. Note: This is only called before the
program ends; thus the MPI_Initialized status of _gfortran_caf_init
does not play a role. */
void
_gfortran_caf_finalize (void)
{
MPI_Win_free (&caf_world_window);
MPI_Finalize ();
}
/* SYNC ALL - the return value matches Fortran's STAT argument. */
int
_gfortran_caf_sync_all (char *errmsg, int errmsg_len)
{
int ierr;
ierr = MPI_Barrier (MPI_COMM_WORLD);
if (ierr && errmsg_len > 0)
{
const char msg[] = "SYNC ALL failed";
int len = sizeof (msg) > errmsg_len ? errmsg_len : sizeof (msg);
memcpy (errmsg, msg, len);
if (errmsg_len > len)
memset (&errmsg[len], ' ', errmsg_len-len);
}
/* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used? */
return ierr;
}
/* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
is not equivalent to SYNC ALL. The return value matches Fortran's
STAT argument. */
int
_gfortran_caf_sync_images (int count, int images[], char *errmsg,
int errmsg_len)
{
int ierr;
if (count == 0 || (count == 1 && images[0] == caf_this_image))
return 0;
#ifdef GFC_CAF_CHECK
{
int i;
for (i = 0; i < count; i++)
if (image[i] < 1 || image[i] > num_images)
{
fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
"IMAGES");
error_stop (1);
}
}
#endif
/* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be
mapped to MPI communicators. Thus, exist early with an error message. */
if (count > 0)
{
fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented");
error_stop (1);
}
/* Handle SYNC IMAGES(*). */
ierr = MPI_Barrier (MPI_COMM_WORLD);
if (ierr && errmsg_len > 0)
{
const char msg[] = "SYNC IMAGES failed";
int len = sizeof (msg) > errmsg_len ? errmsg_len : sizeof (msg);
memcpy (errmsg, msg, len);
if (errmsg_len > len)
memset (&errmsg[len], ' ', errmsg_len-len);
}
/* TODO: Is ierr correct? When should STAT_STOPPED_IMAGE be used? */
return ierr;
}
/* CRITICAL BLOCK. */
void
_gfortran_caf_critical (void)
{
MPI_Win_lock (MPI_LOCK_SHARED, 0, 0, caf_world_window);
}
void
_gfortran_caf_end_critical (void)
{
MPI_Win_unlock (0, caf_world_window);
}
/* ERROR STOP the other images. */
static void
error_stop (int error)
{
/* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
/* FIXME: Do some more effort than just MPI_ABORT. */
MPI_Abort (MPI_COMM_WORLD, error);
/* Should be unreachable, but to make sure also call exit. */
exit (error);
}
/* ERROR STOP function for string arguments. */
void
_gfortran_caf_error_stop_str (const char *string, int32_t len)
{
fputs ("ERROR STOP ", stderr);
while (len--)
fputc (*(string++), stderr);
fputs ("\n", stderr);
error_stop (1);
}
/* ERROR STOP function for numerical arguments. */
void
_gfortran_caf_error_stop (int32_t error)
{
fprintf (stderr, "ERROR STOP %d\n", error);
error_stop (error);
}
