procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Move caf_get-rewrite to coarray.cc [PR107635]

Browse source 
Add a rewriter to keep all expression tree that is not optimization
together.  At the moment this is just a move from resolve.cc, but will
be extended to handle more cases where rewriting the expression tree may
be easier.  The first use case is to extract accessors for coarray
remote image data access.

gcc/fortran/ChangeLog:

	PR fortran/107635
	* Make-lang.in: Add coarray.cc.
	* coarray.cc: New file.
	* gfortran.h (gfc_coarray_rewrite): New procedure.
	* parse.cc (rewrite_expr_tree): Add entrypoint for rewriting
	expression trees.
	* resolve.cc (gfc_resolve_ref): Remove caf_lhs handling.
	(get_arrayspec_from_expr): Moved to rewrite.cc.
	(remove_coarray_from_derived_type): Same.
	(convert_coarray_class_to_derived_type): Same.
	(split_expr_at_caf_ref): Same.
	(check_add_new_component): Same.
	(create_get_parameter_type): Same.
	(create_get_callback): Same.
	(add_caf_get_intrinsic): Same.
	(resolve_variable): Remove caf_lhs handling.

libgfortran/ChangeLog:

	* caf/single.c (_gfortran_caf_finalize): Free memory preventing
	leaks.
	(_gfortran_caf_get_by_ct): Fix constness.
	* caf/libcaf.h (_gfortran_caf_register_accessor): Fix constness.
This commit is contained in:
Andre Vehreschild 2025-01-08 12:33:27 +01:00
parent 94d01a8847
commit 90ba8291c3
7 changed files with 793 additions and 707 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
gcc/fortran/Make-lang.in
View file

@ -52,13 +52,13 @@ fortran-warn = $(STRICT_WARN)
# from the parse tree to GENERIC
F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
fortran/check.o fortran/class.o fortran/constructor.o fortran/cpp.o \
fortran/data.o fortran/decl.o fortran/dump-parse-tree.o fortran/error.o \
fortran/expr.o fortran/interface.o fortran/intrinsic.o fortran/io.o \
fortran/iresolve.o fortran/match.o fortran/matchexp.o fortran/misc.o \
fortran/module.o fortran/openmp.o fortran/options.o fortran/parse.o \
fortran/primary.o fortran/resolve.o fortran/scanner.o fortran/simplify.o \
fortran/st.o fortran/symbol.o fortran/target-memory.o
fortran/check.o fortran/class.o fortran/coarray.o fortran/constructor.o \
fortran/cpp.o fortran/data.o fortran/decl.o fortran/dump-parse-tree.o \
fortran/error.o fortran/expr.o fortran/interface.o fortran/intrinsic.o \
fortran/io.o fortran/iresolve.o fortran/match.o fortran/matchexp.o \
fortran/misc.o fortran/module.o fortran/openmp.o fortran/options.o \
fortran/parse.o fortran/primary.o fortran/resolve.o fortran/scanner.o \
fortran/simplify.o fortran/st.o fortran/symbol.o fortran/target-memory.o
F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \
fortran/convert.o fortran/dependency.o fortran/f95-lang.o \

761
gcc/fortran/coarray.cc Normal file
View file

