OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 

2011-03-27  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.

From-SVN: r171568
This commit is contained in:
Tobias Burnus 2011-03-27 10:30:28 +02:00 committed by Tobias Burnus
parent 46ae608f26
commit 60386f50ce
12 changed files with 394 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/fortran/ChangeLog
View File

@ -1,3 +1,33 @@
2011-03-27 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.
2011-03-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/48291

5
gcc/fortran/gfortran.h
View File

@ -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;

3
gcc/fortran/intrinsic.c
View File

@ -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,

6
gcc/fortran/invoke.texi
View File

@ -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

12
gcc/fortran/iresolve.c
View File

@ -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;
}
}

5
gcc/fortran/libgfortran.h
View File

@ -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;

4
gcc/fortran/options.c
View File

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

6
gcc/fortran/simplify.c
View File

@ -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;

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

@ -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),

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

@ -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:

185
gcc/fortran/trans-stmt.c
View File

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

21
gcc/fortran/trans.h
View File

@ -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. */