Line data Source code
1 : /* Rewrite the expression tree for coarrays.
2 : Copyright (C) 2010-2026 Free Software Foundation, Inc.
3 : Contributed by Andre Vehreschild.
4 :
5 : This file is part of GCC.
6 :
7 : GCC is free software; you can redistribute it and/or modify it under
8 : the terms of the GNU General Public License as published by the Free
9 : Software Foundation; either version 3, or (at your option) any later
10 : version.
11 :
12 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with GCC; see the file COPYING3. If not see
19 : <http://www.gnu.org/licenses/>. */
20 :
21 : /* Rewrite the expression for coarrays where needed:
22 : - coarray indexing operations need the indexing expression put into a
23 : routine callable on the remote image
24 :
25 : This rewriter is meant to used for non-optimisational expression tree
26 : rewrites. When implementing early optimisation it is recommended to
27 : do this in frontend-passes.cc.
28 : */
29 :
30 : #include "config.h"
31 : #include "system.h"
32 : #include "coretypes.h"
33 : #include "options.h"
34 : #include "bitmap.h"
35 : #include "gfortran.h"
36 :
37 : /* The code tree element that is currently processed. */
38 : static gfc_code **current_code;
39 :
40 : /* Code that is inserted into the current caf_accessor at the beginning. */
41 : static gfc_code *caf_accessor_prepend = nullptr;
42 :
43 : static bool caf_on_lhs = false;
44 :
45 : static int caf_sym_cnt = 0;
46 :
47 : static gfc_array_spec *
48 26 : get_arrayspec_from_expr (gfc_expr *expr)
49 : {
50 26 : gfc_array_spec *src_as, *dst_as = NULL;
51 26 : gfc_ref *ref;
52 26 : gfc_array_ref mod_src_ar;
53 26 : int dst_rank = 0;
54 :
55 26 : if (expr->rank == 0)
56 : return NULL;
57 :
58 26 : if (expr->expr_type == EXPR_FUNCTION)
59 0 : return gfc_copy_array_spec (expr->symtree->n.sym->as);
60 :
61 : /* Follow any component references. */
62 26 : if (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_CONSTANT)
63 : {
64 26 : if (expr->symtree)
65 26 : src_as = expr->symtree->n.sym->as;
66 : else
67 : src_as = NULL;
68 :
69 52 : for (ref = expr->ref; ref; ref = ref->next)
70 : {
71 26 : switch (ref->type)
72 : {
73 0 : case REF_COMPONENT:
74 0 : src_as = ref->u.c.component->as;
75 0 : continue;
76 :
77 0 : case REF_SUBSTRING:
78 0 : case REF_INQUIRY:
79 0 : continue;
80 :
81 26 : case REF_ARRAY:
82 26 : switch (ref->u.ar.type)
83 : {
84 : case AR_ELEMENT:
85 26 : src_as = NULL;
86 : break;
87 0 : case AR_SECTION:
88 0 : {
89 0 : if (!dst_as)
90 0 : dst_as = gfc_get_array_spec ();
91 0 : memset (&mod_src_ar, 0, sizeof (gfc_array_ref));
92 0 : mod_src_ar = ref->u.ar;
93 0 : for (int dim = 0; dim < src_as->rank; ++dim)
94 : {
95 0 : switch (ref->u.ar.dimen_type[dim])
96 : {
97 0 : case DIMEN_ELEMENT:
98 0 : gfc_free_expr (mod_src_ar.start[dim]);
99 0 : mod_src_ar.start[dim] = NULL;
100 0 : break;
101 0 : case DIMEN_RANGE:
102 0 : dst_as->lower[dst_rank]
103 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
104 0 : mod_src_ar.start[dst_rank]
105 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
106 0 : if (ref->u.ar.end[dim])
107 : {
108 0 : dst_as->upper[dst_rank]
109 0 : = gfc_copy_expr (ref->u.ar.end[dim]);
110 0 : mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
111 0 : mod_src_ar.stride[dst_rank]
112 0 : = ref->u.ar.stride[dim];
113 : }
114 : else
115 0 : dst_as->upper[dst_rank]
116 0 : = gfc_copy_expr (ref->u.ar.as->upper[dim]);
117 0 : ++dst_rank;
118 0 : break;
119 0 : case DIMEN_STAR:
120 0 : dst_as->lower[dst_rank]
121 0 : = gfc_copy_expr (ref->u.ar.as->lower[dim]);
122 0 : mod_src_ar.start[dst_rank]
123 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
124 0 : if (ref->u.ar.as->upper[dim])
125 : {
126 0 : dst_as->upper[dst_rank]
127 0 : = gfc_copy_expr (ref->u.ar.as->upper[dim]);
128 0 : mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
129 0 : mod_src_ar.stride[dst_rank]
130 0 : = ref->u.ar.stride[dim];
131 : }
132 0 : ++dst_rank;
133 0 : break;
134 0 : case DIMEN_VECTOR:
135 0 : dst_as->lower[dst_rank]
136 0 : = gfc_get_constant_expr (BT_INTEGER,
137 : gfc_index_integer_kind,
138 : &expr->where);
139 0 : mpz_set_ui (dst_as->lower[dst_rank]->value.integer,
140 : 1);
141 0 : mod_src_ar.start[dst_rank]
142 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
143 0 : dst_as->upper[dst_rank]
144 0 : = gfc_get_constant_expr (BT_INTEGER,
145 : gfc_index_integer_kind,
146 : &expr->where);
147 0 : mpz_set (dst_as->upper[dst_rank]->value.integer,
148 0 : ref->u.ar.start[dim]->shape[0]);
149 0 : ++dst_rank;
150 0 : break;
151 0 : case DIMEN_THIS_IMAGE:
152 0 : case DIMEN_UNKNOWN:
153 0 : gcc_unreachable ();
154 : }
155 0 : if (ref->u.ar.dimen_type[dim] != DIMEN_ELEMENT)
156 0 : mod_src_ar.dimen_type[dst_rank]
157 0 : = ref->u.ar.dimen_type[dim];
158 : }
159 0 : dst_as->rank = dst_rank;
160 0 : dst_as->type = AS_EXPLICIT;
161 0 : ref->u.ar = mod_src_ar;
162 0 : ref->u.ar.dimen = dst_rank;
163 0 : break;
164 :
165 : case AR_UNKNOWN:
166 26 : src_as = NULL;
167 : break;
168 :
169 26 : case AR_FULL:
170 26 : if (dst_as)
171 : /* Prevent memory loss. */
172 0 : gfc_free_array_spec (dst_as);
173 26 : dst_as = gfc_copy_array_spec (src_as);
174 26 : break;
175 : }
176 : break;
177 : }
178 0 : }
179 : }
180 : }
181 : else
182 26 : src_as = NULL;
183 :
184 : return dst_as;
185 : }
186 :
187 : static void
188 863 : remove_coarray_from_derived_type (gfc_symbol *base, gfc_namespace *ns,
189 : gfc_array_spec *src_as = NULL)
190 : {
191 863 : gfc_symbol *derived;
192 863 : gfc_symbol *src_derived = base->ts.u.derived;
193 :
194 863 : if (!src_as)
195 820 : src_as = src_derived->as;
196 863 : gfc_get_symbol (src_derived->name, ns, &derived);
197 863 : derived->attr.flavor = FL_DERIVED;
198 863 : derived->attr.alloc_comp = src_derived->attr.alloc_comp;
199 863 : if (src_as && src_as->rank != 0)
200 : {
201 26 : base->attr.dimension = 1;
202 26 : base->as = gfc_copy_array_spec (src_as);
203 26 : base->as->corank = 0;
204 : }
205 4420 : for (gfc_component *p = NULL, *c = src_derived->components; c; c = c->next)
206 : {
207 3557 : gfc_component *n = gfc_get_component ();
208 3557 : *n = *c;
209 3557 : if (n->as)
210 1618 : n->as = gfc_copy_array_spec (c->as);
211 3557 : n->backend_decl = NULL;
212 3557 : n->initializer = NULL;
213 3557 : n->param_list = NULL;
214 3557 : if (p)
215 2696 : p->next = n;
216 : else
217 861 : derived->components = n;
218 :
219 3557 : p = n;
220 : }
221 863 : derived->declared_at = base->declared_at;
222 863 : gfc_set_sym_referenced (derived);
223 863 : gfc_commit_symbol (derived);
224 863 : base->ts.u.derived = derived;
225 863 : gfc_commit_symbol (base);
226 863 : }
227 :
228 : static void
229 43 : convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns)
230 : {
231 43 : gfc_symbol *src_derived = CLASS_DATA (base)->ts.u.derived;
232 43 : gfc_array_spec *src_as = CLASS_DATA (base)->as;
233 86 : const bool attr_allocatable
234 43 : = src_as && src_as->rank && src_as->type == AS_DEFERRED;
235 :
236 43 : base->ts.type = BT_DERIVED;
237 43 : base->ts.u.derived = src_derived;
238 :
239 43 : remove_coarray_from_derived_type (base, ns, src_as);
240 :
241 43 : base->attr.allocatable = attr_allocatable;
242 43 : base->attr.pointer = 0; // Ensure, that it is no pointer.
243 43 : }
244 :
245 : static void
246 1488 : move_coarray_ref (gfc_ref **from, gfc_expr *expr)
247 : {
248 1488 : int i;
249 1488 : gfc_ref *to = expr->ref;
250 1533 : for (; to && to->next; to = to->next)
251 : ;
252 :
253 1488 : if (!to)
254 : {
255 1443 : expr->ref = gfc_get_ref ();
256 1443 : to = expr->ref;
257 1443 : to->type = REF_ARRAY;
258 : }
259 1488 : gcc_assert (to->type == REF_ARRAY);
260 1488 : to->u.ar.as = gfc_copy_array_spec ((*from)->u.ar.as);
261 1488 : to->u.ar.codimen = (*from)->u.ar.codimen;
262 1488 : to->u.ar.dimen = (*from)->u.ar.dimen;
263 1488 : to->u.ar.type = AR_FULL;
264 1488 : to->u.ar.stat = (*from)->u.ar.stat;
265 1488 : (*from)->u.ar.stat = nullptr;
266 1488 : to->u.ar.team = (*from)->u.ar.team;
267 1488 : (*from)->u.ar.team = nullptr;
268 1488 : to->u.ar.team_type = (*from)->u.ar.team_type;
269 1488 : (*from)->u.ar.team_type = TEAM_UNSET;
270 2035 : for (i = 0; i < to->u.ar.dimen; ++i)
271 : {
272 547 : to->u.ar.start[i] = nullptr;
273 547 : to->u.ar.end[i] = nullptr;
274 547 : to->u.ar.stride[i] = nullptr;
275 : }
276 3042 : for (i = (*from)->u.ar.dimen; i < (*from)->u.ar.dimen + (*from)->u.ar.codimen;
277 : ++i)
278 : {
279 1554 : to->u.ar.dimen_type[i] = (*from)->u.ar.dimen_type[i];
280 1554 : to->u.ar.start[i] = (*from)->u.ar.start[i];
281 1554 : (*from)->u.ar.start[i] = nullptr;
282 1554 : to->u.ar.end[i] = (*from)->u.ar.end[i];
283 1554 : (*from)->u.ar.end[i] = nullptr;
284 1554 : to->u.ar.stride[i] = (*from)->u.ar.stride[i];
285 1554 : (*from)->u.ar.stride[i] = nullptr;
286 : }
287 1488 : (*from)->u.ar.codimen = 0;
288 1488 : if ((*from)->u.ar.dimen == 0)
289 : {
290 1075 : gfc_ref *nref = (*from)->next;
291 1075 : (*from)->next = nullptr;
292 1075 : gfc_free_ref_list (*from);
293 1075 : *from = nref;
294 : }
295 1488 : }
296 :
297 : static void
298 2976 : fixup_comp_refs (gfc_expr *expr)
299 : {
300 2976 : bool class_ref = expr->symtree->n.sym->ts.type == BT_CLASS;
301 1708 : gfc_symbol *type
302 : = expr->symtree->n.sym->ts.type == BT_DERIVED
303 2976 : ? expr->symtree->n.sym->ts.u.derived
304 1268 : : (class_ref ? CLASS_DATA (expr->symtree->n.sym)->ts.u.derived
305 : : nullptr);
306 1745 : if (!type)
307 : return;
308 1745 : gfc_ref **pref = &(expr->ref);
309 1745 : for (gfc_ref *ref = expr->ref; ref && type;)
310 : {
311 2286 : switch (ref->type)
312 : {
313 1213 : case REF_COMPONENT:
314 1213 : gfc_find_component (type, ref->u.c.component->name, false, true,
315 : pref);
316 1213 : if (!*pref)
317 : {
318 : /* This happens when there were errors previously. Just don't
319 : crash. */
320 : ref = nullptr;
321 : break;
322 : }
323 1213 : if (class_ref)
324 : /* Link to the class type to allow for derived type resolution. */
325 0 : (*pref)->u.c.sym = ref->u.c.sym;
326 1213 : (*pref)->next = ref->next;
327 1213 : ref->next = NULL;
328 1213 : gfc_free_ref_list (ref);
329 1213 : ref = (*pref)->next;
330 350 : type = (*pref)->u.c.component->ts.type == BT_DERIVED
331 1213 : ? (*pref)->u.c.component->ts.u.derived
332 : : ((*pref)->u.c.component->ts.type == BT_CLASS
333 863 : ? CLASS_DATA ((*pref)->u.c.component)->ts.u.derived
334 : : nullptr);
335 1213 : pref = &(*pref)->next;
336 1213 : break;
337 1073 : case REF_ARRAY:
338 1073 : pref = &ref->next;
339 1073 : ref = ref->next;
340 1073 : break;
341 0 : default:
342 0 : gcc_unreachable ();
343 4031 : break;
344 : }
345 : }
346 : }
347 :
348 : static void
349 1488 : split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
350 : gfc_expr **post_caf_ref_expr, bool for_send)
351 : {
352 1488 : gfc_ref *caf_ref = NULL;
353 1488 : gfc_symtree *st;
354 1488 : gfc_symbol *base;
355 1488 : gfc_typespec *caf_ts;
356 1488 : bool created;
357 :
358 1488 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
359 1488 : caf_ts = &expr->symtree->n.sym->ts;
360 1488 : if (!(expr->symtree->n.sym->ts.type == BT_CLASS
361 1488 : ? CLASS_DATA (expr->symtree->n.sym)->attr.codimension
362 1451 : : expr->symtree->n.sym->attr.codimension))
363 : {
364 : /* The coarray is in some component. Find it. */
365 45 : caf_ref = expr->ref;
366 90 : while (caf_ref)
367 : {
368 90 : if (caf_ref->type == REF_ARRAY && caf_ref->u.ar.codimen != 0)
369 : break;
370 45 : if (caf_ref->type == REF_COMPONENT)
371 45 : caf_ts = &caf_ref->u.c.component->ts;
372 45 : caf_ref = caf_ref->next;
373 : }
374 : }
375 :
376 1488 : created = !gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns, &st,
377 : false);
378 1488 : gcc_assert (created);
379 1488 : st->n.sym->attr.flavor = FL_PARAMETER;
380 1488 : st->n.sym->attr.dummy = 1;
381 1488 : st->n.sym->attr.intent = INTENT_IN;
382 1488 : st->n.sym->ts = *caf_ts;
383 1488 : st->n.sym->declared_at = expr->where;
384 :
385 1488 : *post_caf_ref_expr = gfc_get_variable_expr (st);
386 1488 : (*post_caf_ref_expr)->where = expr->where;
387 1488 : base = (*post_caf_ref_expr)->symtree->n.sym;
388 :
389 1488 : if (!caf_ref)
390 : {
391 1443 : (*post_caf_ref_expr)->ref = gfc_get_ref ();
392 1443 : *(*post_caf_ref_expr)->ref = *expr->ref;
393 1443 : expr->ref = nullptr;
394 1443 : move_coarray_ref (&(*post_caf_ref_expr)->ref, expr);
395 1443 : fixup_comp_refs (expr);
396 :
397 1443 : if (expr->symtree->n.sym->attr.dimension)
398 : {
399 383 : base->as = gfc_copy_array_spec (expr->symtree->n.sym->as);
400 383 : base->as->corank = 0;
401 383 : base->attr.dimension = 1;
402 383 : base->attr.allocatable = expr->symtree->n.sym->attr.allocatable;
403 383 : base->attr.pointer = expr->symtree->n.sym->attr.pointer
404 383 : || expr->symtree->n.sym->attr.associate_var;
405 : }
406 : }
407 : else
408 : {
409 45 : (*post_caf_ref_expr)->ref = gfc_get_ref ();
410 45 : *(*post_caf_ref_expr)->ref = *caf_ref;
411 45 : caf_ref->next = nullptr;
412 45 : move_coarray_ref (&(*post_caf_ref_expr)->ref, expr);
413 45 : fixup_comp_refs (expr);
414 :
415 45 : if (caf_ref && caf_ref->u.ar.dimen)
416 : {
417 6 : base->as = gfc_copy_array_spec (caf_ref->u.ar.as);
418 6 : base->as->corank = 0;
419 6 : base->attr.dimension = 1;
420 6 : base->attr.allocatable = caf_ref->u.ar.as->type != AS_EXPLICIT;
421 : }
422 45 : base->ts = *caf_ts;
423 : }
424 1488 : (*post_caf_ref_expr)->ts = expr->ts;
425 1488 : if (base->ts.type == BT_CHARACTER)
426 : {
427 213 : base->ts.u.cl = gfc_get_charlen ();
428 213 : *base->ts.u.cl = *(caf_ts->u.cl);
429 213 : base->ts.deferred = 1;
430 213 : base->ts.u.cl->length = nullptr;
431 : }
432 1275 : else if (base->ts.type == BT_DERIVED)
433 820 : remove_coarray_from_derived_type (base, ns);
434 455 : else if (base->ts.type == BT_CLASS)
435 43 : convert_coarray_class_to_derived_type (base, ns);
436 :
437 1488 : memset (&(*post_caf_ref_expr)->ts, 0, sizeof (gfc_typespec));
438 1488 : gfc_resolve_expr (*post_caf_ref_expr);
439 1488 : (*post_caf_ref_expr)->corank = 0;
440 1488 : gfc_expression_rank (*post_caf_ref_expr);
441 1488 : if (for_send)
442 667 : gfc_expression_rank (expr);
443 : else
444 821 : expr->rank = (*post_caf_ref_expr)->rank;
445 1488 : }
446 :
447 : static void add_caf_get_from_remote (gfc_expr *e);
448 :
449 : static gfc_component *
450 316 : find_comp (gfc_symbol *type, gfc_expr *e, int *cnt, const bool is_var)
451 : {
452 316 : char *temp_name = nullptr;
453 316 : gfc_component *comp = type->components;
454 :
455 : /* For variables:
456 : - look up same name or create new
457 : all else:
458 : - create unique new
459 : */
460 316 : if (is_var)
461 : {
462 192 : ++(*cnt);
463 192 : free (temp_name);
464 192 : temp_name = xasprintf ("caf_temp_%s_%d", e->symtree->name, *cnt);
465 534 : while (comp && strcmp (comp->name, temp_name) != 0)
466 150 : comp = comp->next;
467 192 : if (!comp)
468 : {
469 192 : const bool added = gfc_add_component (type, temp_name, &comp);
470 192 : gcc_assert (added);
471 : }
472 : }
473 : else
474 : {
475 : int r = -1;
476 : /* Components are always appended, i.e., when searching to add a unique
477 : one just iterating forward is sufficient. */
478 124 : do
479 : {
480 124 : ++(*cnt);
481 124 : free (temp_name);
482 124 : temp_name = xasprintf ("caf_temp_%s_%d", e->symtree->name, *cnt);
483 :
484 250 : while (comp && (r = strcmp (comp->name, temp_name)) <= 0)
485 2 : comp = comp->next;
486 : }
487 124 : while (comp && r <= 0);
488 124 : {
489 124 : const bool added = gfc_add_component (type, temp_name, &comp);
490 124 : gcc_assert (added);
491 : }
492 : }
493 :
494 316 : comp->loc = e->where;
495 316 : comp->ts = e->ts;
496 316 : free (temp_name);
497 :
498 316 : return comp;
499 : }
500 :
501 : static void
502 316 : check_add_new_comp_handle_array (gfc_expr *e, gfc_symbol *type,
503 : gfc_symbol *add_data)
504 : {
505 316 : gfc_component *comp;
506 316 : static int cnt = -1;
507 316 : gfc_symtree *caller_image;
508 316 : gfc_code *pre_code = caf_accessor_prepend;
509 316 : bool static_array_or_scalar = true;
510 316 : symbol_attribute e_attr = gfc_expr_attr (e);
511 :
512 316 : gfc_free_shape (&e->shape, e->rank);
513 :
514 : /* When already code to prepend into the accessor exists, go to
515 : the end of the chain. */
516 632 : for (; pre_code && pre_code->next; pre_code = pre_code->next)
517 : ;
518 :
519 316 : comp = find_comp (type, e, &cnt,
520 316 : e->symtree->n.sym->attr.flavor == FL_VARIABLE
521 316 : || e->symtree->n.sym->attr.flavor == FL_PARAMETER);
522 :
523 316 : if (e->expr_type == EXPR_FUNCTION
524 192 : || (e->expr_type == EXPR_VARIABLE && e_attr.dimension
525 26 : && e_attr.allocatable))
526 : {
527 126 : gfc_code *code;
528 126 : gfc_symtree *st;
529 126 : const bool created
530 126 : = !gfc_get_sym_tree (comp->name, gfc_current_ns, &st, false, &e->where);
531 126 : gcc_assert (created);
532 :
533 126 : st->n.sym->ts = e->ts;
534 126 : gfc_set_sym_referenced (st->n.sym);
535 126 : code = gfc_get_code (EXEC_ASSIGN);
536 126 : code->loc = e->where;
537 126 : code->expr1 = gfc_get_variable_expr (st);
538 126 : code->expr2 = XCNEW (gfc_expr);
539 126 : *(code->expr2) = *e;
540 126 : code->next = *current_code;
541 126 : *current_code = code;
542 :
543 126 : if (e_attr.dimension)
544 : {
545 2 : gfc_array_spec *as = get_arrayspec_from_expr (e);
546 2 : static_array_or_scalar = gfc_is_compile_time_shape (as);
547 :
548 2 : comp->attr.dimension = 1;
549 2 : st->n.sym->attr.dimension = 1;
550 2 : st->n.sym->as = as;
551 :
552 2 : if (!static_array_or_scalar)
553 : {
554 2 : comp->attr.allocatable = 1;
555 2 : st->n.sym->attr.allocatable = 1;
556 : }
557 2 : code->expr1->rank = as->rank;
558 2 : gfc_add_full_array_ref (code->expr1, gfc_copy_array_spec (as));
559 2 : comp->as = gfc_copy_array_spec (as);
560 : }
561 :
562 126 : gfc_expression_rank (code->expr1);
563 126 : comp->initializer = gfc_get_variable_expr (st);
564 126 : gfc_commit_symbol (st->n.sym);
565 126 : }
566 : else
567 : {
568 190 : comp->initializer = gfc_copy_expr (e);
569 190 : if (e_attr.dimension && e->rank)
570 : {
571 24 : comp->attr.dimension = 1;
572 24 : comp->as = get_arrayspec_from_expr (e);
573 : }
574 : }
575 316 : comp->initializer->where = e->where;
576 316 : comp->attr.access = ACCESS_PRIVATE;
577 316 : memset (e, 0, sizeof (gfc_expr));
578 316 : e->ts = comp->initializer->ts;
579 316 : e->expr_type = EXPR_VARIABLE;
580 316 : e->where = comp->initializer->where;
581 :
582 316 : if (comp->as && comp->as->rank)
583 : {
584 26 : if (static_array_or_scalar)
585 : {
586 24 : e->ref = gfc_get_ref ();
587 24 : e->ref->type = REF_ARRAY;
588 24 : e->ref->u.ar.as = gfc_copy_array_spec (add_data->as);
589 24 : e->ref->u.ar.codimen = 1;
590 24 : e->ref->u.ar.dimen_type[0] = DIMEN_THIS_IMAGE;
591 : }
592 : else
593 : {
594 2 : gfc_code *c;
595 2 : gfc_symtree *lv, *ad;
596 2 : bool created = !gfc_get_sym_tree (comp->name, add_data->ns, &lv,
597 2 : false, &e->where);
598 2 : gcc_assert (created);
599 :
600 2 : lv->n.sym->ts = e->ts;
601 2 : lv->n.sym->attr.dimension = 1;
602 2 : lv->n.sym->attr.allocatable = 1;
603 2 : lv->n.sym->attr.flavor = FL_VARIABLE;
604 2 : lv->n.sym->as = gfc_copy_array_spec (comp->as);
605 2 : gfc_set_sym_referenced (lv->n.sym);
606 2 : gfc_commit_symbol (lv->n.sym);
607 2 : c = gfc_get_code (EXEC_ASSIGN);
608 2 : c->loc = e->where;
609 2 : c->expr1 = gfc_get_variable_expr (lv);
610 2 : c->expr1->where = e->where;
611 :
612 2 : created = !gfc_find_sym_tree (add_data->name, add_data->ns, 0, &ad);
613 2 : gcc_assert (created);
614 2 : c->expr2 = gfc_get_variable_expr (ad);
615 2 : c->expr2->where = e->where;
616 2 : c->expr2->ts = comp->initializer->ts;
617 2 : c->expr2->ref = gfc_get_ref ();
618 2 : c->expr2->ref->type = REF_ARRAY;
619 2 : c->expr2->ref->u.ar.as = gfc_copy_array_spec (add_data->as);
620 2 : c->expr2->ref->u.ar.codimen = 1;
621 2 : c->expr2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
622 2 : caller_image
623 2 : = gfc_find_symtree_in_proc ("caller_image", add_data->ns);
624 2 : gcc_assert (caller_image);
625 2 : c->expr2->ref->u.ar.start[0] = gfc_get_variable_expr (caller_image);
626 2 : c->expr2->ref->u.ar.start[0]->where = e->where;
627 2 : created = gfc_find_component (ad->n.sym->ts.u.derived, comp->name,
628 : false, true, &c->expr2->ref->next)
629 : != nullptr;
630 2 : gcc_assert (created);
631 2 : c->expr2->rank = comp->as->rank;
632 2 : gfc_add_full_array_ref (c->expr2, gfc_copy_array_spec (comp->as));
633 2 : gfc_set_sym_referenced (ad->n.sym);
634 2 : gfc_commit_symbol (ad->n.sym);
635 2 : if (pre_code)
636 0 : pre_code->next = c;
637 : else
638 2 : caf_accessor_prepend = c;
639 2 : add_caf_get_from_remote (c->expr2);
640 :
641 2 : e->symtree = lv;
642 2 : gfc_expression_rank (e);
643 2 : gfc_add_full_array_ref (e, gfc_copy_array_spec (comp->as));
644 : }
645 : }
646 : else
647 : {
648 290 : e->ref = gfc_get_ref ();
649 290 : e->ref->type = REF_ARRAY;
650 290 : e->ref->u.ar.as = gfc_copy_array_spec (add_data->as);
651 290 : e->ref->u.ar.codimen = 1;
652 290 : e->ref->u.ar.dimen_type[0] = DIMEN_THIS_IMAGE;
653 : }
654 :
655 316 : if (static_array_or_scalar)
656 : {
657 314 : const bool created
658 314 : = gfc_find_component (add_data->ts.u.derived, comp->name, false, true,
659 314 : &e->ref);
660 314 : gcc_assert (created);
661 314 : e->symtree = gfc_find_symtree (add_data->ns->sym_root, add_data->name);
662 314 : gcc_assert (e->symtree);
663 314 : if (IS_CLASS_ARRAY (e->ref->u.c.component)
664 314 : || e->ref->u.c.component->attr.dimension)
665 : {
666 24 : gfc_add_full_array_ref (e, e->ref->u.c.component->ts.type == BT_CLASS
667 0 : ? CLASS_DATA (e->ref->u.c.component)->as
668 : : e->ref->u.c.component->as);
669 48 : e->ref->next->u.ar.dimen
670 24 : = e->ref->u.c.component->ts.type == BT_CLASS
671 24 : ? CLASS_DATA (e->ref->u.c.component)->as->rank
672 24 : : e->ref->u.c.component->as->rank;
673 : }
674 314 : gfc_expression_rank (e);
675 : }
676 316 : }
677 :
678 : static void
679 4879 : check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *add_data)
680 : {
681 4887 : if (e)
682 : {
683 969 : switch (e->expr_type)
684 : {
685 : case EXPR_CONSTANT:
686 : case EXPR_NULL:
687 : break;
688 10 : case EXPR_OP:
689 10 : check_add_new_component (type, e->value.op.op1, add_data);
690 10 : if (e->value.op.op2)
691 : check_add_new_component (type, e->value.op.op2, add_data);
692 : break;
693 0 : case EXPR_COMPCALL:
694 0 : for (gfc_actual_arglist *actual = e->value.compcall.actual; actual;
695 0 : actual = actual->next)
696 0 : check_add_new_component (type, actual->expr, add_data);
697 : break;
698 124 : case EXPR_FUNCTION:
699 124 : check_add_new_comp_handle_array (e, type, add_data);
700 124 : break;
701 192 : case EXPR_VARIABLE:
702 192 : check_add_new_comp_handle_array (e, type, add_data);
703 192 : break;
704 0 : case EXPR_ARRAY:
705 0 : case EXPR_PPC:
706 0 : case EXPR_STRUCTURE:
707 0 : case EXPR_SUBSTRING:
708 0 : gcc_unreachable ();
709 : default:;
710 : }
711 : }
712 4879 : }
713 :
714 : static gfc_symbol *
715 1488 : create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns,
716 : gfc_symbol *add_data)
717 : {
718 1488 : static int type_cnt = 0;
719 1488 : char tname[GFC_MAX_SYMBOL_LEN + 1];
720 1488 : char *name;
721 1488 : gfc_symbol *type;
722 :
723 1488 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
724 :
725 1488 : strcpy (tname, expr->symtree->name);
726 1488 : name = xasprintf ("@_caf_add_data_t_%s_%d", tname, ++type_cnt);
727 1488 : gfc_get_symbol (name, ns, &type);
728 :
729 1488 : type->attr.flavor = FL_DERIVED;
730 1488 : add_data->ts.u.derived = type;
731 1488 : add_data->attr.codimension = 1;
732 1488 : add_data->as = gfc_get_array_spec ();
733 1488 : add_data->as->corank = 1;
734 1488 : add_data->as->type = AS_EXPLICIT;
735 1488 : add_data->as->cotype = AS_DEFERRED;
736 1488 : add_data->as->lower[0]
737 1488 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
738 : &expr->where);
739 1488 : mpz_set_si (add_data->as->lower[0]->value.integer, 1);
740 :
741 3749 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
742 : {
743 2261 : if (ref->type == REF_ARRAY)
744 : {
745 : gfc_array_ref *ar = &ref->u.ar;
746 2716 : for (int i = 0; i < ar->dimen; ++i)
747 : {
748 1623 : check_add_new_component (type, ar->start[i], add_data);
749 1623 : check_add_new_component (type, ar->end[i], add_data);
750 1623 : check_add_new_component (type, ar->stride[i], add_data);
751 : }
752 : }
753 : }
754 :
755 1488 : type->declared_at = expr->where;
756 1488 : gfc_set_sym_referenced (type);
757 1488 : gfc_commit_symbol (type);
758 1488 : free (name);
759 1488 : return type;
760 : }
761 :
762 : static void
763 1488 : remove_caf_ref (gfc_expr *expr, const bool conv_to_this_image_cafref = false)
764 : {
765 1488 : gfc_ref *ref = expr->ref;
766 3254 : while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
767 : {
768 1766 : ref = ref->next;
769 : }
770 1488 : if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
771 : {
772 413 : if (ref->u.ar.dimen != 0)
773 : {
774 413 : ref->u.ar.codimen = 0;
775 413 : ref = ref->next;
776 : }
777 : else
778 : {
779 0 : if (conv_to_this_image_cafref)
780 : {
781 0 : for (int i = ref->u.ar.dimen;
782 0 : i < ref->u.ar.dimen + ref->u.ar.codimen; ++i)
783 0 : ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
784 : }
785 : else
786 : {
787 0 : expr->ref = ref->next;
788 0 : ref->next = NULL;
789 0 : gfc_free_ref_list (ref);
790 0 : ref = expr->ref;
791 : }
792 : }
793 : }
794 1488 : fixup_comp_refs (expr);
795 1488 : }
796 :
797 : static gfc_expr *
798 821 : create_get_callback (gfc_expr *expr)
799 : {
800 821 : gfc_namespace *ns;
801 821 : gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data,
802 : *old_buffer_data, *caller_image;
803 821 : char tname[GFC_MAX_SYMBOL_LEN + 1];
804 821 : char *name;
805 821 : const char *mname;
806 821 : gfc_expr *cb, *post_caf_ref_expr;
807 821 : gfc_code *code;
808 821 : int expr_rank = expr->rank;
809 821 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
810 821 : caf_accessor_prepend = nullptr;
811 :
812 : /* Find the top-level namespace. */
813 975 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
814 : ;
815 :
816 821 : if (expr->expr_type == EXPR_VARIABLE)
817 821 : strcpy (tname, expr->symtree->name);
818 : else
819 0 : strcpy (tname, "dummy");
820 821 : if (expr->symtree->n.sym->module)
821 5 : mname = expr->symtree->n.sym->module;
822 : else
823 : mname = "main";
824 821 : name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
825 821 : gfc_get_symbol (name, ns, &extproc);
826 821 : extproc->declared_at = expr->where;
827 821 : gfc_set_sym_referenced (extproc);
828 821 : ++extproc->refs;
829 821 : gfc_commit_symbol (extproc);
830 :
831 : /* Set up namespace. */
832 821 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
833 821 : sub_ns->sibling = ns->contained;
834 821 : ns->contained = sub_ns;
835 821 : sub_ns->resolved = 1;
836 : /* Set up procedure symbol. */
837 821 : gfc_find_symbol (name, sub_ns, 1, &proc);
838 821 : sub_ns->proc_name = proc;
839 821 : proc->attr.if_source = IFSRC_DECL;
840 821 : proc->attr.access = ACCESS_PUBLIC;
841 821 : gfc_add_subroutine (&proc->attr, name, NULL);
842 821 : proc->attr.host_assoc = 1;
843 821 : proc->attr.always_explicit = 1;
844 821 : ++proc->refs;
845 821 : proc->declared_at = expr->where;
846 821 : gfc_commit_symbol (proc);
847 821 : free (name);
848 :
849 821 : split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, false);
850 :
851 821 : if (ns->proc_name->attr.flavor == FL_MODULE)
852 2 : proc->module = ns->proc_name->name;
853 821 : gfc_set_sym_referenced (proc);
854 : /* Set up formal arguments. */
855 821 : gfc_formal_arglist **argptr = &proc->formal;
856 : #define ADD_ARG(name, nsym, stype, skind, sintent) \
857 : gfc_get_symbol (name, sub_ns, &nsym); \
858 : nsym->ts.type = stype; \
859 : nsym->ts.kind = skind; \
860 : nsym->attr.flavor = FL_PARAMETER; \
861 : nsym->attr.dummy = 1; \
862 : nsym->attr.intent = sintent; \
863 : nsym->declared_at = expr->where; \
864 : gfc_set_sym_referenced (nsym); \
865 : *argptr = gfc_get_formal_arglist (); \
866 : (*argptr)->sym = nsym; \
867 : argptr = &(*argptr)->next
868 :
869 821 : name = xasprintf ("add_data_%s_%s_%d", mname, tname, caf_sym_cnt);
870 821 : ADD_ARG (name, get_data, BT_DERIVED, 0, INTENT_IN);
871 821 : gfc_commit_symbol (get_data);
872 821 : free (name);
873 :
874 821 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
875 : INTENT_IN);
876 821 : gfc_commit_symbol (caller_image);
877 :
878 821 : ADD_ARG ("buffer", buffer, expr->ts.type, expr->ts.kind, INTENT_INOUT);
879 821 : buffer->ts = expr->ts;
880 821 : if (expr_rank)
881 : {
882 444 : buffer->as = gfc_get_array_spec ();
883 444 : buffer->as->rank = expr_rank;
884 444 : if (expr->shape)
885 : {
886 254 : buffer->as->type = AS_EXPLICIT;
887 624 : for (int d = 0; d < expr_rank; ++d)
888 : {
889 370 : buffer->as->lower[d]
890 370 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
891 : &gfc_current_locus);
892 370 : gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1);
893 370 : buffer->as->upper[d]
894 370 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
895 : &gfc_current_locus);
896 370 : gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer,
897 370 : gfc_mpz_get_hwi (expr->shape[d]));
898 : }
899 254 : buffer->attr.allocatable = 1;
900 : }
901 : else
902 : {
903 190 : buffer->as->type = AS_DEFERRED;
904 190 : buffer->attr.allocatable = 1;
905 : }
906 444 : buffer->attr.dimension = 1;
907 : }
908 : else
909 377 : buffer->attr.pointer = 1;
910 821 : if (buffer->ts.type == BT_CHARACTER)
911 : {
912 97 : buffer->ts.u.cl = gfc_get_charlen ();
913 97 : *buffer->ts.u.cl = *expr->ts.u.cl;
914 97 : buffer->ts.u.cl->length = gfc_copy_expr (expr->ts.u.cl->length);
915 : }
916 821 : gfc_commit_symbol (buffer);
917 :
918 821 : ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, gfc_default_logical_kind,
919 : INTENT_OUT);
920 821 : gfc_commit_symbol (free_buffer);
921 :
922 : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
923 821 : base = post_caf_ref_expr->symtree->n.sym;
924 821 : gfc_set_sym_referenced (base);
925 821 : gfc_commit_symbol (base);
926 821 : *argptr = gfc_get_formal_arglist ();
927 821 : (*argptr)->sym = base;
928 821 : argptr = &(*argptr)->next;
929 821 : gfc_commit_symbol (base);
930 : #undef ADD_ARG
931 :
932 : /* Set up code. */
933 821 : if (expr->rank != 0)
934 : {
935 : /* Code: old_buffer_ptr = C_LOC (buffer); */
936 444 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
937 444 : gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data);
938 444 : old_buffer_data->ts.type = BT_VOID;
939 444 : old_buffer_data->attr.flavor = FL_VARIABLE;
940 444 : old_buffer_data->declared_at = expr->where;
941 444 : gfc_set_sym_referenced (old_buffer_data);
942 444 : gfc_commit_symbol (old_buffer_data);
943 444 : code->loc = expr->where;
944 444 : code->expr1 = gfc_lval_expr_from_sym (old_buffer_data);
945 444 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
946 : gfc_current_locus, 1,
947 : gfc_lval_expr_from_sym (buffer));
948 444 : code->next = gfc_get_code (EXEC_ASSIGN);
949 444 : code = code->next;
950 : }
951 : else
952 377 : code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN);
953 :
954 : /* Code: buffer = expr; */
955 821 : code->loc = expr->where;
956 821 : code->expr1 = gfc_lval_expr_from_sym (buffer);
957 821 : code->expr2 = post_caf_ref_expr;
958 821 : remove_caf_ref (post_caf_ref_expr);
959 821 : get_data->ts.u.derived
960 821 : = create_caf_add_data_parameter_type (code->expr2, ns, get_data);
961 821 : if (code->expr2->rank == 0 && code->expr2->ts.type != BT_CHARACTER)
962 312 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
963 : gfc_current_locus, 1, code->expr2);
964 :
965 : /* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or
966 : * *free_buffer = 0; for rank == 0. */
967 821 : code->next = gfc_get_code (EXEC_ASSIGN);
968 821 : code = code->next;
969 821 : code->loc = expr->where;
970 821 : code->expr1 = gfc_lval_expr_from_sym (free_buffer);
971 821 : if (expr->rank != 0)
972 : {
973 444 : code->expr2 = gfc_get_operator_expr (
974 : &gfc_current_locus, INTRINSIC_NE_OS,
975 : gfc_lval_expr_from_sym (old_buffer_data),
976 : gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
977 : gfc_current_locus, 1,
978 : gfc_lval_expr_from_sym (buffer)));
979 444 : code->expr2->ts.type = BT_LOGICAL;
980 444 : code->expr2->ts.kind = gfc_default_logical_kind;
981 : }
982 : else
983 : {
984 377 : code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
985 : &gfc_current_locus, false);
986 : }
987 :
988 821 : cb = gfc_lval_expr_from_sym (extproc);
989 821 : cb->ts.interface = extproc;
990 :
991 821 : if (caf_accessor_prepend)
992 : {
993 : gfc_code *c = caf_accessor_prepend;
994 : /* Find last in chain. */
995 2 : for (; c->next; c = c->next)
996 : ;
997 2 : c->next = sub_ns->code;
998 2 : sub_ns->code = caf_accessor_prepend;
999 : }
1000 821 : caf_accessor_prepend = backup_caf_accessor_prepend;
1001 821 : return cb;
1002 : }
1003 :
1004 : void
1005 924 : add_caf_get_from_remote (gfc_expr *e)
1006 : {
1007 924 : gfc_expr *wrapper, *tmp_expr, *get_from_remote_expr,
1008 : *get_from_remote_hash_expr;
1009 924 : gfc_ref *ref;
1010 924 : int n;
1011 :
1012 980 : for (ref = e->ref; ref; ref = ref->next)
1013 980 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
1014 : break;
1015 924 : if (ref == NULL)
1016 : return;
1017 :
1018 1664 : for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
1019 983 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1020 : return;
1021 :
1022 681 : tmp_expr = XCNEW (gfc_expr);
1023 681 : *tmp_expr = *e;
1024 681 : get_from_remote_expr = create_get_callback (tmp_expr);
1025 681 : get_from_remote_hash_expr = gfc_get_expr ();
1026 681 : get_from_remote_hash_expr->expr_type = EXPR_CONSTANT;
1027 681 : get_from_remote_hash_expr->ts.type = BT_INTEGER;
1028 681 : get_from_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1029 681 : get_from_remote_hash_expr->where = tmp_expr->where;
1030 681 : mpz_init_set_ui (get_from_remote_hash_expr->value.integer,
1031 681 : gfc_hash_value (get_from_remote_expr->symtree->n.sym));
1032 681 : wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
1033 : "caf_get", tmp_expr->where, 3, tmp_expr,
1034 : get_from_remote_hash_expr,
1035 : get_from_remote_expr);
1036 681 : gfc_add_caf_accessor (get_from_remote_hash_expr, get_from_remote_expr);
1037 681 : wrapper->ts = e->ts;
1038 681 : wrapper->rank = e->rank;
1039 681 : wrapper->corank = e->corank;
1040 681 : if (e->rank)
1041 386 : wrapper->shape = gfc_copy_shape (e->shape, e->rank);
1042 681 : *e = *wrapper;
1043 681 : free (wrapper);
1044 : }
1045 :
1046 : static gfc_expr *
1047 167 : create_allocated_callback (gfc_expr *expr)
1048 : {
1049 167 : gfc_namespace *ns;
1050 167 : gfc_symbol *extproc, *proc, *result, *base, *add_data, *caller_image;
1051 167 : char tname[GFC_MAX_SYMBOL_LEN + 1];
1052 167 : char *name;
1053 167 : const char *mname;
1054 167 : gfc_expr *cb, *post_caf_ref_expr;
1055 167 : gfc_code *code;
1056 167 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
1057 167 : caf_accessor_prepend = nullptr;
1058 167 : gfc_expr swp;
1059 :
1060 : /* Find the top-level namespace. */
1061 175 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
1062 : ;
1063 :
1064 167 : if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
1065 167 : strcpy (tname, expr->value.function.actual->expr->symtree->name);
1066 : else
1067 0 : strcpy (tname, "dummy");
1068 167 : if (expr->value.function.actual->expr->symtree->n.sym->module)
1069 0 : mname = expr->value.function.actual->expr->symtree->n.sym->module;
1070 : else
1071 : mname = "main";
1072 167 : name = xasprintf ("_caf_present_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1073 167 : gfc_get_symbol (name, ns, &extproc);
1074 167 : extproc->declared_at = expr->where;
1075 167 : gfc_set_sym_referenced (extproc);
1076 167 : ++extproc->refs;
1077 167 : gfc_commit_symbol (extproc);
1078 :
1079 : /* Set up namespace. */
1080 167 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
1081 167 : sub_ns->sibling = ns->contained;
1082 167 : ns->contained = sub_ns;
1083 167 : sub_ns->resolved = 1;
1084 : /* Set up procedure symbol. */
1085 167 : gfc_find_symbol (name, sub_ns, 1, &proc);
1086 167 : sub_ns->proc_name = proc;
1087 167 : proc->attr.if_source = IFSRC_DECL;
1088 167 : proc->attr.access = ACCESS_PUBLIC;
1089 167 : gfc_add_subroutine (&proc->attr, name, NULL);
1090 167 : proc->attr.host_assoc = 1;
1091 167 : proc->attr.always_explicit = 1;
1092 167 : proc->declared_at = expr->where;
1093 167 : ++proc->refs;
1094 167 : gfc_commit_symbol (proc);
1095 167 : free (name);
1096 :
1097 167 : split_expr_at_caf_ref (expr->value.function.actual->expr, sub_ns,
1098 : &post_caf_ref_expr, true);
1099 :
1100 167 : if (ns->proc_name->attr.flavor == FL_MODULE)
1101 4 : proc->module = ns->proc_name->name;
1102 167 : gfc_set_sym_referenced (proc);
1103 : /* Set up formal arguments. */
1104 167 : gfc_formal_arglist **argptr = &proc->formal;
1105 : #define ADD_ARG(name, nsym, stype, skind, sintent) \
1106 : gfc_get_symbol (name, sub_ns, &nsym); \
1107 : nsym->ts.type = stype; \
1108 : nsym->ts.kind = skind; \
1109 : nsym->attr.flavor = FL_PARAMETER; \
1110 : nsym->attr.dummy = 1; \
1111 : nsym->attr.intent = sintent; \
1112 : nsym->declared_at = expr->where; \
1113 : gfc_set_sym_referenced (nsym); \
1114 : *argptr = gfc_get_formal_arglist (); \
1115 : (*argptr)->sym = nsym; \
1116 : argptr = &(*argptr)->next
1117 :
1118 167 : name = xasprintf ("add_data_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1119 167 : ADD_ARG (name, add_data, BT_DERIVED, 0, INTENT_IN);
1120 167 : gfc_commit_symbol (add_data);
1121 167 : free (name);
1122 167 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
1123 : INTENT_IN);
1124 167 : gfc_commit_symbol (caller_image);
1125 :
1126 167 : ADD_ARG ("result", result, BT_LOGICAL, gfc_default_logical_kind, INTENT_OUT);
1127 167 : gfc_commit_symbol (result);
1128 :
1129 : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
1130 167 : base = post_caf_ref_expr->symtree->n.sym;
1131 167 : base->attr.pointer = !base->attr.dimension;
1132 167 : gfc_set_sym_referenced (base);
1133 167 : *argptr = gfc_get_formal_arglist ();
1134 167 : (*argptr)->sym = base;
1135 167 : argptr = &(*argptr)->next;
1136 167 : gfc_commit_symbol (base);
1137 : #undef ADD_ARG
1138 :
1139 : /* Set up code. */
1140 : /* Code: result = post_caf_ref_expr; */
1141 167 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
1142 167 : code->loc = expr->where;
1143 167 : code->expr1 = gfc_lval_expr_from_sym (result);
1144 167 : swp = *expr;
1145 167 : *expr = *swp.value.function.actual->expr;
1146 167 : swp.value.function.actual->expr = nullptr;
1147 167 : code->expr2 = gfc_copy_expr (&swp);
1148 167 : code->expr2->value.function.actual->expr = post_caf_ref_expr;
1149 :
1150 167 : remove_caf_ref (code->expr2->value.function.actual->expr, true);
1151 167 : add_data->ts.u.derived
1152 167 : = create_caf_add_data_parameter_type (post_caf_ref_expr, ns, add_data);
1153 :
1154 167 : cb = gfc_lval_expr_from_sym (extproc);
1155 167 : cb->ts.interface = extproc;
1156 :
1157 167 : if (caf_accessor_prepend)
1158 : {
1159 : gfc_code *c = caf_accessor_prepend;
1160 : /* Find last in chain. */
1161 0 : for (; c->next; c = c->next)
1162 : ;
1163 0 : c->next = sub_ns->code;
1164 0 : sub_ns->code = caf_accessor_prepend;
1165 : }
1166 167 : caf_accessor_prepend = backup_caf_accessor_prepend;
1167 167 : return cb;
1168 : }
1169 :
1170 : static void
1171 167 : rewrite_caf_allocated (gfc_expr **e)
1172 : {
1173 167 : gfc_expr *present_fn_expr, *present_hash_expr, *wrapper;
1174 :
1175 167 : present_fn_expr = create_allocated_callback (*e);
1176 :
1177 167 : present_hash_expr = gfc_get_expr ();
1178 167 : present_hash_expr->expr_type = EXPR_CONSTANT;
1179 167 : present_hash_expr->ts.type = BT_INTEGER;
1180 167 : present_hash_expr->ts.kind = gfc_default_integer_kind;
1181 167 : present_hash_expr->where = (*e)->where;
1182 167 : mpz_init_set_ui (present_hash_expr->value.integer,
1183 167 : gfc_hash_value (present_fn_expr->symtree->n.sym));
1184 167 : wrapper
1185 167 : = gfc_build_intrinsic_call (gfc_current_ns,
1186 : GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE,
1187 : "caf_is_present_on_remote", (*e)->where, 3, *e,
1188 : present_hash_expr, present_fn_expr);
1189 167 : gfc_add_caf_accessor (present_hash_expr, present_fn_expr);
1190 167 : *e = wrapper;
1191 167 : }
1192 :
1193 : static gfc_expr *
1194 500 : create_send_callback (gfc_expr *expr, gfc_expr *rhs)
1195 : {
1196 500 : gfc_namespace *ns;
1197 500 : gfc_symbol *extproc, *proc, *buffer, *base, *send_data, *caller_image;
1198 500 : char tname[GFC_MAX_SYMBOL_LEN + 1];
1199 500 : char *name;
1200 500 : const char *mname;
1201 500 : gfc_expr *cb, *post_caf_ref_expr;
1202 500 : gfc_code *code;
1203 500 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
1204 500 : caf_accessor_prepend = nullptr;
1205 :
1206 : /* Find the top-level namespace. */
1207 659 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
1208 : ;
1209 :
1210 500 : if (expr->expr_type == EXPR_VARIABLE)
1211 500 : strcpy (tname, expr->symtree->name);
1212 : else
1213 0 : strcpy (tname, "dummy");
1214 500 : if (expr->symtree->n.sym->module)
1215 0 : mname = expr->symtree->n.sym->module;
1216 : else
1217 : mname = "main";
1218 500 : name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1219 500 : gfc_get_symbol (name, ns, &extproc);
1220 500 : extproc->declared_at = expr->where;
1221 500 : gfc_set_sym_referenced (extproc);
1222 500 : ++extproc->refs;
1223 500 : gfc_commit_symbol (extproc);
1224 :
1225 : /* Set up namespace. */
1226 500 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
1227 500 : sub_ns->sibling = ns->contained;
1228 500 : ns->contained = sub_ns;
1229 500 : sub_ns->resolved = 1;
1230 : /* Set up procedure symbol. */
1231 500 : gfc_find_symbol (name, sub_ns, 1, &proc);
1232 500 : sub_ns->proc_name = proc;
1233 500 : proc->attr.if_source = IFSRC_DECL;
1234 500 : proc->attr.access = ACCESS_PUBLIC;
1235 500 : gfc_add_subroutine (&proc->attr, name, NULL);
1236 500 : proc->attr.host_assoc = 1;
1237 500 : proc->attr.always_explicit = 1;
1238 500 : ++proc->refs;
1239 500 : proc->declared_at = expr->where;
1240 500 : gfc_commit_symbol (proc);
1241 500 : free (name);
1242 :
1243 500 : split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, true);
1244 :
1245 500 : if (ns->proc_name->attr.flavor == FL_MODULE)
1246 1 : proc->module = ns->proc_name->name;
1247 500 : gfc_set_sym_referenced (proc);
1248 : /* Set up formal arguments. */
1249 500 : gfc_formal_arglist **argptr = &proc->formal;
1250 : #define ADD_ARG(name, nsym, stype, skind, sintent) \
1251 : gfc_get_symbol (name, sub_ns, &nsym); \
1252 : nsym->ts.type = stype; \
1253 : nsym->ts.kind = skind; \
1254 : nsym->attr.flavor = FL_PARAMETER; \
1255 : nsym->attr.dummy = 1; \
1256 : nsym->attr.intent = sintent; \
1257 : nsym->declared_at = expr->where; \
1258 : gfc_set_sym_referenced (nsym); \
1259 : *argptr = gfc_get_formal_arglist (); \
1260 : (*argptr)->sym = nsym; \
1261 : argptr = &(*argptr)->next
1262 :
1263 500 : name = xasprintf ("add_send_data_%s_%s_%d", mname, tname, caf_sym_cnt);
1264 500 : ADD_ARG (name, send_data, BT_DERIVED, 0, INTENT_IN);
1265 500 : gfc_commit_symbol (send_data);
1266 500 : free (name);
1267 :
1268 500 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
1269 : INTENT_IN);
1270 500 : gfc_commit_symbol (caller_image);
1271 :
1272 : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
1273 500 : base = post_caf_ref_expr->symtree->n.sym;
1274 500 : base->attr.intent = INTENT_INOUT;
1275 500 : gfc_set_sym_referenced (base);
1276 500 : gfc_commit_symbol (base);
1277 500 : *argptr = gfc_get_formal_arglist ();
1278 500 : (*argptr)->sym = base;
1279 500 : argptr = &(*argptr)->next;
1280 500 : gfc_commit_symbol (base);
1281 :
1282 500 : ADD_ARG ("buffer", buffer, rhs->ts.type, rhs->ts.kind, INTENT_IN);
1283 500 : buffer->ts = rhs->ts;
1284 500 : if (rhs->rank)
1285 : {
1286 200 : buffer->as = gfc_get_array_spec ();
1287 200 : buffer->as->rank = rhs->rank;
1288 200 : buffer->as->type = AS_DEFERRED;
1289 200 : buffer->attr.allocatable = 1;
1290 200 : buffer->attr.dimension = 1;
1291 : }
1292 500 : if (buffer->ts.type == BT_CHARACTER)
1293 : {
1294 116 : buffer->ts.u.cl = gfc_get_charlen ();
1295 116 : *buffer->ts.u.cl = *rhs->ts.u.cl;
1296 116 : buffer->ts.deferred = 1;
1297 116 : buffer->ts.u.cl->length = gfc_copy_expr (rhs->ts.u.cl->length);
1298 : }
1299 500 : gfc_commit_symbol (buffer);
1300 : #undef ADD_ARG
1301 :
1302 : /* Set up code. */
1303 : /* Code: base = buffer; */
1304 500 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
1305 500 : code->loc = expr->where;
1306 500 : code->expr1 = post_caf_ref_expr;
1307 500 : if (code->expr1->ts.type == BT_CHARACTER
1308 116 : && code->expr1->ts.kind != buffer->ts.kind)
1309 : {
1310 56 : bool converted;
1311 56 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1312 56 : converted = gfc_convert_chartype (code->expr2, &code->expr1->ts);
1313 56 : gcc_assert (converted);
1314 : }
1315 444 : else if (code->expr1->ts.type != buffer->ts.type)
1316 : {
1317 126 : bool converted;
1318 126 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1319 252 : converted = gfc_convert_type_warn (code->expr2, &code->expr1->ts, 0, 0,
1320 126 : buffer->attr.dimension);
1321 126 : gcc_assert (converted);
1322 : }
1323 : else
1324 318 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1325 500 : remove_caf_ref (post_caf_ref_expr);
1326 500 : send_data->ts.u.derived
1327 500 : = create_caf_add_data_parameter_type (code->expr1, ns, send_data);
1328 :
1329 500 : cb = gfc_lval_expr_from_sym (extproc);
1330 500 : cb->ts.interface = extproc;
1331 :
1332 500 : if (caf_accessor_prepend)
1333 : {
1334 : gfc_code *c = caf_accessor_prepend;
1335 : /* Find last in chain. */
1336 0 : for (; c->next; c = c->next)
1337 : ;
1338 0 : c->next = sub_ns->code;
1339 0 : sub_ns->code = caf_accessor_prepend;
1340 : }
1341 500 : caf_accessor_prepend = backup_caf_accessor_prepend;
1342 500 : return cb;
1343 : }
1344 :
1345 : static void
1346 512 : rewrite_caf_send (gfc_code *c)
1347 : {
1348 512 : gfc_expr *send_to_remote_expr, *send_to_remote_hash_expr, *lhs, *rhs;
1349 512 : gfc_actual_arglist *arg = c->ext.actual;
1350 :
1351 512 : lhs = arg->expr;
1352 512 : arg = arg->next;
1353 512 : rhs = arg->expr;
1354 : /* Detect an already rewritten caf_send. */
1355 512 : if (arg->next && arg->next->expr->expr_type == EXPR_CONSTANT
1356 12 : && arg->next->next && arg->next->next->expr->expr_type == EXPR_VARIABLE)
1357 : return;
1358 :
1359 500 : send_to_remote_expr = create_send_callback (lhs, rhs);
1360 500 : send_to_remote_hash_expr = gfc_get_expr ();
1361 500 : send_to_remote_hash_expr->expr_type = EXPR_CONSTANT;
1362 500 : send_to_remote_hash_expr->ts.type = BT_INTEGER;
1363 500 : send_to_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1364 500 : send_to_remote_hash_expr->where = lhs->where;
1365 500 : mpz_init_set_ui (send_to_remote_hash_expr->value.integer,
1366 500 : gfc_hash_value (send_to_remote_expr->symtree->n.sym));
1367 500 : arg->next = gfc_get_actual_arglist ();
1368 500 : arg = arg->next;
1369 500 : arg->expr = send_to_remote_hash_expr;
1370 500 : arg->next = gfc_get_actual_arglist ();
1371 500 : arg = arg->next;
1372 500 : arg->expr = send_to_remote_expr;
1373 500 : gfc_add_caf_accessor (send_to_remote_hash_expr, send_to_remote_expr);
1374 :
1375 500 : if (gfc_is_coindexed (rhs))
1376 : {
1377 140 : gfc_expr *get_from_remote_expr, *get_from_remote_hash_expr;
1378 :
1379 140 : c->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SENDGET);
1380 140 : get_from_remote_expr = create_get_callback (rhs);
1381 140 : get_from_remote_hash_expr = gfc_get_expr ();
1382 140 : get_from_remote_hash_expr->expr_type = EXPR_CONSTANT;
1383 140 : get_from_remote_hash_expr->ts.type = BT_INTEGER;
1384 140 : get_from_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1385 140 : get_from_remote_hash_expr->where = rhs->where;
1386 140 : mpz_init_set_ui (get_from_remote_hash_expr->value.integer,
1387 140 : gfc_hash_value (get_from_remote_expr->symtree->n.sym));
1388 140 : arg->next = gfc_get_actual_arglist ();
1389 140 : arg = arg->next;
1390 140 : arg->expr = get_from_remote_hash_expr;
1391 140 : arg->next = gfc_get_actual_arglist ();
1392 140 : arg = arg->next;
1393 140 : arg->expr = get_from_remote_expr;
1394 140 : gfc_add_caf_accessor (get_from_remote_hash_expr, get_from_remote_expr);
1395 : }
1396 : }
1397 :
1398 : static int
1399 69756 : coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
1400 : void *data ATTRIBUTE_UNUSED)
1401 : {
1402 69756 : *walk_subtrees = 1;
1403 :
1404 69756 : switch ((*e)->expr_type)
1405 : {
1406 26429 : case EXPR_VARIABLE:
1407 26429 : if (!caf_on_lhs && gfc_is_coindexed (*e))
1408 : {
1409 922 : add_caf_get_from_remote (*e);
1410 922 : *walk_subtrees = 0;
1411 : }
1412 : /* Clear the flag to rewrite caf_gets in sub expressions of the lhs. */
1413 26429 : caf_on_lhs = false;
1414 26429 : break;
1415 7952 : case EXPR_FUNCTION:
1416 7952 : if ((*e)->value.function.isym)
1417 7814 : switch ((*e)->value.function.isym->id)
1418 : {
1419 632 : case GFC_ISYM_ALLOCATED:
1420 632 : if ((*e)->value.function.actual->expr
1421 632 : && (gfc_is_coarray ((*e)->value.function.actual->expr)
1422 537 : || gfc_is_coindexed ((*e)->value.function.actual->expr)))
1423 : {
1424 167 : rewrite_caf_allocated (e);
1425 167 : *walk_subtrees = 0;
1426 : }
1427 : break;
1428 12 : case GFC_ISYM_CAF_GET:
1429 12 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
1430 12 : *walk_subtrees = 0;
1431 12 : break;
1432 : default:
1433 : break;
1434 : }
1435 : default:
1436 : break;
1437 : }
1438 :
1439 69756 : return 0;
1440 : }
1441 :
1442 : static int
1443 18727 : coindexed_code_callback (gfc_code **c, int *walk_subtrees,
1444 : void *data ATTRIBUTE_UNUSED)
1445 : {
1446 18727 : int ws = 1;
1447 18727 : current_code = c;
1448 :
1449 18727 : switch ((*c)->op)
1450 : {
1451 6671 : case EXEC_ASSIGN:
1452 6671 : case EXEC_POINTER_ASSIGN:
1453 6671 : caf_on_lhs = true;
1454 6671 : coindexed_expr_callback (&((*c)->expr1), &ws, NULL);
1455 6671 : caf_on_lhs = false;
1456 6671 : ws = 1;
1457 6671 : coindexed_expr_callback (&((*c)->expr2), &ws, NULL);
1458 6671 : *walk_subtrees = ws;
1459 6671 : break;
1460 127 : case EXEC_LOCK:
1461 127 : case EXEC_UNLOCK:
1462 127 : case EXEC_EVENT_POST:
1463 127 : case EXEC_EVENT_WAIT:
1464 127 : *walk_subtrees = 0;
1465 127 : break;
1466 1081 : case EXEC_CALL:
1467 1081 : *walk_subtrees = 1;
1468 1081 : if ((*c)->resolved_isym)
1469 854 : switch ((*c)->resolved_isym->id)
1470 : {
1471 512 : case GFC_ISYM_CAF_SEND:
1472 512 : rewrite_caf_send (*c);
1473 512 : *walk_subtrees = 0;
1474 512 : break;
1475 6 : case GFC_ISYM_CAF_SENDGET:
1476 : /* Seldomly this routine is called again with the symbol already
1477 : changed to CAF_SENDGET. Do not process the subtree again. The
1478 : rewrite has already been done by rewrite_caf_send (). */
1479 6 : *walk_subtrees = 0;
1480 6 : break;
1481 179 : case GFC_ISYM_ATOMIC_ADD:
1482 179 : case GFC_ISYM_ATOMIC_AND:
1483 179 : case GFC_ISYM_ATOMIC_CAS:
1484 179 : case GFC_ISYM_ATOMIC_DEF:
1485 179 : case GFC_ISYM_ATOMIC_FETCH_ADD:
1486 179 : case GFC_ISYM_ATOMIC_FETCH_AND:
1487 179 : case GFC_ISYM_ATOMIC_FETCH_OR:
1488 179 : case GFC_ISYM_ATOMIC_FETCH_XOR:
1489 179 : case GFC_ISYM_ATOMIC_OR:
1490 179 : case GFC_ISYM_ATOMIC_REF:
1491 179 : case GFC_ISYM_ATOMIC_XOR:
1492 179 : *walk_subtrees = 0;
1493 179 : break;
1494 : default:
1495 : break;
1496 : }
1497 : break;
1498 10848 : default:
1499 10848 : *walk_subtrees = 1;
1500 10848 : break;
1501 : }
1502 18727 : return 0;
1503 : }
1504 :
1505 : void
1506 1978 : gfc_coarray_rewrite (gfc_namespace *ns)
1507 : {
1508 1978 : gfc_namespace *saved_ns = gfc_current_ns;
1509 1978 : gfc_current_ns = ns;
1510 :
1511 1978 : if (flag_coarray == GFC_FCOARRAY_LIB)
1512 : {
1513 1978 : gfc_code_walker (&ns->code, coindexed_code_callback,
1514 : coindexed_expr_callback, NULL);
1515 :
1516 3438 : for (gfc_namespace *cns = ns->contained; cns; cns = cns->sibling)
1517 1460 : gfc_coarray_rewrite (cns);
1518 : }
1519 :
1520 1978 : gfc_current_ns = saved_ns;
1521 1978 : }
|
