diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index e3219c1f01e..5b2f921bf2e 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -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 \ diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc new file mode 100644 index 00000000000..1094a3aec2a --- /dev/null +++ b/gcc/fortran/coarray.cc @@ -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 +. */ + +/* 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; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 557c5c76f41..c319768d758 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 336ea89c5a9..a95bb62afb8 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -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 diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 3d3f117216c..12eb0725c02 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -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; diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 67f7389a942..edeb1a6fc69 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -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); diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 195c50e8f31..a877138f244 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -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) {