@ -0,0 +1,761 @@
/* Rewrite the expression tree for coarrays.
Copyright (C) 2010-2025 Free Software Foundation, Inc.
Contributed by Andre Vehreschild.
This file is part of GCC.
GCC 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.
GCC 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.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* Rewrite the expression for coarrays where needed:
- coarray indexing operations need the indexing expression put into a
routine callable on the remote image
This rewriter is meant to used for non-optimisational expression tree
rewrites. When implementing early optimisation it is recommended to
do this in frontend-passes.cc.
*/
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "bitmap.h"
#include "gfortran.h"
static gfc_code **current_code;
static bool caf_on_lhs = false;
static gfc_array_spec *
get_arrayspec_from_expr (gfc_expr *expr)
{
gfc_array_spec *src_as, *dst_as = NULL;
gfc_ref *ref;
gfc_array_ref mod_src_ar;
int dst_rank = 0;
if (expr->rank == 0)
return NULL;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_CONSTANT)
{
if (expr->symtree)
src_as = expr->symtree->n.sym->as;
else
src_as = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_COMPONENT:
src_as = ref->u.c.component->as;
continue;
case REF_SUBSTRING:
case REF_INQUIRY:
continue;
case REF_ARRAY:
switch (ref->u.ar.type)
{
case AR_ELEMENT:
src_as = NULL;
break;
case AR_SECTION:
{
if (!dst_as)
dst_as = gfc_get_array_spec ();
memset (&mod_src_ar, 0, sizeof (gfc_array_ref));
mod_src_ar = ref->u.ar;
for (int dim = 0; dim < src_as->rank; ++dim)
{
switch (ref->u.ar.dimen_type[dim])
{
case DIMEN_ELEMENT:
gfc_free_expr (mod_src_ar.start[dim]);
mod_src_ar.start[dim] = NULL;
break;
case DIMEN_RANGE:
dst_as->lower[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
mod_src_ar.start[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
if (ref->u.ar.end[dim])
{
dst_as->upper[dst_rank]
= gfc_copy_expr (ref->u.ar.end[dim]);
mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
mod_src_ar.stride[dst_rank]
= ref->u.ar.stride[dim];
}
else
dst_as->upper[dst_rank]
= gfc_copy_expr (ref->u.ar.as->upper[dim]);
++dst_rank;
break;
case DIMEN_STAR:
dst_as->lower[dst_rank]
= gfc_copy_expr (ref->u.ar.as->lower[dim]);
mod_src_ar.start[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
if (ref->u.ar.as->upper[dim])
{
dst_as->upper[dst_rank]
= gfc_copy_expr (ref->u.ar.as->upper[dim]);
mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
mod_src_ar.stride[dst_rank]
= ref->u.ar.stride[dim];
}
++dst_rank;
break;
case DIMEN_VECTOR:
dst_as->lower[dst_rank]
= gfc_get_constant_expr (BT_INTEGER,
gfc_index_integer_kind,
&expr->where);
mpz_set_ui (dst_as->lower[dst_rank]->value.integer,
1);
mod_src_ar.start[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
dst_as->upper[dst_rank]
= gfc_get_constant_expr (BT_INTEGER,
gfc_index_integer_kind,
&expr->where);
mpz_set (dst_as->upper[dst_rank]->value.integer,
ref->u.ar.start[dim]->shape[0]);
++dst_rank;
break;
case DIMEN_THIS_IMAGE:
case DIMEN_UNKNOWN:
gcc_unreachable ();
}
if (ref->u.ar.dimen_type[dim] != DIMEN_ELEMENT)
mod_src_ar.dimen_type[dst_rank]
= ref->u.ar.dimen_type[dim];
}
dst_as->rank = dst_rank;
dst_as->type = AS_EXPLICIT;
ref->u.ar = mod_src_ar;
ref->u.ar.dimen = dst_rank;
break;
case AR_UNKNOWN:
src_as = NULL;
break;
case AR_FULL:
dst_as = gfc_copy_array_spec (src_as);
break;
}
break;
}
}
}
}
else
src_as = NULL;
return dst_as;
}
static void
remove_coarray_from_derived_type (gfc_symbol *base, gfc_namespace *ns,
gfc_array_spec *src_as = NULL)
{
gfc_symbol *derived;
gfc_symbol *src_derived = base->ts.u.derived;
if (!src_as)
src_as = src_derived->as;
gfc_get_symbol (src_derived->name, ns, &derived);
derived->attr.flavor = FL_DERIVED;
derived->attr.alloc_comp = src_derived->attr.alloc_comp;
if (src_as && src_as->rank != 0)
{
base->attr.dimension = 1;
base->as = gfc_copy_array_spec (src_as);
base->as->corank = 0;
}
for (gfc_component *p = NULL, *c = src_derived->components; c; c = c->next)
{
gfc_component *n = gfc_get_component ();
*n = *c;
if (n->as)
n->as = gfc_copy_array_spec (c->as);
n->backend_decl = NULL;
n->initializer = NULL;
n->param_list = NULL;
if (p)
p->next = n;
else
derived->components = n;
p = n;
}
gfc_set_sym_referenced (derived);
gfc_commit_symbol (derived);
base->ts.u.derived = derived;
gfc_commit_symbol (base);
}
static void
convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns)
{
gfc_symbol *src_derived = CLASS_DATA (base)->ts.u.derived;
gfc_array_spec *src_as = CLASS_DATA (base)->as;
const bool attr_allocatable
= src_as && src_as->rank && src_as->type == AS_DEFERRED;
base->ts.type = BT_DERIVED;
base->ts.u.derived = src_derived;
remove_coarray_from_derived_type (base, ns, src_as);
base->attr.allocatable = attr_allocatable;
base->attr.pointer = 0; // Ensure, that it is no pointer.
}
static void
split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
gfc_expr **post_caf_ref_expr)
{
gfc_ref *caf_ref = NULL;
gfc_symtree *st;
gfc_symbol *base;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
if (!expr->symtree->n.sym->attr.codimension)
{
/* The coarray is in some component. Find it. */
caf_ref = expr->ref;
while (caf_ref)
{
if (caf_ref->type == REF_COMPONENT
&& caf_ref->u.c.component->attr.codimension)
break;
caf_ref = caf_ref->next;
}
}
gcc_assert (!gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns,
&st, false));
st->n.sym->attr.flavor = FL_PARAMETER;
st->n.sym->attr.dummy = 1;
st->n.sym->attr.intent = INTENT_IN;
st->n.sym->ts = caf_ref ? caf_ref->u.c.sym->ts : expr->symtree->n.sym->ts;
*post_caf_ref_expr = gfc_get_variable_expr (st);
(*post_caf_ref_expr)->where = expr->where;
base = (*post_caf_ref_expr)->symtree->n.sym;
if (!caf_ref)
{
(*post_caf_ref_expr)->ref = gfc_copy_ref (expr->ref);
if (expr->symtree->n.sym->attr.dimension)
{
base->as = gfc_copy_array_spec (expr->symtree->n.sym->as);
base->as->corank = 0;
base->attr.dimension = 1;
base->attr.allocatable = expr->symtree->n.sym->attr.allocatable;
base->attr.pointer = expr->symtree->n.sym->attr.pointer
|| expr->symtree->n.sym->attr.associate_var;
}
}
else
{
(*post_caf_ref_expr)->ref = gfc_copy_ref (caf_ref->next);
if (caf_ref->u.c.component->attr.dimension)
{
base->as = gfc_copy_array_spec (caf_ref->u.c.component->as);
base->as->corank = 0;
base->attr.dimension = 1;
base->attr.allocatable = caf_ref->u.c.component->attr.allocatable;
base->attr.pointer = caf_ref->u.c.component->attr.pointer;
}
base->ts = caf_ref->u.c.component->ts;
}
(*post_caf_ref_expr)->ts = expr->ts;
if (base->ts.type == BT_CHARACTER)
{
base->ts.u.cl = gfc_get_charlen ();
*base->ts.u.cl = *(caf_ref ? caf_ref->u.c.component->ts.u.cl
: expr->symtree->n.sym->ts.u.cl);
base->ts.deferred = 1;
base->ts.u.cl->length = nullptr;
}
if (base->ts.type == BT_DERIVED)
remove_coarray_from_derived_type (base, ns);
else if (base->ts.type == BT_CLASS)
convert_coarray_class_to_derived_type (base, ns);
gfc_expression_rank (expr);
gfc_expression_rank (*post_caf_ref_expr);
}
static void
check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *get_data)
{
if (e)
{
switch (e->expr_type)
{
case EXPR_CONSTANT:
case EXPR_NULL:
break;
case EXPR_OP:
check_add_new_component (type, e->value.op.op1, get_data);
if (e->value.op.op2)
check_add_new_component (type, e->value.op.op2, get_data);
break;
case EXPR_COMPCALL:
for (gfc_actual_arglist *actual = e->value.compcall.actual; actual;
actual = actual->next)
check_add_new_component (type, actual->expr, get_data);
break;
case EXPR_FUNCTION:
if (!e->symtree->n.sym->attr.pure
&& !e->symtree->n.sym->attr.elemental)
{
// Treat non-pure functions.
gfc_error ("Sorry, not yet able to call a non-pure/non-elemental"
" function %s in a coarray reference; use a temporary"
" for the function's result instead",
e->symtree->n.sym->name);
}
for (gfc_actual_arglist *actual = e->value.function.actual; actual;
actual = actual->next)
check_add_new_component (type, actual->expr, get_data);
break;
case EXPR_VARIABLE:
{
gfc_component *comp;
gfc_ref *ref;
int old_rank = e->rank;
/* Can't use gfc_find_component here, because type is not yet
complete. */
comp = type->components;
while (comp)
{
if (strcmp (comp->name, e->symtree->name) == 0)
break;
comp = comp->next;
}
if (!comp)
{
gcc_assert (gfc_add_component (type, e->symtree->name, &comp));
/* Take a copy of e, before modifying it. */
gfc_expr *init = gfc_copy_expr (e);
if (e->ref)
{
switch (e->ref->type)
{
case REF_ARRAY:
comp->as = get_arrayspec_from_expr (e);
comp->attr.dimension = e->ref->u.ar.dimen != 0;
comp->ts = e->ts;
break;
case REF_COMPONENT:
comp->ts = e->ref->u.c.sym->ts;
break;
default:
gcc_unreachable ();
break;
}
}
else
comp->ts = e->ts;
comp->attr.access = ACCESS_PRIVATE;
comp->initializer = init;
}
else
gcc_assert (comp->ts.type == e->ts.type
&& comp->ts.u.derived == e->ts.u.derived);
ref = e->ref;
e->ref = NULL;
gcc_assert (gfc_find_component (get_data->ts.u.derived,
e->symtree->name, false, true,
&e->ref));
e->symtree
= gfc_find_symtree (get_data->ns->sym_root, get_data->name);
e->ref->next = ref;
gfc_free_shape (&e->shape, old_rank);
gfc_expression_rank (e);
break;
}
case EXPR_ARRAY:
case EXPR_PPC:
case EXPR_STRUCTURE:
case EXPR_SUBSTRING:
gcc_unreachable ();
default:;
}
}
}
static gfc_symbol *
create_get_parameter_type (gfc_expr *expr, gfc_namespace *ns,
gfc_symbol *get_data)
{
static int type_cnt = 0;
char tname[GFC_MAX_SYMBOL_LEN + 1];
char *name;
gfc_symbol *type;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
strcpy (tname, expr->symtree->name);
name = xasprintf ("@_rget_data_t_%s_%d", tname, ++type_cnt);
gfc_get_symbol (name, ns, &type);
type->attr.flavor = FL_DERIVED;
get_data->ts.u.derived = type;
for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_ARRAY)
{
gfc_array_ref *ar = &ref->u.ar;
for (int i = 0; i < ar->dimen; ++i)
{
check_add_new_component (type, ar->start[i], get_data);
check_add_new_component (type, ar->end[i], get_data);
check_add_new_component (type, ar->stride[i], get_data);
}
}
}
gfc_set_sym_referenced (type);
gfc_commit_symbol (type);
return type;
}
static gfc_expr *
create_get_callback (gfc_expr *expr)
{
static int cnt = 0;
gfc_namespace *ns;
gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data,
*old_buffer_data;
char tname[GFC_MAX_SYMBOL_LEN + 1];
char *name;
const char *mname;
gfc_expr *cb, *post_caf_ref_expr;
gfc_code *code;
int expr_rank = expr->rank;
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
;
if (expr->expr_type == EXPR_VARIABLE)
strcpy (tname, expr->symtree->name);
else
strcpy (tname, "dummy");
if (expr->symtree->n.sym->module)
mname = expr->symtree->n.sym->module;
else
mname = "main";
name = xasprintf ("_caf_rget_%s_%s_%d", mname, tname, ++cnt);
gfc_get_symbol (name, ns, &extproc);
gfc_set_sym_referenced (extproc);
++extproc->refs;
gfc_commit_symbol (extproc);
/* Set up namespace. */
gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
sub_ns->sibling = ns->contained;
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
gfc_find_symbol (name, sub_ns, 1, &proc);
sub_ns->proc_name = proc;
proc->attr.if_source = IFSRC_DECL;
proc->attr.access = ACCESS_PUBLIC;
gfc_add_subroutine (&proc->attr, name, NULL);
proc->attr.host_assoc = 1;
proc->attr.always_explicit = 1;
++proc->refs;
gfc_commit_symbol (proc);
free (name);
split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr);
if (ns->proc_name->attr.flavor == FL_MODULE)
proc->module = ns->proc_name->name;
gfc_set_sym_referenced (proc);
/* Set up formal arguments. */
gfc_formal_arglist **argptr = &proc->formal;
#define ADD_ARG(name, nsym, stype, sintent) \
gfc_get_symbol (name, sub_ns, &nsym); \
nsym->ts.type = stype; \
nsym->attr.flavor = FL_PARAMETER; \
nsym->attr.dummy = 1; \
nsym->attr.intent = sintent; \
gfc_set_sym_referenced (nsym); \
*argptr = gfc_get_formal_arglist (); \
(*argptr)->sym = nsym; \
argptr = &(*argptr)->next
ADD_ARG ("buffer", buffer, expr->ts.type, INTENT_INOUT);
buffer->ts = expr->ts;
if (expr_rank)
{
buffer->as = gfc_get_array_spec ();
buffer->as->rank = expr_rank;
if (expr->shape)
{
buffer->as->type = AS_EXPLICIT;
for (int d = 0; d < expr_rank; ++d)
{
buffer->as->lower[d]
= gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
&gfc_current_locus);
gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1);
buffer->as->upper[d]
= gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
&gfc_current_locus);
gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer,
gfc_mpz_get_hwi (expr->shape[d]));
}
buffer->attr.allocatable = 1;
}
else
{
buffer->as->type = AS_DEFERRED;
buffer->attr.allocatable = 1;
}
buffer->attr.dimension = 1;
}
else
buffer->attr.pointer = 1;
if (buffer->ts.type == BT_CHARACTER)
{
buffer->ts.u.cl = gfc_get_charlen ();
*buffer->ts.u.cl = *expr->ts.u.cl;
buffer->ts.deferred = 1;
buffer->ts.u.cl->length = nullptr;
}
gfc_commit_symbol (buffer);
ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, INTENT_OUT);
free_buffer->ts.kind = gfc_default_logical_kind;
gfc_commit_symbol (free_buffer);
// ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
base = post_caf_ref_expr->symtree->n.sym;
gfc_set_sym_referenced (base);
gfc_commit_symbol (base);
*argptr = gfc_get_formal_arglist ();
(*argptr)->sym = base;
argptr = &(*argptr)->next;
gfc_commit_symbol (base);
ADD_ARG ("get_data", get_data, BT_DERIVED, INTENT_IN);
gfc_commit_symbol (get_data);
#undef ADD_ARG
/* Set up code. */
if (expr->rank != 0)
{
/* Code: old_buffer_ptr = C_LOC (buffer); */
code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data);
old_buffer_data->ts.type = BT_VOID;
old_buffer_data->attr.flavor = FL_VARIABLE;
gfc_set_sym_referenced (old_buffer_data);
gfc_commit_symbol (old_buffer_data);
code->expr1 = gfc_lval_expr_from_sym (old_buffer_data);
code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
gfc_current_locus, 1,
gfc_lval_expr_from_sym (buffer));
code->next = gfc_get_code (EXEC_ASSIGN);
code = code->next;
}
else
code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN);
/* Code: buffer = expr; */
code->expr1 = gfc_lval_expr_from_sym (buffer);
code->expr2 = post_caf_ref_expr;
gfc_ref *ref = code->expr2->ref, **pref = &code->expr2->ref;
if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
{
if (ref->u.ar.dimen != 0)
{
ref->u.ar.codimen = 0;
pref = &ref->next;
ref = ref->next;
}
else
{
code->expr2->ref = ref->next;
ref->next = NULL;
gfc_free_ref_list (ref);
ref = code->expr2->ref;
pref = &code->expr2->ref;
}
}
if (ref && ref->type == REF_COMPONENT)
{
gfc_find_component (code->expr2->symtree->n.sym->ts.u.derived,
ref->u.c.component->name, false, false, pref);
if (*pref != ref)
{
(*pref)->next = ref->next;
ref->next = NULL;
gfc_free_ref_list (ref);
}
}
get_data->ts.u.derived
= create_get_parameter_type (code->expr2, ns, get_data);
if (code->expr2->rank == 0)
code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
gfc_current_locus, 1, code->expr2);
/* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or
* *free_buffer = 0; for rank == 0. */
code->next = gfc_get_code (EXEC_ASSIGN);
code = code->next;
code->expr1 = gfc_lval_expr_from_sym (free_buffer);
if (expr->rank != 0)
{
code->expr2 = gfc_get_operator_expr (
&gfc_current_locus, INTRINSIC_NE_OS,
gfc_lval_expr_from_sym (old_buffer_data),
gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
gfc_current_locus, 1,
gfc_lval_expr_from_sym (buffer)));
code->expr2->ts.type = BT_LOGICAL;
code->expr2->ts.kind = gfc_default_logical_kind;
}
else
{
code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
&gfc_current_locus, false);
}
cb = gfc_lval_expr_from_sym (extproc);
cb->ts.interface = extproc;
return cb;
}
static void
add_caf_get_intrinsic (gfc_expr *e)
{
gfc_expr *wrapper, *tmp_expr, *rget_expr, *rget_hash_expr;
gfc_ref *ref;
int n;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
break;
if (ref == NULL)
return;
for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
return;
tmp_expr = XCNEW (gfc_expr);
*tmp_expr = *e;
rget_expr = create_get_callback (tmp_expr);
rget_hash_expr = gfc_get_expr ();
rget_hash_expr->expr_type = EXPR_CONSTANT;
rget_hash_expr->ts.type = BT_INTEGER;
rget_hash_expr->ts.kind = gfc_default_integer_kind;
rget_hash_expr->where = tmp_expr->where;
mpz_init_set_ui (rget_hash_expr->value.integer,
gfc_hash_value (rget_expr->symtree->n.sym));
wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
"caf_get", tmp_expr->where, 3, tmp_expr,
rget_hash_expr, rget_expr);
gfc_add_caf_accessor (rget_hash_expr, rget_expr);
wrapper->ts = e->ts;
wrapper->rank = e->rank;
wrapper->corank = e->corank;
if (e->rank)
wrapper->shape = gfc_copy_shape (e->shape, e->rank);
*e = *wrapper;
free (wrapper);
}
static int
coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
void *data ATTRIBUTE_UNUSED)
{
if ((*e)->expr_type == EXPR_VARIABLE)
{
if (!caf_on_lhs && gfc_is_coindexed (*e))
{
add_caf_get_intrinsic (*e);
*walk_subtrees = 0;
return 0;
}
/* Clear the flag to rewrite caf_gets in sub expressions of the lhs. */
caf_on_lhs = false;
}
*walk_subtrees = 1;
return 0;
}
static int
coindexed_code_callback (gfc_code **c, int *walk_subtrees,
void *data ATTRIBUTE_UNUSED)
{
int ws = 1;
current_code = c;
switch ((*c)->op)
{
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
caf_on_lhs = true;
coindexed_expr_callback (&((*c)->expr1), &ws, NULL);
caf_on_lhs = false;
ws = 1;
coindexed_expr_callback (&((*c)->expr2), &ws, NULL);
*walk_subtrees = ws;
break;
case EXEC_LOCK:
case EXEC_UNLOCK:
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
*walk_subtrees = 0;
break;
default:
*walk_subtrees = 1;
break;
}
return 0;
}
void
gfc_coarray_rewrite (gfc_namespace *ns)
{
gfc_namespace *saved_ns = gfc_current_ns;
gfc_current_ns = ns;
if (flag_coarray == GFC_FCOARRAY_LIB)
gfc_code_walker (&ns->code, coindexed_code_callback,
coindexed_expr_callback, NULL);
gfc_current_ns = saved_ns;
}

