return GFC_NCA_NORMAL_COARRAY;
}
+/* Allocate a shared coarray from a constructor, without checking. */
+
+void
+gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int corank,
+ int alloc_type)
+{
+ gfc_add_expr_to_block (b,
+ build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc,
+ 4, gfc_build_addr_expr (pvoid_type_node, decl),
+ size, build_int_cst (integer_type_node, corank),
+ build_int_cst (integer_type_node, alloc_type)));
+}
+
+/* Allocate a shared coarray from user space, with checking. */
+
void
-gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank,
- int corank, int alloc_type, tree status,
- tree errmsg, tree errlen, bool calc_offset)
+allocate_shared_coarray_chk (stmtblock_t *b, tree decl, tree size, int rank,
+ int corank, int alloc_type, tree status,
+ tree errmsg, tree errlen)
{
tree st, err, elen;
+ int i;
+ tree offset, stride, lbound, mult;
if (status == NULL_TREE)
st = null_pointer_node;
err = errmsg == NULL_TREE ? null_pointer_node : errmsg;
elen = errlen == NULL_TREE ? build_int_cst (gfc_charlen_type_node, 0) : errlen;
+
gfc_add_expr_to_block (b,
- build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_allocate,
- 7, gfc_build_addr_expr (pvoid_type_node, decl),
- size, build_int_cst (integer_type_node, corank),
- build_int_cst (integer_type_node, alloc_type),
- st, err, elen));
- if (calc_offset)
- {
- int i;
- tree offset, stride, lbound, mult;
- offset = build_int_cst (gfc_array_index_type, 0);
- for (i = 0; i < rank + corank; i++)
- {
- stride = gfc_conv_array_stride (decl, i);
- lbound = gfc_conv_array_lbound (decl, i);
- mult = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, lbound);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, mult);
- }
- gfc_conv_descriptor_offset_set (b, decl, offset);
+ build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_alloc_chk,
+ 7, gfc_build_addr_expr (pvoid_type_node, decl),
+ size, build_int_cst (integer_type_node, corank),
+ build_int_cst (integer_type_node, alloc_type),
+ st, err, elen));
+
+ offset = build_int_cst (gfc_array_index_type, 0);
+ for (i = 0; i < rank + corank; i++)
+ {
+ stride = gfc_conv_array_stride (decl, i);
+ lbound = gfc_conv_array_lbound (decl, i);
+ mult = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ stride, lbound);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, mult);
}
+ gfc_conv_descriptor_offset_set (b, decl, offset);
}
/* Initializes the descriptor and generates a call to _gfor_allocate. Does
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
- bool e3_has_nodescriptor)
+ bool e3_has_nodescriptor, bool *shared_coarray)
{
tree tmp;
tree allocation;
expr3_elem_size, nelems, expr3, e3_arr_desc,
e3_has_nodescriptor, expr, &element_size);
+ /* Update the array descriptor with the offset and the span. */
+ if (dimension)
+ {
+ gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+ tmp = fold_convert (gfc_array_index_type, element_size);
+ gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
+ }
+
+ set_descriptor = gfc_finish_block (&set_descriptor_block);
+
if (dimension && !(flag_coarray == GFC_FCOARRAY_SHARED && coarray))
{
var_overflow = gfc_create_var (integer_type_node, "overflow");
elem_size = expr3_elem_size;
else
elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(se->expr)));
+
+ /* Setting the descriptor needs to be done before allocation of the
+ shared coarray. */
+ gfc_add_expr_to_block (&elseblock, set_descriptor);
+
int alloc_type
= gfc_cas_get_allocation_type (expr->symtree->n.sym);
- gfc_allocate_shared_coarray (&elseblock, se->expr, elem_size,
+ allocate_shared_coarray_chk (&elseblock, se->expr, elem_size,
ref->u.ar.as->rank, ref->u.ar.as->corank,
- alloc_type, status, errmsg, errlen,
- true);
+ alloc_type, status, errmsg, errlen);
+ *shared_coarray = true;
}
/* The allocatable variant takes the old pointer as first argument. */
else if (allocatable)
else
allocation = gfc_finish_block (&elseblock);
-
- /* Update the array descriptor with the offset and the span. */
- if (dimension)
- {
- gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
- tmp = fold_convert (gfc_array_index_type, element_size);
- gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
- }
-
- set_descriptor = gfc_finish_block (&set_descriptor_block);
-
- if (status != NULL_TREE)
+ if (status != NULL_TREE && !(coarray && flag_coarray == GFC_FCOARRAY_SHARED))
{
cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, status,
- build_int_cst (TREE_TYPE (status), 0));
+ logical_type_node, status,
+ build_int_cst (TREE_TYPE (status), 0));
if (not_prev_allocated != NULL_TREE)
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond, not_prev_allocated);
+ logical_type_node, cond,
+ not_prev_allocated);
- set_descriptor = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- cond,
- set_descriptor,
- build_empty_stmt (input_location));
+ set_descriptor = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ set_descriptor,
+ build_empty_stmt (input_location));
}
/* For native coarrays, the size must be set before the allocation routine
can be called. */
if (coarray && flag_coarray == GFC_FCOARRAY_SHARED)
- {
- gfc_add_expr_to_block (&se->pre, set_descriptor);
- gfc_add_expr_to_block (&se->pre, allocation);
- }
+ gfc_add_expr_to_block (&se->pre, allocation);
else
{
gfc_add_expr_to_block (&se->pre, allocation);
/* Although static, derived types with default initializers and
allocatable components must not be nulled wholesale; instead they
are treated component by component. */
- if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
+ if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer
+ && !(flag_coarray == GFC_FCOARRAY_SHARED && sym->attr.codimension))
{
/* SAVEd variables are not freed on exit. */
gfc_trans_static_array_pointer (sym);
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *, tree, bool);
+ tree, tree *, gfc_expr *, tree, bool, bool *);
enum gfc_coarray_allocation_type {
GFC_NCA_NORMAL_COARRAY = 1,
int gfc_cas_get_allocation_type (gfc_symbol *);
-void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int, int,
- tree, tree, tree, bool);
+void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
/* Native coarray functions. */
tree gfor_fndecl_cas_master;
-tree gfor_fndecl_cas_coarray_allocate;
+tree gfor_fndecl_cas_coarray_alloc;
+tree gfor_fndecl_cas_coarray_alloc_chk;
tree gfor_fndecl_cas_coarray_free;
tree gfor_fndecl_cas_this_image;
tree gfor_fndecl_cas_num_images;
gfor_fndecl_cas_master = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("cas_master")), ". r ", integer_type_node, 1,
build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)));
- gfor_fndecl_cas_coarray_allocate = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R W W . ", integer_type_node, 7,
- pvoid_type_node, /* desc. */
- size_type_node, /* elem_size. */
- integer_type_node, /* corank. */
- integer_type_node, /* alloc_type. */
- gfc_pint4_type_node, /* stat. */
- pchar1_type_node, /* errmsg. */
- gfc_charlen_type_node, /* errmsg_len. */
- NULL_TREE);
+ gfor_fndecl_cas_coarray_alloc_chk = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("cas_coarray_alloc_chk")), ". . R R R W W . ",
+ integer_type_node, 7,
+ pvoid_type_node, /* desc. */
+ size_type_node, /* elem_size. */
+ integer_type_node, /* corank. */
+ integer_type_node, /* alloc_type. */
+ gfc_pint4_type_node, /* stat. */
+ pchar1_type_node, /* errmsg. */
+ gfc_charlen_type_node); /* errmsg_len. */
+ gfor_fndecl_cas_coarray_alloc
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R ",
+ integer_type_node, 4,
+ pvoid_type_node, /* desc. */
+ size_type_node, /* elem_size. */
+ integer_type_node, /* corank. */
+ integer_type_node); /* alloc_type. */
+
gfor_fndecl_cas_coarray_free = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("cas_coarray_free")), ". . R ", integer_type_node, 2,
pvoid_type_node, /* Pointer to the descriptor to be deallocated. */
NULL_TREE, &nelems, NULL,
NULL_TREE, true, NULL, &element_size);
elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(decl)));
- gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->rank,
- sym->as->corank, alloc_type,
- NULL_TREE, NULL_TREE,
- build_int_cst (gfc_charlen_type_node, 0),
- false);
+ gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->corank,
+ alloc_type);
gfc_conv_descriptor_offset_set (init, decl, offset);
}
else if (flag_coarray == GFC_FCOARRAY_SHARED
&& sym->attr.codimension)
{
- gfc_trans_shared_coarray_inline (block, sym);
+ if (sym->attr.save == SAVE_EXPLICIT)
+ gfc_trans_shared_coarray_static (sym);
+ else
+ gfc_trans_shared_coarray_inline (block, sym);
}
else
{
if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat);
- if(type == EXEC_SYNC_MEMORY)
+ if (type == EXEC_SYNC_MEMORY)
{
/* For shared coarrays, there is no need for a memory
fence here because that is emitted anyway below. */
return NULL;
}
-/* Helper function - return true if a coarray is allcoated via this
- statement. */
-
-static bool
-coarray_alloc_p (gfc_code *code)
-{
- if (code == NULL || code->op != EXEC_ALLOCATE)
- return false;
-
- for (gfc_alloc *al = code->ext.alloc.list; al != NULL; al = al->next)
- {
- gfc_ref *ref, *last;
- for (ref = al->expr->ref, last = ref; ref; last = ref, ref = ref->next)
- ;
-
- ref = last;
- if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen)
- return true;
- }
- return false;
-}
-
/* Translate the ALLOCATE statement. */
tree
gfc_symtree *newsym = NULL;
symbol_attribute caf_attr;
gfc_actual_arglist *param_list;
+ bool shared_coarray = false;
if (!code->ext.alloc.list)
return NULL_TREE;
label_finish, tmp, &nelems,
e3rhs ? e3rhs : code->expr3,
e3_is == E3_DESC ? expr3 : NULL_TREE,
- e3_has_nodescriptor))
+ e3_has_nodescriptor, &shared_coarray))
{
/* A scalar or derived type. First compute the size to
allocate.
gfc_add_block_to_block (&block, &se.pre);
/* Error checking -- Note: ERRMSG only makes sense with STAT. */
- if (code->expr1)
+ if (code->expr1 && !shared_coarray)
{
tmp = build1_v (GOTO_EXPR, label_errmsg);
parm = fold_build2_loc (input_location, NE_EXPR,
gfc_free_expr (e3rhs);
}
/* STAT. */
- if (code->expr1)
+ if (code->expr1 && !shared_coarray)
{
tmp = build1_v (LABEL_EXPR, label_errmsg);
gfc_add_expr_to_block (&block, tmp);
}
/* ERRMSG - only useful if STAT is present. */
- if (code->expr1 && code->expr2)
+ if (code->expr1 && code->expr2 && !shared_coarray)
{
const char *msg = "Attempt to allocate an allocated object";
tree slen, dlen, errmsg_str;
zero_size);
gfc_add_expr_to_block (&post, tmp);
}
- else if (flag_coarray == GFC_FCOARRAY_SHARED && coarray_alloc_p (code))
- {
- tmp = build_call_expr_loc (input_location, gfor_fndecl_cas_sync_all,
- 1, null_pointer_node);
- gfc_add_expr_to_block (&post, tmp);
- }
gfc_add_block_to_block (&block, &se.post);
gfc_add_block_to_block (&block, &post);
/* Native coarray library function decls. */
extern GTY(()) tree gfor_fndecl_cas_this_image;
extern GTY(()) tree gfor_fndecl_cas_num_images;
-extern GTY(()) tree gfor_fndecl_cas_coarray_allocate;
+extern GTY(()) tree gfor_fndecl_cas_coarray_alloc;
+extern GTY(()) tree gfor_fndecl_cas_coarray_alloc_chk;
extern GTY(()) tree gfor_fndecl_cas_coarray_free;
extern GTY(()) tree gfor_fndecl_cas_sync_images;
extern GTY(()) tree gfor_fndecl_cas_sync_all;
allocate (a[*])
deallocate (a)
end program main
-! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_sync_all" 1 "original" } }
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+program main
+ integer, allocatable :: a[:]
+ character (len=80) :: errmsg
+ integer :: st
+ st = 42
+ allocate (a[*],stat=st)
+ if (st /= 0) stop 1
+ allocate (a[*], stat=st)
+ if (st == 0) stop 1
+ allocate (a[*], stat=st,errmsg=errmsg)
+ if (st == 0) stop 2
+ if (errmsg /= "Attempting to allocate already allocated variable") stop 3
+end program main
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+! { dg-options "-fdump-tree-original" }
+
+program main
+ integer :: n
+ n = 4096
+ do i=1,3
+ block
+ integer, allocatable :: a[:]
+ if (allocated(a)) stop 1
+ allocate (a[*])
+ a = 42
+ n = n * 2
+ end block
+ end do
+end program main
+! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_alloc_chk" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_cas_coarray_free" 1 "original" } }
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+! { dg-options "-fdump-tree-original" }
+
+program main
+ call test(.true.)
+ call test(.false.)
+contains
+ subroutine test(flag)
+ logical, intent(in) :: flag
+ integer, save, dimension(:), allocatable :: a[:]
+ if (flag) then
+ allocate (a(4)[*])
+ a = this_image()
+ else
+ if (size(a,1) /= 4) stop 1
+ if (any(a /= this_image())) stop 2
+ end if
+ end subroutine test
+end program main
test_for_cas_errors (int *stat, char *errmsg, size_t errmsg_length)
{
size_t errmsg_written_bytes;
- if (!stat)
- return 0;
/* This rather strange ordering is mandated by the standard. */
if (this_image.m->finished_images)
{
- *stat = CAS_STAT_STOPPED_IMAGE;
- if (errmsg)
+ if (stat)
{
- errmsg_written_bytes = snprintf (errmsg, errmsg_length,
- "Stopped images present (currently "
- "%d)",
- this_image.m->finished_images);
- if (errmsg_written_bytes > errmsg_length - 1)
- errmsg_written_bytes = errmsg_length - 1;
-
- memset (errmsg + errmsg_written_bytes, ' ',
- errmsg_length - errmsg_written_bytes);
+ *stat = CAS_STAT_STOPPED_IMAGE;
+ if (errmsg)
+ {
+ errmsg_written_bytes
+ = snprintf (errmsg, errmsg_length,
+ "Stopped images present (currently %d)",
+ this_image.m->finished_images);
+ if (errmsg_written_bytes > errmsg_length - 1)
+ errmsg_written_bytes = errmsg_length - 1;
+
+ memset (errmsg + errmsg_written_bytes, ' ',
+ errmsg_length - errmsg_written_bytes);
+ }
+ }
+ else
+ {
+ fprintf (stderr, "Stopped images present (currently %d)",
+ this_image.m->finished_images);
+ exit(1);
}
}
else if (this_image.m->has_failed_image)
{
- *stat = CAS_STAT_FAILED_IMAGE;
- if (errmsg)
+ if (stat)
{
- errmsg_written_bytes = snprintf (errmsg, errmsg_length,
- "Failed images present (currently "
- "%d)",
- this_image.m->has_failed_image);
- if (errmsg_written_bytes > errmsg_length - 1)
- errmsg_written_bytes = errmsg_length - 1;
-
- memset (errmsg + errmsg_written_bytes, ' ',
- errmsg_length - errmsg_written_bytes);
+ *stat = CAS_STAT_FAILED_IMAGE;
+ if (errmsg)
+ {
+ errmsg_written_bytes
+ = snprintf (errmsg, errmsg_length,
+ "Failed images present (currently %d)",
+ this_image.m->has_failed_image);
+ if (errmsg_written_bytes > errmsg_length - 1)
+ errmsg_written_bytes = errmsg_length - 1;
+
+ memset (errmsg + errmsg_written_bytes, ' ',
+ errmsg_length - errmsg_written_bytes);
+ }
+ }
+ else
+ {
+ fprintf (stderr, "Failed images present (currently %d)\n",
+ this_image.m->has_failed_image);
+ exit(1);
}
}
else
{
- *stat = 0;
+ if (stat)
+ *stat = 0;
+
return 0;
}
return 1;
#define STAT_ERRMSG_ENTRY_CHECK(stat, errmsg, errmsg_len) \
do { \
- if (test_for_cas_errors(stat, errmsg, errmsg_len))\
+ if (unlikely (test_for_cas_errors(stat, errmsg, errmsg_len))) \
return;\
} while(0)
#define STAT_ERRMSG_ENTRY_CHECK_RET(stat, errmsg, errmsg_len, retval) \
do { \
- if (test_for_cas_errors(stat, errmsg, errmsg_len))\
+ if (unlikely(test_for_cas_errors(stat, errmsg, errmsg_len))) \
return retval;\
} while(0)
GFC_NCA_EVENT_COARRAY,
};
-void cas_coarray_alloc (gfc_array_void *, size_t, int, int, int *,
- char *, size_t);
+void cas_coarray_alloc (gfc_array_void *, size_t, int, int);
export_proto (cas_coarray_alloc);
+void cas_coarray_alloc_chk (gfc_array_void *, size_t, int, int, int *,
+ char *, size_t);
+export_proto (cas_coarray_alloc_chk);
+
void cas_coarray_free (gfc_array_void *, int);
export_proto (cas_coarray_free);
size_t);
export_proto (cas_collsub_broadcast_scalar);
-void
-cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank,
- int alloc_type, int *status, char *errmsg, size_t errmsg_len)
+static void
+cas_coarray_alloc_work (gfc_array_void *desc, size_t elem_size, int corank,
+ int alloc_type)
{
int i, last_rank_index;
int num_coarray_elems, num_elems; /* Excludes the last dimension, because it
size_t last_lbound;
size_t size_in_bytes;
- ensure_initialization (); /* This function might be the first one to be
- called, if it is called in a constructor. */
-
- STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len);
if (alloc_type == GFC_NCA_LOCK_COARRAY)
elem_size = sizeof (pthread_mutex_t);
else if (alloc_type == GFC_NCA_EVENT_COARRAY)
else if (alloc_type == GFC_NCA_EVENT_COARRAY)
(void)0; // TODO
else
- desc->base_addr
- = get_memory_by_id (&local->ai, size_in_bytes, (intptr_t)desc);
+ desc->base_addr =
+ get_memory_by_id (&local->ai, size_in_bytes, (intptr_t) desc);
+}
+
+void
+cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank,
+ int alloc_type)
+{
+ ensure_initialization (); /* This function might be the first one to be
+ called, if it is called in a constructor. */
+ cas_coarray_alloc_work (desc, elem_size, corank, alloc_type);
+}
+
+void
+cas_coarray_alloc_chk (gfc_array_void *desc, size_t elem_size, int corank,
+ int alloc_type, int *status, char *errmsg,
+ size_t errmsg_len)
+{
+ STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len);
+ if (unlikely(GFC_DESCRIPTOR_DATA (desc) != NULL))
+ {
+ if (status == NULL)
+ {
+ fprintf (stderr,"Image %d: Attempting to allocate already allocated "
+ "variable at %p %p\n", this_image.image_num + 1, (void *) desc,
+ desc->base_addr);
+ exit (1);
+ }
+ else
+ {
+ *status = LIBERROR_ALLOCATION;
+ if (errmsg)
+ {
+ size_t errmsg_written_bytes;
+ errmsg_written_bytes
+ = snprintf (errmsg, errmsg_len, "Attempting to allocate already "
+ "allocated variable");
+ if (errmsg_written_bytes > errmsg_len - 1)
+ errmsg_written_bytes = errmsg_len - 1;
+ memset (errmsg + errmsg_written_bytes, ' ',
+ errmsg_len - errmsg_written_bytes);
+ }
+ return;
+ }
+ }
+ cas_coarray_alloc_work (desc, elem_size, corank, alloc_type);
+ sync_all (&local->si);
}
void
projects / thirdparty / gcc.git / commitdiff