2
gcc/fortran/gfortran.h
View file

@ -3974,6 +3974,8 @@ const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
bool gfc_pure_function (gfc_expr *e, const char **name);
bool gfc_implicit_pure_function (gfc_expr *e);
/* coarray.cc */
void gfc_coarray_rewrite (gfc_namespace *);
/* array.cc */
gfc_iterator *gfc_copy_iterator (gfc_iterator *);

13
gcc/fortran/parse.cc
View file

@ -7339,6 +7339,16 @@ add_global_program (void)
}
}
/* Rewrite expression where needed.
- Currently this is done for co-indexed expressions only.
*/
static void
rewrite_expr_tree (gfc_namespace *gfc_global_ns_list)
{
for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
gfc_current_ns = gfc_current_ns->sibling)
gfc_coarray_rewrite (gfc_current_ns);
}
/* Resolve all the program units. */
static void
@ -7616,6 +7626,9 @@ done:
/* Do the resolution. */
resolve_all_program_units (gfc_global_ns_list);
if (flag_coarray == GFC_FCOARRAY_LIB)
rewrite_expr_tree (gfc_global_ns_list);
/* Go through all top-level namespaces and unset the implicit_pure
attribute for any procedures that call something not pure or
implicit_pure. Because the a procedure marked as not implicit_pure

693
gcc/fortran/resolve.cc
View file

@ -92,8 +92,6 @@ static bitmap_obstack labels_obstack;
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
/* True when we are on left hand side in an assignment of a coarray. */
static bool caf_lhs = false;
/* Is the symbol host associated? */
static bool
@ -5584,7 +5582,7 @@ gfc_resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension, dim;
gfc_ref *ref, **prev, *array_ref;
bool equal_length, old_caf_lhs;
bool equal_length;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
@ -5594,18 +5592,13 @@ gfc_resolve_ref (gfc_expr *expr)
break;
}
old_caf_lhs = caf_lhs;
caf_lhs = false;
for (prev = &expr->ref; *prev != NULL;
prev = *prev == NULL ? prev : &(*prev)->next)
switch ((*prev)->type)
{
case REF_ARRAY:
if (!resolve_array_ref (&(*prev)->u.ar))
{
caf_lhs = old_caf_lhs;
return false;
}
break;
case REF_COMPONENT:
@ -5615,10 +5608,7 @@ gfc_resolve_ref (gfc_expr *expr)
case REF_SUBSTRING:
equal_length = false;
if (!gfc_resolve_substring (*prev, &equal_length))
{
caf_lhs = old_caf_lhs;
return false;
}
if (expr->expr_type != EXPR_SUBSTRING && equal_length)
{
@ -5632,7 +5622,6 @@ gfc_resolve_ref (gfc_expr *expr)
}
break;
}
caf_lhs = old_caf_lhs;
/* Check constraints on part references. */
@ -5908,663 +5897,6 @@ gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
|| op1->corank == op2->corank);
}
static gfc_array_spec *
get_arrayspec_from_expr (gfc_expr *expr)
{
gfc_array_spec *src_as, *dst_as = NULL;
gfc_ref *ref;
gfc_array_ref mod_src_ar;
int dst_rank = 0;
if (expr->rank == 0)
return NULL;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_CONSTANT)
{
if (expr->symtree)
src_as = expr->symtree->n.sym->as;
else
src_as = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_COMPONENT:
src_as = ref->u.c.component->as;
continue;
case REF_SUBSTRING:
case REF_INQUIRY:
continue;
case REF_ARRAY:
switch (ref->u.ar.type)
{
case AR_ELEMENT:
src_as = NULL;
break;
case AR_SECTION: {
if (!dst_as)
dst_as = gfc_get_array_spec ();
memset (&mod_src_ar, 0, sizeof (gfc_array_ref));
mod_src_ar = ref->u.ar;
for (int dim = 0; dim < src_as->rank; ++dim)
{
switch (ref->u.ar.dimen_type[dim])
{
case DIMEN_ELEMENT:
gfc_free_expr (mod_src_ar.start[dim]);
mod_src_ar.start[dim] = NULL;
break;
case DIMEN_RANGE:
dst_as->lower[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
mod_src_ar.start[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
if (ref->u.ar.end[dim])
{
dst_as->upper[dst_rank]
= gfc_copy_expr (ref->u.ar.end[dim]);
mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
mod_src_ar.stride[dst_rank]
= ref->u.ar.stride[dim];
}
else
dst_as->upper[dst_rank]
= gfc_copy_expr (ref->u.ar.as->upper[dim]);
++dst_rank;
break;
case DIMEN_STAR:
dst_as->lower[dst_rank]
= gfc_copy_expr (ref->u.ar.as->lower[dim]);
mod_src_ar.start[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
if (ref->u.ar.as->upper[dim])
{
dst_as->upper[dst_rank]
= gfc_copy_expr (ref->u.ar.as->upper[dim]);
mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
mod_src_ar.stride[dst_rank]
= ref->u.ar.stride[dim];
}
++dst_rank;
break;
case DIMEN_VECTOR:
dst_as->lower[dst_rank]
= gfc_get_constant_expr (BT_INTEGER,
gfc_index_integer_kind,
&expr->where);
mpz_set_ui (dst_as->lower[dst_rank]->value.integer,
1);
mod_src_ar.start[dst_rank]
= gfc_copy_expr (ref->u.ar.start[dim]);
dst_as->upper[dst_rank]
= gfc_get_constant_expr (BT_INTEGER,
gfc_index_integer_kind,
&expr->where);
mpz_set (dst_as->upper[dst_rank]->value.integer,
ref->u.ar.start[dim]->shape[0]);
++dst_rank;
break;
case DIMEN_THIS_IMAGE:
case DIMEN_UNKNOWN:
gcc_unreachable ();
}
if (ref->u.ar.dimen_type[dim] != DIMEN_ELEMENT)
mod_src_ar.dimen_type[dst_rank]
= ref->u.ar.dimen_type[dim];
}
dst_as->rank = dst_rank;
dst_as->type = AS_EXPLICIT;
ref->u.ar = mod_src_ar;
ref->u.ar.dimen = dst_rank;
break;
case AR_UNKNOWN:
src_as = NULL;
break;
case AR_FULL:
dst_as = gfc_copy_array_spec (src_as);
break;
}
break;
}
}
}
}
else
src_as = NULL;
return dst_as;
}
static void
remove_coarray_from_derived_type (gfc_symbol *base, gfc_namespace *ns,
gfc_array_spec *src_as = NULL)
{
gfc_symbol *derived;
gfc_symbol *src_derived = base->ts.u.derived;
if (!src_as)
src_as = src_derived->as;
gfc_get_symbol (src_derived->name, ns, &derived);
derived->attr.flavor = FL_DERIVED;
derived->attr.alloc_comp = src_derived->attr.alloc_comp;
if (src_as && src_as->rank != 0)
{
base->attr.dimension = 1;
base->as = gfc_copy_array_spec (src_as);
base->as->corank = 0;
}
for (gfc_component *p = NULL, *c = src_derived->components; c; c = c->next)
{
gfc_component *n = gfc_get_component ();
*n = *c;
if (n->as)
n->as = gfc_copy_array_spec (c->as);
n->backend_decl = NULL;
n->initializer = NULL;
n->param_list = NULL;
if (p)
p->next = n;
else
derived->components = n;
p = n;
}
gfc_set_sym_referenced (derived);
gfc_commit_symbol (derived);
base->ts.u.derived = derived;
gfc_commit_symbol (base);
}
static void
convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns)
{
gfc_symbol *src_derived = CLASS_DATA (base)->ts.u.derived;
gfc_array_spec *src_as = CLASS_DATA (base)->as;
const bool attr_allocatable
= src_as && src_as->rank && src_as->type == AS_DEFERRED;
base->ts.type = BT_DERIVED;
base->ts.u.derived = src_derived;
remove_coarray_from_derived_type (base, ns, src_as);
base->attr.allocatable = attr_allocatable;
base->attr.pointer = 0; // Ensure, that it is no pointer.
}
static void
split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
gfc_expr **post_caf_ref_expr)
{
gfc_ref *caf_ref = NULL;
gfc_symtree *st;
gfc_symbol *base;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
if (!expr->symtree->n.sym->attr.codimension)
{
/* The coarray is in some component. Find it. */
caf_ref = expr->ref;
while (caf_ref)
{
if (caf_ref->type == REF_COMPONENT
&& caf_ref->u.c.component->attr.codimension)
break;
caf_ref = caf_ref->next;
}
}
gcc_assert (!gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns,
&st, false));
st->n.sym->attr.flavor = FL_PARAMETER;
st->n.sym->attr.dummy = 1;
st->n.sym->attr.intent = INTENT_IN;
st->n.sym->ts = caf_ref ? caf_ref->u.c.sym->ts : expr->symtree->n.sym->ts;
*post_caf_ref_expr = gfc_get_variable_expr (st);
(*post_caf_ref_expr)->where = expr->where;
base = (*post_caf_ref_expr)->symtree->n.sym;
if (!caf_ref)
{
(*post_caf_ref_expr)->ref = gfc_copy_ref (expr->ref);
if (expr->symtree->n.sym->attr.dimension)
{
base->as = gfc_copy_array_spec (expr->symtree->n.sym->as);
base->as->corank = 0;
base->attr.dimension = 1;
base->attr.allocatable = expr->symtree->n.sym->attr.allocatable;
base->attr.pointer = expr->symtree->n.sym->attr.pointer
|| expr->symtree->n.sym->attr.associate_var;
}
}
else
{
(*post_caf_ref_expr)->ref = gfc_copy_ref (caf_ref->next);
if (caf_ref->u.c.component->attr.dimension)
{
base->as = gfc_copy_array_spec (caf_ref->u.c.component->as);
base->as->corank = 0;
base->attr.dimension = 1;
base->attr.allocatable = caf_ref->u.c.component->attr.allocatable;
base->attr.pointer = caf_ref->u.c.component->attr.pointer;
}
base->ts = caf_ref->u.c.component->ts;
}
(*post_caf_ref_expr)->ts = expr->ts;
if (base->ts.type == BT_CHARACTER)
{
base->ts.u.cl = gfc_get_charlen ();
*base->ts.u.cl = *(caf_ref ? caf_ref->u.c.component->ts.u.cl
: expr->symtree->n.sym->ts.u.cl);
base->ts.deferred = 1;
base->ts.u.cl->length = nullptr;
}
if (base->ts.type == BT_DERIVED)
remove_coarray_from_derived_type (base, ns);
else if (base->ts.type == BT_CLASS)
convert_coarray_class_to_derived_type (base, ns);
gfc_expression_rank (expr);
gfc_expression_rank (*post_caf_ref_expr);
}
static void
check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *get_data)
{
if (e)
{
switch (e->expr_type)
{
case EXPR_CONSTANT:
case EXPR_NULL:
break;
case EXPR_OP:
check_add_new_component (type, e->value.op.op1, get_data);
if (e->value.op.op2)
check_add_new_component (type, e->value.op.op2, get_data);
break;
case EXPR_COMPCALL:
for (gfc_actual_arglist *actual = e->value.compcall.actual; actual;
actual = actual->next)
check_add_new_component (type, actual->expr, get_data);
break;
case EXPR_FUNCTION:
if (!e->symtree->n.sym->attr.pure
&& !e->symtree->n.sym->attr.elemental)
{
// Treat non-pure functions.
gfc_error ("Sorry, not yet able to call a non-pure/non-elemental"
" function %s in a coarray reference; use a temporary"
" for the function's result instead",
e->symtree->n.sym->name);
}
for (gfc_actual_arglist *actual = e->value.function.actual; actual;
actual = actual->next)
check_add_new_component (type, actual->expr, get_data);
break;
case EXPR_VARIABLE: {
gfc_component *comp;
gfc_ref *ref;
int old_rank = e->rank;
/* Can't use gfc_find_component here, because type is not yet
complete. */
comp = type->components;
while (comp)
{
if (strcmp (comp->name, e->symtree->name) == 0)
break;
comp = comp->next;
}
if (!comp)
{
gcc_assert (gfc_add_component (type, e->symtree->name, &comp));
/* Take a copy of e, before modifying it. */
gfc_expr *init = gfc_copy_expr (e);
if (e->ref)
{
switch (e->ref->type)
{
case REF_ARRAY:
comp->as = get_arrayspec_from_expr (e);
comp->attr.dimension = e->ref->u.ar.dimen != 0;
comp->ts = e->ts;
break;
case REF_COMPONENT:
comp->ts = e->ref->u.c.sym->ts;
break;
default:
gcc_unreachable ();
break;
}
}
else
comp->ts = e->ts;
comp->attr.access = ACCESS_PRIVATE;
comp->initializer = init;
}
else
gcc_assert (comp->ts.type == e->ts.type
&& comp->ts.u.derived == e->ts.u.derived);
ref = e->ref;
e->ref = NULL;
gcc_assert (gfc_find_component (get_data->ts.u.derived,
e->symtree->name, false, true,
&e->ref));
e->symtree
= gfc_find_symtree (get_data->ns->sym_root, get_data->name);
e->ref->next = ref;
gfc_free_shape (&e->shape, old_rank);
gfc_expression_rank (e);
break;
}
case EXPR_ARRAY:
case EXPR_PPC:
case EXPR_STRUCTURE:
case EXPR_SUBSTRING:
gcc_unreachable ();
default:;
}
}
}
static gfc_symbol *
create_get_parameter_type (gfc_expr *expr, gfc_namespace *ns,
gfc_symbol *get_data)
{
static int type_cnt = 0;
char tname[GFC_MAX_SYMBOL_LEN + 1];
char *name;
gfc_symbol *type;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
strcpy (tname, expr->symtree->name);
name = xasprintf ("@_rget_data_t_%s_%d", tname, ++type_cnt);
gfc_get_symbol (name, ns, &type);
type->attr.flavor = FL_DERIVED;
get_data->ts.u.derived = type;
for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_ARRAY)
{
gfc_array_ref *ar = &ref->u.ar;
for (int i = 0; i < ar->dimen; ++i)
{
check_add_new_component (type, ar->start[i], get_data);
check_add_new_component (type, ar->end[i], get_data);
check_add_new_component (type, ar->stride[i], get_data);
}
}
}
gfc_set_sym_referenced (type);
gfc_commit_symbol (type);
return type;
}
static gfc_expr *
create_get_callback (gfc_expr *expr)
{
static int cnt = 0;
gfc_namespace *ns;
gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data,
*old_buffer_data;
char tname[GFC_MAX_SYMBOL_LEN + 1];
char *name;
const char *mname;
gfc_expr *cb, *post_caf_ref_expr;
gfc_code *code;
int expr_rank = expr->rank;
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
;
if (expr->expr_type == EXPR_VARIABLE)
strcpy (tname, expr->symtree->name);
else
strcpy (tname, "dummy");
if (expr->symtree->n.sym->module)
mname = expr->symtree->n.sym->module;
else
mname = "main";
name = xasprintf ("_caf_rget_%s_%s_%d", mname, tname, ++cnt);
gfc_get_symbol (name, ns, &extproc);
gfc_set_sym_referenced (extproc);
++extproc->refs;
gfc_commit_symbol (extproc);
/* Set up namespace. */
gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
sub_ns->sibling = ns->contained;
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
gfc_find_symbol (name, sub_ns, 1, &proc);
sub_ns->proc_name = proc;
proc->attr.if_source = IFSRC_DECL;
proc->attr.access = ACCESS_PUBLIC;
gfc_add_subroutine (&proc->attr, name, NULL);
proc->attr.host_assoc = 1;
proc->attr.always_explicit = 1;
++proc->refs;
gfc_commit_symbol (proc);
free (name);
split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr);
if (ns->proc_name->attr.flavor == FL_MODULE)
proc->module = ns->proc_name->name;
gfc_set_sym_referenced (proc);
/* Set up formal arguments. */
gfc_formal_arglist **argptr = &proc->formal;
#define ADD_ARG(name, nsym, stype, sintent) \
gfc_get_symbol (name, sub_ns, &nsym); \
nsym->ts.type = stype; \
nsym->attr.flavor = FL_PARAMETER; \
nsym->attr.dummy = 1; \
nsym->attr.intent = sintent; \
gfc_set_sym_referenced (nsym); \
*argptr = gfc_get_formal_arglist (); \
(*argptr)->sym = nsym; \
argptr = &(*argptr)->next
ADD_ARG ("buffer", buffer, expr->ts.type, INTENT_INOUT);
buffer->ts = expr->ts;
if (expr_rank)
{
buffer->as = gfc_get_array_spec ();
buffer->as->rank = expr_rank;
if (expr->shape)
{
buffer->as->type = AS_EXPLICIT;
for (int d = 0; d < expr_rank; ++d)
{
buffer->as->lower[d]
= gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
&gfc_current_locus);
gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1);
buffer->as->upper[d]
= gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
&gfc_current_locus);
gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer,
gfc_mpz_get_hwi (expr->shape[d]));
}
buffer->attr.allocatable = 1;
}
else
{
buffer->as->type = AS_DEFERRED;
buffer->attr.allocatable = 1;
}
buffer->attr.dimension = 1;
}
else
buffer->attr.pointer = 1;
if (buffer->ts.type == BT_CHARACTER)
{
buffer->ts.u.cl = gfc_get_charlen ();
*buffer->ts.u.cl = *expr->ts.u.cl;
buffer->ts.deferred = 1;
buffer->ts.u.cl->length = nullptr;
}
gfc_commit_symbol (buffer);
ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, INTENT_OUT);
free_buffer->ts.kind = gfc_default_logical_kind;
gfc_commit_symbol (free_buffer);
// ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
base = post_caf_ref_expr->symtree->n.sym;
gfc_set_sym_referenced (base);
gfc_commit_symbol (base);
*argptr = gfc_get_formal_arglist ();
(*argptr)->sym = base;
argptr = &(*argptr)->next;
gfc_commit_symbol (base);
ADD_ARG ("get_data", get_data, BT_DERIVED, INTENT_IN);
gfc_commit_symbol (get_data);
#undef ADD_ARG
/* Set up code. */
if (expr->rank != 0)
{
/* Code: old_buffer_ptr = C_LOC (buffer); */
code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data);
old_buffer_data->ts.type = BT_VOID;
old_buffer_data->attr.flavor = FL_VARIABLE;
gfc_set_sym_referenced (old_buffer_data);
gfc_commit_symbol (old_buffer_data);
code->expr1 = gfc_lval_expr_from_sym (old_buffer_data);
code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
gfc_current_locus, 1,
gfc_lval_expr_from_sym (buffer));
code->next = gfc_get_code (EXEC_ASSIGN);
code = code->next;
}
else
code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN);
/* Code: buffer = expr; */
code->expr1 = gfc_lval_expr_from_sym (buffer);
code->expr2 = post_caf_ref_expr;
gfc_ref *ref = code->expr2->ref, **pref = &code->expr2->ref;
if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
{
if (ref->u.ar.dimen != 0)
{
ref->u.ar.codimen = 0;
pref = &ref->next;
ref = ref->next;
}
else
{
code->expr2->ref = ref->next;
ref->next = NULL;
gfc_free_ref_list (ref);
ref = code->expr2->ref;
pref = &code->expr2->ref;
}
}
if (ref && ref->type == REF_COMPONENT)
{
gfc_find_component (code->expr2->symtree->n.sym->ts.u.derived,
ref->u.c.component->name, false, false, pref);
if (*pref != ref)
{
(*pref)->next = ref->next;
ref->next = NULL;
gfc_free_ref_list (ref);
}
}
get_data->ts.u.derived
= create_get_parameter_type (code->expr2, ns, get_data);
if (code->expr2->rank == 0)
code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
gfc_current_locus, 1, code->expr2);
/* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or
* *free_buffer = 0; for rank == 0. */
code->next = gfc_get_code (EXEC_ASSIGN);
code = code->next;
code->expr1 = gfc_lval_expr_from_sym (free_buffer);
if (expr->rank != 0)
{
code->expr2 = gfc_get_operator_expr (
&gfc_current_locus, INTRINSIC_NE_OS,
gfc_lval_expr_from_sym (old_buffer_data),
gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
gfc_current_locus, 1,
gfc_lval_expr_from_sym (buffer)));
code->expr2->ts.type = BT_LOGICAL;
code->expr2->ts.kind = gfc_default_logical_kind;
}
else
{
code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
&gfc_current_locus, false);
}
cb = gfc_lval_expr_from_sym (extproc);
cb->ts.interface = extproc;
return cb;
}
static void
add_caf_get_intrinsic (gfc_expr *e)
{
gfc_expr *wrapper, *tmp_expr, *rget_expr, *rget_hash_expr;
gfc_ref *ref;
int n;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
break;
if (ref == NULL)
return;
for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
return;
tmp_expr = XCNEW (gfc_expr);
*tmp_expr = *e;
rget_expr = create_get_callback (tmp_expr);
rget_hash_expr = gfc_get_expr ();
rget_hash_expr->expr_type = EXPR_CONSTANT;
rget_hash_expr->ts.type = BT_INTEGER;
rget_hash_expr->ts.kind = gfc_default_integer_kind;
rget_hash_expr->where = tmp_expr->where;
mpz_init_set_ui (rget_hash_expr->value.integer,
gfc_hash_value (rget_expr->symtree->n.sym));
wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
"caf_get", tmp_expr->where, 3, tmp_expr,
rget_hash_expr, rget_expr);
gfc_add_caf_accessor (rget_hash_expr, rget_expr);
wrapper->ts = e->ts;
wrapper->rank = e->rank;
wrapper->corank = e->corank;
if (e->rank)
wrapper->shape = gfc_copy_shape (e->shape, e->rank);
*e = *wrapper;
free (wrapper);
}
/* Resolve a variable expression. */
static bool
@ -6911,8 +6243,6 @@ resolve_variable (gfc_expr *e)
if (sym->as)
{
bool old_caf_lhs = caf_lhs;
caf_lhs = false;
for (n = 0; n < sym->as->rank; n++)
{
if (!gfc_resolve_expr (sym->as->lower[n]))
@ -6920,7 +6250,6 @@ resolve_variable (gfc_expr *e)
if (!gfc_resolve_expr (sym->as->upper[n]))
t = false;
}
caf_lhs = old_caf_lhs;
}
specification_expr = saved_specification_expr;
@ -6996,10 +6325,6 @@ resolve_procedure:
if (t)
gfc_expression_rank (e);
if (t && flag_coarray == GFC_FCOARRAY_LIB && !caf_lhs
&& gfc_is_coindexed (e))
add_caf_get_intrinsic (e);
if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
gfc_warning (OPT_Wdeprecated_declarations,
"Using variable %qs at %L is deprecated",
@ -13905,22 +13230,8 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
start:
t = true;
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
{
switch (code->op)
{
case EXEC_ASSIGN:
case EXEC_LOCK:
case EXEC_UNLOCK:
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
caf_lhs = gfc_is_coindexed (code->expr1);
break;
default:
break;
}
t = gfc_resolve_expr (code->expr1);
caf_lhs = false;
}
forall_flag = forall_save;
gfc_do_concurrent_flag = do_concurrent_save;

8
libgfortran/caf/libcaf.h
View file

@ -237,11 +237,9 @@ void _gfortran_caf_sendget_by_ref (
int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat,
int *src_stat, int dst_type, int src_type);
void _gfortran_caf_register_accessor (const int hash,
void (*accessor) (void **, int32_t *,
void *, void *,
const size_t *,
size_t *));
void _gfortran_caf_register_accessor (
const int hash, void (*accessor) (void **, int32_t *, void *, void *,
size_t *, const size_t *));
void _gfortran_caf_register_accessors_finish (void);

9
libgfortran/caf/single.c
View file

@ -57,8 +57,8 @@ typedef struct caf_single_token *caf_single_token_t;
/* Global variables. */
caf_static_t *caf_static_list = NULL;
typedef void (*accessor_t) (void **, int32_t *, void *, void *, const size_t *,
size_t *);
typedef void (*accessor_t) (void **, int32_t *, void *, void *, size_t *,
const size_t *);
struct accessor_hash_t
{
int hash;
@ -129,6 +129,7 @@ _gfortran_caf_finalize (void)
while (caf_static_list != NULL)
{
caf_static_t *tmp = caf_static_list->prev;
free (((caf_single_token_t) caf_static_list->token)->memptr);
free (caf_static_list->token);
free (caf_static_list);
caf_static_list = tmp;
@ -2941,8 +2942,8 @@ _gfortran_caf_get_by_ct (
}
accessor_hash_table[getter_index].accessor (dst_ptr, &free_buffer, src_ptr,
get_data, opt_src_charlen,
opt_dst_charlen);
get_data, opt_dst_charlen,
opt_src_charlen);
if (opt_dst_desc && old_dst_data_ptr && !may_realloc_dst
&& opt_dst_desc->base_addr != old_dst_data_ptr)
{