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 1487 : move_coarray_ref (gfc_ref **from, gfc_expr *expr)
247 : {
248 1487 : int i;
249 1487 : gfc_ref *to = expr->ref;
250 1532 : for (; to && to->next; to = to->next)
251 : ;
252 :
253 1487 : if (!to)
254 : {
255 1442 : expr->ref = gfc_get_ref ();
256 1442 : to = expr->ref;
257 1442 : to->type = REF_ARRAY;
258 : }
259 1487 : gcc_assert (to->type == REF_ARRAY);
260 1487 : to->u.ar.as = gfc_copy_array_spec ((*from)->u.ar.as);
261 1487 : to->u.ar.codimen = (*from)->u.ar.codimen;
262 1487 : to->u.ar.dimen = (*from)->u.ar.dimen;
263 1487 : to->u.ar.type = AR_FULL;
264 1487 : to->u.ar.stat = (*from)->u.ar.stat;
265 1487 : (*from)->u.ar.stat = nullptr;
266 1487 : to->u.ar.team = (*from)->u.ar.team;
267 1487 : (*from)->u.ar.team = nullptr;
268 1487 : to->u.ar.team_type = (*from)->u.ar.team_type;
269 1487 : (*from)->u.ar.team_type = TEAM_UNSET;
270 2033 : for (i = 0; i < to->u.ar.dimen; ++i)
271 : {
272 546 : to->u.ar.start[i] = nullptr;
273 546 : to->u.ar.end[i] = nullptr;
274 546 : to->u.ar.stride[i] = nullptr;
275 : }
276 3040 : for (i = (*from)->u.ar.dimen; i < (*from)->u.ar.dimen + (*from)->u.ar.codimen;
277 : ++i)
278 : {
279 1553 : to->u.ar.dimen_type[i] = (*from)->u.ar.dimen_type[i];
280 1553 : to->u.ar.start[i] = (*from)->u.ar.start[i];
281 1553 : (*from)->u.ar.start[i] = nullptr;
282 1553 : to->u.ar.end[i] = (*from)->u.ar.end[i];
283 1553 : (*from)->u.ar.end[i] = nullptr;
284 1553 : to->u.ar.stride[i] = (*from)->u.ar.stride[i];
285 1553 : (*from)->u.ar.stride[i] = nullptr;
286 : }
287 1487 : (*from)->u.ar.codimen = 0;
288 1487 : 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 1487 : }
296 :
297 : static void
298 2974 : fixup_comp_refs (gfc_expr *expr)
299 : {
300 2974 : 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 2974 : ? expr->symtree->n.sym->ts.u.derived
304 1266 : : (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 1487 : split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
350 : gfc_expr **post_caf_ref_expr, bool for_send)
351 : {
352 1487 : gfc_ref *caf_ref = NULL;
353 1487 : gfc_symtree *st;
354 1487 : gfc_symbol *base;
355 1487 : gfc_typespec *caf_ts;
356 1487 : bool created;
357 :
358 1487 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
359 1487 : caf_ts = &expr->symtree->n.sym->ts;
360 1487 : if (!(expr->symtree->n.sym->ts.type == BT_CLASS
361 1487 : ? CLASS_DATA (expr->symtree->n.sym)->attr.codimension
362 1450 : : 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 1487 : created = !gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns, &st,
377 : false);
378 1487 : gcc_assert (created);
379 1487 : st->n.sym->attr.flavor = FL_PARAMETER;
380 1487 : st->n.sym->attr.dummy = 1;
381 1487 : st->n.sym->attr.intent = INTENT_IN;
382 1487 : st->n.sym->ts = *caf_ts;
383 1487 : st->n.sym->declared_at = expr->where;
384 :
385 1487 : *post_caf_ref_expr = gfc_get_variable_expr (st);
386 1487 : (*post_caf_ref_expr)->where = expr->where;
387 1487 : base = (*post_caf_ref_expr)->symtree->n.sym;
388 :
389 1487 : if (!caf_ref)
390 : {
391 1442 : (*post_caf_ref_expr)->ref = gfc_get_ref ();
392 1442 : *(*post_caf_ref_expr)->ref = *expr->ref;
393 1442 : expr->ref = nullptr;
394 1442 : move_coarray_ref (&(*post_caf_ref_expr)->ref, expr);
395 1442 : fixup_comp_refs (expr);
396 :
397 1442 : if (expr->symtree->n.sym->attr.dimension)
398 : {
399 382 : base->as = gfc_copy_array_spec (expr->symtree->n.sym->as);
400 382 : base->as->corank = 0;
401 382 : base->attr.dimension = 1;
402 382 : base->attr.allocatable = expr->symtree->n.sym->attr.allocatable;
403 382 : base->attr.pointer = expr->symtree->n.sym->attr.pointer
404 382 : || 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 1487 : (*post_caf_ref_expr)->ts = expr->ts;
425 1487 : 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 1274 : else if (base->ts.type == BT_DERIVED)
433 820 : remove_coarray_from_derived_type (base, ns);
434 454 : else if (base->ts.type == BT_CLASS)
435 43 : convert_coarray_class_to_derived_type (base, ns);
436 :
437 1487 : memset (&(*post_caf_ref_expr)->ts, 0, sizeof (gfc_typespec));
438 1487 : gfc_resolve_expr (*post_caf_ref_expr);
439 1487 : (*post_caf_ref_expr)->corank = 0;
440 1487 : gfc_expression_rank (*post_caf_ref_expr);
441 1487 : if (for_send)
442 667 : gfc_expression_rank (expr);
443 : else
444 820 : expr->rank = (*post_caf_ref_expr)->rank;
445 1487 : }
446 :
447 : static void add_caf_get_from_remote (gfc_expr *e);
448 :
449 : static gfc_component *
450 376 : find_comp (gfc_symbol *type, gfc_expr *e, int *cnt, const bool is_var)
451 : {
452 376 : char *temp_name = nullptr;
453 376 : 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 376 : if (is_var)
461 : {
462 376 : ++(*cnt);
463 376 : free (temp_name);
464 376 : temp_name = xasprintf ("caf_temp_%s_%d", e->symtree->name, *cnt);
465 1654 : while (comp && strcmp (comp->name, temp_name) != 0)
466 902 : comp = comp->next;
467 376 : if (!comp)
468 : {
469 376 : const bool added = gfc_add_component (type, temp_name, &comp);
470 376 : 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 0 : do
479 : {
480 0 : ++(*cnt);
481 0 : free (temp_name);
482 0 : temp_name = xasprintf ("caf_temp_%s_%d", e->symtree->name, *cnt);
483 :
484 0 : while (comp && (r = strcmp (comp->name, temp_name)) <= 0)
485 0 : comp = comp->next;
486 : }
487 0 : while (comp && r <= 0);
488 0 : {
489 0 : const bool added = gfc_add_component (type, temp_name, &comp);
490 0 : gcc_assert (added);
491 : }
492 : }
493 :
494 376 : comp->loc = e->where;
495 376 : comp->ts = e->ts;
496 376 : free (temp_name);
497 :
498 376 : return comp;
499 : }
500 :
501 : static void
502 376 : check_add_new_comp_handle_array (gfc_expr *e, gfc_symbol *type,
503 : gfc_symbol *add_data)
504 : {
505 376 : gfc_component *comp;
506 376 : static int cnt = -1;
507 376 : gfc_symtree *caller_image;
508 376 : gfc_code *pre_code = caf_accessor_prepend;
509 376 : bool static_array_or_scalar = true;
510 376 : symbol_attribute e_attr = gfc_expr_attr (e);
511 :
512 376 : 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 752 : for (; pre_code && pre_code->next; pre_code = pre_code->next)
517 : ;
518 :
519 376 : comp = find_comp (type, e, &cnt,
520 376 : e->symtree->n.sym->attr.flavor == FL_VARIABLE
521 376 : || e->symtree->n.sym->attr.flavor == FL_PARAMETER);
522 :
523 376 : if (e->expr_type == EXPR_FUNCTION
524 376 : || (e->expr_type == EXPR_VARIABLE && e_attr.dimension
525 26 : && e_attr.allocatable))
526 : {
527 2 : gfc_code *code;
528 2 : gfc_symtree *st;
529 2 : const bool created
530 2 : = !gfc_get_sym_tree (comp->name, gfc_current_ns, &st, false, &e->where);
531 2 : gcc_assert (created);
532 :
533 2 : st->n.sym->ts = e->ts;
534 2 : gfc_set_sym_referenced (st->n.sym);
535 2 : code = gfc_get_code (EXEC_ASSIGN);
536 2 : code->loc = e->where;
537 2 : code->expr1 = gfc_get_variable_expr (st);
538 2 : code->expr2 = XCNEW (gfc_expr);
539 2 : *(code->expr2) = *e;
540 2 : code->next = *current_code;
541 2 : *current_code = code;
542 :
543 2 : 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 2 : gfc_expression_rank (code->expr1);
563 2 : comp->initializer = gfc_get_variable_expr (st);
564 2 : gfc_commit_symbol (st->n.sym);
565 2 : }
566 : else
567 : {
568 374 : comp->initializer = gfc_copy_expr (e);
569 374 : 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 376 : comp->initializer->where = e->where;
576 376 : comp->attr.access = ACCESS_PRIVATE;
577 376 : memset (e, 0, sizeof (gfc_expr));
578 376 : e->ts = comp->initializer->ts;
579 376 : e->expr_type = EXPR_VARIABLE;
580 376 : e->where = comp->initializer->where;
581 :
582 376 : 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 350 : e->ref = gfc_get_ref ();
649 350 : e->ref->type = REF_ARRAY;
650 350 : e->ref->u.ar.as = gfc_copy_array_spec (add_data->as);
651 350 : e->ref->u.ar.codimen = 1;
652 350 : e->ref->u.ar.dimen_type[0] = DIMEN_THIS_IMAGE;
653 : }
654 :
655 376 : if (static_array_or_scalar)
656 : {
657 374 : const bool created
658 374 : = gfc_find_component (add_data->ts.u.derived, comp->name, false, true,
659 374 : &e->ref);
660 374 : gcc_assert (created);
661 374 : e->symtree = gfc_find_symtree (add_data->ns->sym_root, add_data->name);
662 374 : gcc_assert (e->symtree);
663 374 : if (IS_CLASS_ARRAY (e->ref->u.c.component)
664 374 : || 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 374 : gfc_expression_rank (e);
675 : }
676 376 : }
677 :
678 : static void
679 5064 : check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *add_data)
680 : {
681 5132 : if (e)
682 : {
683 1216 : switch (e->expr_type)
684 : {
685 : case EXPR_CONSTANT:
686 : case EXPR_NULL:
687 : break;
688 70 : case EXPR_OP:
689 70 : check_add_new_component (type, e->value.op.op1, add_data);
690 70 : 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 : if (!e->symtree->n.sym->attr.pure
700 4 : && !e->symtree->n.sym->attr.elemental
701 4 : && !(e->value.function.isym
702 4 : && (e->value.function.isym->pure
703 0 : || e->value.function.isym->elemental)))
704 : /* Treat non-pure/non-elemental functions. */
705 0 : check_add_new_comp_handle_array (e, type, add_data);
706 : else
707 252 : for (gfc_actual_arglist *actual = e->value.function.actual; actual;
708 128 : actual = actual->next)
709 128 : check_add_new_component (type, actual->expr, add_data);
710 : break;
711 376 : case EXPR_VARIABLE:
712 376 : check_add_new_comp_handle_array (e, type, add_data);
713 376 : break;
714 0 : case EXPR_ARRAY:
715 0 : case EXPR_PPC:
716 0 : case EXPR_STRUCTURE:
717 0 : case EXPR_SUBSTRING:
718 0 : gcc_unreachable ();
719 : default:;
720 : }
721 : }
722 5064 : }
723 :
724 : static gfc_symbol *
725 1487 : create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns,
726 : gfc_symbol *add_data)
727 : {
728 1487 : static int type_cnt = 0;
729 1487 : char tname[GFC_MAX_SYMBOL_LEN + 1];
730 1487 : char *name;
731 1487 : gfc_symbol *type;
732 :
733 1487 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
734 :
735 1487 : strcpy (tname, expr->symtree->name);
736 1487 : name = xasprintf ("@_caf_add_data_t_%s_%d", tname, ++type_cnt);
737 1487 : gfc_get_symbol (name, ns, &type);
738 :
739 1487 : type->attr.flavor = FL_DERIVED;
740 1487 : add_data->ts.u.derived = type;
741 1487 : add_data->attr.codimension = 1;
742 1487 : add_data->as = gfc_get_array_spec ();
743 1487 : add_data->as->corank = 1;
744 1487 : add_data->as->type = AS_EXPLICIT;
745 1487 : add_data->as->cotype = AS_DEFERRED;
746 1487 : add_data->as->lower[0]
747 1487 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
748 : &expr->where);
749 1487 : mpz_set_si (add_data->as->lower[0]->value.integer, 1);
750 :
751 3747 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
752 : {
753 2260 : if (ref->type == REF_ARRAY)
754 : {
755 : gfc_array_ref *ar = &ref->u.ar;
756 2714 : for (int i = 0; i < ar->dimen; ++i)
757 : {
758 1622 : check_add_new_component (type, ar->start[i], add_data);
759 1622 : check_add_new_component (type, ar->end[i], add_data);
760 1622 : check_add_new_component (type, ar->stride[i], add_data);
761 : }
762 : }
763 : }
764 :
765 1487 : type->declared_at = expr->where;
766 1487 : gfc_set_sym_referenced (type);
767 1487 : gfc_commit_symbol (type);
768 1487 : free (name);
769 1487 : return type;
770 : }
771 :
772 : static void
773 1487 : remove_caf_ref (gfc_expr *expr, const bool conv_to_this_image_cafref = false)
774 : {
775 1487 : gfc_ref *ref = expr->ref;
776 3253 : while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
777 : {
778 1766 : ref = ref->next;
779 : }
780 1487 : if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
781 : {
782 412 : if (ref->u.ar.dimen != 0)
783 : {
784 412 : ref->u.ar.codimen = 0;
785 412 : ref = ref->next;
786 : }
787 : else
788 : {
789 0 : if (conv_to_this_image_cafref)
790 : {
791 0 : for (int i = ref->u.ar.dimen;
792 0 : i < ref->u.ar.dimen + ref->u.ar.codimen; ++i)
793 0 : ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
794 : }
795 : else
796 : {
797 0 : expr->ref = ref->next;
798 0 : ref->next = NULL;
799 0 : gfc_free_ref_list (ref);
800 0 : ref = expr->ref;
801 : }
802 : }
803 : }
804 1487 : fixup_comp_refs (expr);
805 1487 : }
806 :
807 : static gfc_expr *
808 820 : create_get_callback (gfc_expr *expr)
809 : {
810 820 : gfc_namespace *ns;
811 820 : gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data,
812 : *old_buffer_data, *caller_image;
813 820 : char tname[GFC_MAX_SYMBOL_LEN + 1];
814 820 : char *name;
815 820 : const char *mname;
816 820 : gfc_expr *cb, *post_caf_ref_expr;
817 820 : gfc_code *code;
818 820 : int expr_rank = expr->rank;
819 820 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
820 820 : caf_accessor_prepend = nullptr;
821 :
822 : /* Find the top-level namespace. */
823 974 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
824 : ;
825 :
826 820 : if (expr->expr_type == EXPR_VARIABLE)
827 820 : strcpy (tname, expr->symtree->name);
828 : else
829 0 : strcpy (tname, "dummy");
830 820 : if (expr->symtree->n.sym->module)
831 5 : mname = expr->symtree->n.sym->module;
832 : else
833 : mname = "main";
834 820 : name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
835 820 : gfc_get_symbol (name, ns, &extproc);
836 820 : extproc->declared_at = expr->where;
837 820 : gfc_set_sym_referenced (extproc);
838 820 : ++extproc->refs;
839 820 : gfc_commit_symbol (extproc);
840 :
841 : /* Set up namespace. */
842 820 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
843 820 : sub_ns->sibling = ns->contained;
844 820 : ns->contained = sub_ns;
845 820 : sub_ns->resolved = 1;
846 : /* Set up procedure symbol. */
847 820 : gfc_find_symbol (name, sub_ns, 1, &proc);
848 820 : sub_ns->proc_name = proc;
849 820 : proc->attr.if_source = IFSRC_DECL;
850 820 : proc->attr.access = ACCESS_PUBLIC;
851 820 : gfc_add_subroutine (&proc->attr, name, NULL);
852 820 : proc->attr.host_assoc = 1;
853 820 : proc->attr.always_explicit = 1;
854 820 : ++proc->refs;
855 820 : proc->declared_at = expr->where;
856 820 : gfc_commit_symbol (proc);
857 820 : free (name);
858 :
859 820 : split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, false);
860 :
861 820 : if (ns->proc_name->attr.flavor == FL_MODULE)
862 2 : proc->module = ns->proc_name->name;
863 820 : gfc_set_sym_referenced (proc);
864 : /* Set up formal arguments. */
865 820 : gfc_formal_arglist **argptr = &proc->formal;
866 : #define ADD_ARG(name, nsym, stype, skind, sintent) \
867 : gfc_get_symbol (name, sub_ns, &nsym); \
868 : nsym->ts.type = stype; \
869 : nsym->ts.kind = skind; \
870 : nsym->attr.flavor = FL_PARAMETER; \
871 : nsym->attr.dummy = 1; \
872 : nsym->attr.intent = sintent; \
873 : nsym->declared_at = expr->where; \
874 : gfc_set_sym_referenced (nsym); \
875 : *argptr = gfc_get_formal_arglist (); \
876 : (*argptr)->sym = nsym; \
877 : argptr = &(*argptr)->next
878 :
879 820 : name = xasprintf ("add_data_%s_%s_%d", mname, tname, caf_sym_cnt);
880 820 : ADD_ARG (name, get_data, BT_DERIVED, 0, INTENT_IN);
881 820 : gfc_commit_symbol (get_data);
882 820 : free (name);
883 :
884 820 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
885 : INTENT_IN);
886 820 : gfc_commit_symbol (caller_image);
887 :
888 820 : ADD_ARG ("buffer", buffer, expr->ts.type, expr->ts.kind, INTENT_INOUT);
889 820 : buffer->ts = expr->ts;
890 820 : if (expr_rank)
891 : {
892 444 : buffer->as = gfc_get_array_spec ();
893 444 : buffer->as->rank = expr_rank;
894 444 : if (expr->shape)
895 : {
896 254 : buffer->as->type = AS_EXPLICIT;
897 624 : for (int d = 0; d < expr_rank; ++d)
898 : {
899 370 : buffer->as->lower[d]
900 370 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
901 : &gfc_current_locus);
902 370 : gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1);
903 370 : buffer->as->upper[d]
904 370 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
905 : &gfc_current_locus);
906 370 : gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer,
907 370 : gfc_mpz_get_hwi (expr->shape[d]));
908 : }
909 254 : buffer->attr.allocatable = 1;
910 : }
911 : else
912 : {
913 190 : buffer->as->type = AS_DEFERRED;
914 190 : buffer->attr.allocatable = 1;
915 : }
916 444 : buffer->attr.dimension = 1;
917 : }
918 : else
919 376 : buffer->attr.pointer = 1;
920 820 : if (buffer->ts.type == BT_CHARACTER)
921 : {
922 97 : buffer->ts.u.cl = gfc_get_charlen ();
923 97 : *buffer->ts.u.cl = *expr->ts.u.cl;
924 97 : buffer->ts.u.cl->length = gfc_copy_expr (expr->ts.u.cl->length);
925 : }
926 820 : gfc_commit_symbol (buffer);
927 :
928 820 : ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, gfc_default_logical_kind,
929 : INTENT_OUT);
930 820 : gfc_commit_symbol (free_buffer);
931 :
932 : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
933 820 : base = post_caf_ref_expr->symtree->n.sym;
934 820 : gfc_set_sym_referenced (base);
935 820 : gfc_commit_symbol (base);
936 820 : *argptr = gfc_get_formal_arglist ();
937 820 : (*argptr)->sym = base;
938 820 : argptr = &(*argptr)->next;
939 820 : gfc_commit_symbol (base);
940 : #undef ADD_ARG
941 :
942 : /* Set up code. */
943 820 : if (expr->rank != 0)
944 : {
945 : /* Code: old_buffer_ptr = C_LOC (buffer); */
946 444 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
947 444 : gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data);
948 444 : old_buffer_data->ts.type = BT_VOID;
949 444 : old_buffer_data->attr.flavor = FL_VARIABLE;
950 444 : old_buffer_data->declared_at = expr->where;
951 444 : gfc_set_sym_referenced (old_buffer_data);
952 444 : gfc_commit_symbol (old_buffer_data);
953 444 : code->loc = expr->where;
954 444 : code->expr1 = gfc_lval_expr_from_sym (old_buffer_data);
955 444 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
956 : gfc_current_locus, 1,
957 : gfc_lval_expr_from_sym (buffer));
958 444 : code->next = gfc_get_code (EXEC_ASSIGN);
959 444 : code = code->next;
960 : }
961 : else
962 376 : code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN);
963 :
964 : /* Code: buffer = expr; */
965 820 : code->loc = expr->where;
966 820 : code->expr1 = gfc_lval_expr_from_sym (buffer);
967 820 : code->expr2 = post_caf_ref_expr;
968 820 : remove_caf_ref (post_caf_ref_expr);
969 820 : get_data->ts.u.derived
970 820 : = create_caf_add_data_parameter_type (code->expr2, ns, get_data);
971 820 : if (code->expr2->rank == 0 && code->expr2->ts.type != BT_CHARACTER)
972 311 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
973 : gfc_current_locus, 1, code->expr2);
974 :
975 : /* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or
976 : * *free_buffer = 0; for rank == 0. */
977 820 : code->next = gfc_get_code (EXEC_ASSIGN);
978 820 : code = code->next;
979 820 : code->loc = expr->where;
980 820 : code->expr1 = gfc_lval_expr_from_sym (free_buffer);
981 820 : if (expr->rank != 0)
982 : {
983 444 : code->expr2 = gfc_get_operator_expr (
984 : &gfc_current_locus, INTRINSIC_NE_OS,
985 : gfc_lval_expr_from_sym (old_buffer_data),
986 : gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
987 : gfc_current_locus, 1,
988 : gfc_lval_expr_from_sym (buffer)));
989 444 : code->expr2->ts.type = BT_LOGICAL;
990 444 : code->expr2->ts.kind = gfc_default_logical_kind;
991 : }
992 : else
993 : {
994 376 : code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
995 : &gfc_current_locus, false);
996 : }
997 :
998 820 : cb = gfc_lval_expr_from_sym (extproc);
999 820 : cb->ts.interface = extproc;
1000 :
1001 820 : if (caf_accessor_prepend)
1002 : {
1003 : gfc_code *c = caf_accessor_prepend;
1004 : /* Find last in chain. */
1005 2 : for (; c->next; c = c->next)
1006 : ;
1007 2 : c->next = sub_ns->code;
1008 2 : sub_ns->code = caf_accessor_prepend;
1009 : }
1010 820 : caf_accessor_prepend = backup_caf_accessor_prepend;
1011 820 : return cb;
1012 : }
1013 :
1014 : void
1015 923 : add_caf_get_from_remote (gfc_expr *e)
1016 : {
1017 923 : gfc_expr *wrapper, *tmp_expr, *get_from_remote_expr,
1018 : *get_from_remote_hash_expr;
1019 923 : gfc_ref *ref;
1020 923 : int n;
1021 :
1022 979 : for (ref = e->ref; ref; ref = ref->next)
1023 979 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
1024 : break;
1025 923 : if (ref == NULL)
1026 : return;
1027 :
1028 1662 : for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
1029 982 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1030 : return;
1031 :
1032 680 : tmp_expr = XCNEW (gfc_expr);
1033 680 : *tmp_expr = *e;
1034 680 : get_from_remote_expr = create_get_callback (tmp_expr);
1035 680 : get_from_remote_hash_expr = gfc_get_expr ();
1036 680 : get_from_remote_hash_expr->expr_type = EXPR_CONSTANT;
1037 680 : get_from_remote_hash_expr->ts.type = BT_INTEGER;
1038 680 : get_from_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1039 680 : get_from_remote_hash_expr->where = tmp_expr->where;
1040 680 : mpz_init_set_ui (get_from_remote_hash_expr->value.integer,
1041 680 : gfc_hash_value (get_from_remote_expr->symtree->n.sym));
1042 680 : wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
1043 : "caf_get", tmp_expr->where, 3, tmp_expr,
1044 : get_from_remote_hash_expr,
1045 : get_from_remote_expr);
1046 680 : gfc_add_caf_accessor (get_from_remote_hash_expr, get_from_remote_expr);
1047 680 : wrapper->ts = e->ts;
1048 680 : wrapper->rank = e->rank;
1049 680 : wrapper->corank = e->corank;
1050 680 : if (e->rank)
1051 386 : wrapper->shape = gfc_copy_shape (e->shape, e->rank);
1052 680 : *e = *wrapper;
1053 680 : free (wrapper);
1054 : }
1055 :
1056 : static gfc_expr *
1057 167 : create_allocated_callback (gfc_expr *expr)
1058 : {
1059 167 : gfc_namespace *ns;
1060 167 : gfc_symbol *extproc, *proc, *result, *base, *add_data, *caller_image;
1061 167 : char tname[GFC_MAX_SYMBOL_LEN + 1];
1062 167 : char *name;
1063 167 : const char *mname;
1064 167 : gfc_expr *cb, *post_caf_ref_expr;
1065 167 : gfc_code *code;
1066 167 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
1067 167 : caf_accessor_prepend = nullptr;
1068 167 : gfc_expr swp;
1069 :
1070 : /* Find the top-level namespace. */
1071 175 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
1072 : ;
1073 :
1074 167 : if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
1075 167 : strcpy (tname, expr->value.function.actual->expr->symtree->name);
1076 : else
1077 0 : strcpy (tname, "dummy");
1078 167 : if (expr->value.function.actual->expr->symtree->n.sym->module)
1079 0 : mname = expr->value.function.actual->expr->symtree->n.sym->module;
1080 : else
1081 : mname = "main";
1082 167 : name = xasprintf ("_caf_present_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1083 167 : gfc_get_symbol (name, ns, &extproc);
1084 167 : extproc->declared_at = expr->where;
1085 167 : gfc_set_sym_referenced (extproc);
1086 167 : ++extproc->refs;
1087 167 : gfc_commit_symbol (extproc);
1088 :
1089 : /* Set up namespace. */
1090 167 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
1091 167 : sub_ns->sibling = ns->contained;
1092 167 : ns->contained = sub_ns;
1093 167 : sub_ns->resolved = 1;
1094 : /* Set up procedure symbol. */
1095 167 : gfc_find_symbol (name, sub_ns, 1, &proc);
1096 167 : sub_ns->proc_name = proc;
1097 167 : proc->attr.if_source = IFSRC_DECL;
1098 167 : proc->attr.access = ACCESS_PUBLIC;
1099 167 : gfc_add_subroutine (&proc->attr, name, NULL);
1100 167 : proc->attr.host_assoc = 1;
1101 167 : proc->attr.always_explicit = 1;
1102 167 : proc->declared_at = expr->where;
1103 167 : ++proc->refs;
1104 167 : gfc_commit_symbol (proc);
1105 167 : free (name);
1106 :
1107 167 : split_expr_at_caf_ref (expr->value.function.actual->expr, sub_ns,
1108 : &post_caf_ref_expr, true);
1109 :
1110 167 : if (ns->proc_name->attr.flavor == FL_MODULE)
1111 4 : proc->module = ns->proc_name->name;
1112 167 : gfc_set_sym_referenced (proc);
1113 : /* Set up formal arguments. */
1114 167 : gfc_formal_arglist **argptr = &proc->formal;
1115 : #define ADD_ARG(name, nsym, stype, skind, sintent) \
1116 : gfc_get_symbol (name, sub_ns, &nsym); \
1117 : nsym->ts.type = stype; \
1118 : nsym->ts.kind = skind; \
1119 : nsym->attr.flavor = FL_PARAMETER; \
1120 : nsym->attr.dummy = 1; \
1121 : nsym->attr.intent = sintent; \
1122 : nsym->declared_at = expr->where; \
1123 : gfc_set_sym_referenced (nsym); \
1124 : *argptr = gfc_get_formal_arglist (); \
1125 : (*argptr)->sym = nsym; \
1126 : argptr = &(*argptr)->next
1127 :
1128 167 : name = xasprintf ("add_data_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1129 167 : ADD_ARG (name, add_data, BT_DERIVED, 0, INTENT_IN);
1130 167 : gfc_commit_symbol (add_data);
1131 167 : free (name);
1132 167 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
1133 : INTENT_IN);
1134 167 : gfc_commit_symbol (caller_image);
1135 :
1136 167 : ADD_ARG ("result", result, BT_LOGICAL, gfc_default_logical_kind, INTENT_OUT);
1137 167 : gfc_commit_symbol (result);
1138 :
1139 : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
1140 167 : base = post_caf_ref_expr->symtree->n.sym;
1141 167 : base->attr.pointer = !base->attr.dimension;
1142 167 : gfc_set_sym_referenced (base);
1143 167 : *argptr = gfc_get_formal_arglist ();
1144 167 : (*argptr)->sym = base;
1145 167 : argptr = &(*argptr)->next;
1146 167 : gfc_commit_symbol (base);
1147 : #undef ADD_ARG
1148 :
1149 : /* Set up code. */
1150 : /* Code: result = post_caf_ref_expr; */
1151 167 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
1152 167 : code->loc = expr->where;
1153 167 : code->expr1 = gfc_lval_expr_from_sym (result);
1154 167 : swp = *expr;
1155 167 : *expr = *swp.value.function.actual->expr;
1156 167 : swp.value.function.actual->expr = nullptr;
1157 167 : code->expr2 = gfc_copy_expr (&swp);
1158 167 : code->expr2->value.function.actual->expr = post_caf_ref_expr;
1159 :
1160 167 : remove_caf_ref (code->expr2->value.function.actual->expr, true);
1161 167 : add_data->ts.u.derived
1162 167 : = create_caf_add_data_parameter_type (post_caf_ref_expr, ns, add_data);
1163 :
1164 167 : cb = gfc_lval_expr_from_sym (extproc);
1165 167 : cb->ts.interface = extproc;
1166 :
1167 167 : if (caf_accessor_prepend)
1168 : {
1169 : gfc_code *c = caf_accessor_prepend;
1170 : /* Find last in chain. */
1171 0 : for (; c->next; c = c->next)
1172 : ;
1173 0 : c->next = sub_ns->code;
1174 0 : sub_ns->code = caf_accessor_prepend;
1175 : }
1176 167 : caf_accessor_prepend = backup_caf_accessor_prepend;
1177 167 : return cb;
1178 : }
1179 :
1180 : static void
1181 167 : rewrite_caf_allocated (gfc_expr **e)
1182 : {
1183 167 : gfc_expr *present_fn_expr, *present_hash_expr, *wrapper;
1184 :
1185 167 : present_fn_expr = create_allocated_callback (*e);
1186 :
1187 167 : present_hash_expr = gfc_get_expr ();
1188 167 : present_hash_expr->expr_type = EXPR_CONSTANT;
1189 167 : present_hash_expr->ts.type = BT_INTEGER;
1190 167 : present_hash_expr->ts.kind = gfc_default_integer_kind;
1191 167 : present_hash_expr->where = (*e)->where;
1192 167 : mpz_init_set_ui (present_hash_expr->value.integer,
1193 167 : gfc_hash_value (present_fn_expr->symtree->n.sym));
1194 167 : wrapper
1195 167 : = gfc_build_intrinsic_call (gfc_current_ns,
1196 : GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE,
1197 : "caf_is_present_on_remote", (*e)->where, 3, *e,
1198 : present_hash_expr, present_fn_expr);
1199 167 : gfc_add_caf_accessor (present_hash_expr, present_fn_expr);
1200 167 : *e = wrapper;
1201 167 : }
1202 :
1203 : static gfc_expr *
1204 500 : create_send_callback (gfc_expr *expr, gfc_expr *rhs)
1205 : {
1206 500 : gfc_namespace *ns;
1207 500 : gfc_symbol *extproc, *proc, *buffer, *base, *send_data, *caller_image;
1208 500 : char tname[GFC_MAX_SYMBOL_LEN + 1];
1209 500 : char *name;
1210 500 : const char *mname;
1211 500 : gfc_expr *cb, *post_caf_ref_expr;
1212 500 : gfc_code *code;
1213 500 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
1214 500 : caf_accessor_prepend = nullptr;
1215 :
1216 : /* Find the top-level namespace. */
1217 659 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
1218 : ;
1219 :
1220 500 : if (expr->expr_type == EXPR_VARIABLE)
1221 500 : strcpy (tname, expr->symtree->name);
1222 : else
1223 0 : strcpy (tname, "dummy");
1224 500 : if (expr->symtree->n.sym->module)
1225 0 : mname = expr->symtree->n.sym->module;
1226 : else
1227 : mname = "main";
1228 500 : name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1229 500 : gfc_get_symbol (name, ns, &extproc);
1230 500 : extproc->declared_at = expr->where;
1231 500 : gfc_set_sym_referenced (extproc);
1232 500 : ++extproc->refs;
1233 500 : gfc_commit_symbol (extproc);
1234 :
1235 : /* Set up namespace. */
1236 500 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
1237 500 : sub_ns->sibling = ns->contained;
1238 500 : ns->contained = sub_ns;
1239 500 : sub_ns->resolved = 1;
1240 : /* Set up procedure symbol. */
1241 500 : gfc_find_symbol (name, sub_ns, 1, &proc);
1242 500 : sub_ns->proc_name = proc;
1243 500 : proc->attr.if_source = IFSRC_DECL;
1244 500 : proc->attr.access = ACCESS_PUBLIC;
1245 500 : gfc_add_subroutine (&proc->attr, name, NULL);
1246 500 : proc->attr.host_assoc = 1;
1247 500 : proc->attr.always_explicit = 1;
1248 500 : ++proc->refs;
1249 500 : proc->declared_at = expr->where;
1250 500 : gfc_commit_symbol (proc);
1251 500 : free (name);
1252 :
1253 500 : split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, true);
1254 :
1255 500 : if (ns->proc_name->attr.flavor == FL_MODULE)
1256 1 : proc->module = ns->proc_name->name;
1257 500 : gfc_set_sym_referenced (proc);
1258 : /* Set up formal arguments. */
1259 500 : gfc_formal_arglist **argptr = &proc->formal;
1260 : #define ADD_ARG(name, nsym, stype, skind, sintent) \
1261 : gfc_get_symbol (name, sub_ns, &nsym); \
1262 : nsym->ts.type = stype; \
1263 : nsym->ts.kind = skind; \
1264 : nsym->attr.flavor = FL_PARAMETER; \
1265 : nsym->attr.dummy = 1; \
1266 : nsym->attr.intent = sintent; \
1267 : nsym->declared_at = expr->where; \
1268 : gfc_set_sym_referenced (nsym); \
1269 : *argptr = gfc_get_formal_arglist (); \
1270 : (*argptr)->sym = nsym; \
1271 : argptr = &(*argptr)->next
1272 :
1273 500 : name = xasprintf ("add_send_data_%s_%s_%d", mname, tname, caf_sym_cnt);
1274 500 : ADD_ARG (name, send_data, BT_DERIVED, 0, INTENT_IN);
1275 500 : gfc_commit_symbol (send_data);
1276 500 : free (name);
1277 :
1278 500 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
1279 : INTENT_IN);
1280 500 : gfc_commit_symbol (caller_image);
1281 :
1282 : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
1283 500 : base = post_caf_ref_expr->symtree->n.sym;
1284 500 : base->attr.intent = INTENT_INOUT;
1285 500 : gfc_set_sym_referenced (base);
1286 500 : gfc_commit_symbol (base);
1287 500 : *argptr = gfc_get_formal_arglist ();
1288 500 : (*argptr)->sym = base;
1289 500 : argptr = &(*argptr)->next;
1290 500 : gfc_commit_symbol (base);
1291 :
1292 500 : ADD_ARG ("buffer", buffer, rhs->ts.type, rhs->ts.kind, INTENT_IN);
1293 500 : buffer->ts = rhs->ts;
1294 500 : if (rhs->rank)
1295 : {
1296 200 : buffer->as = gfc_get_array_spec ();
1297 200 : buffer->as->rank = rhs->rank;
1298 200 : buffer->as->type = AS_DEFERRED;
1299 200 : buffer->attr.allocatable = 1;
1300 200 : buffer->attr.dimension = 1;
1301 : }
1302 500 : if (buffer->ts.type == BT_CHARACTER)
1303 : {
1304 116 : buffer->ts.u.cl = gfc_get_charlen ();
1305 116 : *buffer->ts.u.cl = *rhs->ts.u.cl;
1306 116 : buffer->ts.deferred = 1;
1307 116 : buffer->ts.u.cl->length = gfc_copy_expr (rhs->ts.u.cl->length);
1308 : }
1309 500 : gfc_commit_symbol (buffer);
1310 : #undef ADD_ARG
1311 :
1312 : /* Set up code. */
1313 : /* Code: base = buffer; */
1314 500 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
1315 500 : code->loc = expr->where;
1316 500 : code->expr1 = post_caf_ref_expr;
1317 500 : if (code->expr1->ts.type == BT_CHARACTER
1318 116 : && code->expr1->ts.kind != buffer->ts.kind)
1319 : {
1320 56 : bool converted;
1321 56 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1322 56 : converted = gfc_convert_chartype (code->expr2, &code->expr1->ts);
1323 56 : gcc_assert (converted);
1324 : }
1325 444 : else if (code->expr1->ts.type != buffer->ts.type)
1326 : {
1327 126 : bool converted;
1328 126 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1329 252 : converted = gfc_convert_type_warn (code->expr2, &code->expr1->ts, 0, 0,
1330 126 : buffer->attr.dimension);
1331 126 : gcc_assert (converted);
1332 : }
1333 : else
1334 318 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1335 500 : remove_caf_ref (post_caf_ref_expr);
1336 500 : send_data->ts.u.derived
1337 500 : = create_caf_add_data_parameter_type (code->expr1, ns, send_data);
1338 :
1339 500 : cb = gfc_lval_expr_from_sym (extproc);
1340 500 : cb->ts.interface = extproc;
1341 :
1342 500 : if (caf_accessor_prepend)
1343 : {
1344 : gfc_code *c = caf_accessor_prepend;
1345 : /* Find last in chain. */
1346 0 : for (; c->next; c = c->next)
1347 : ;
1348 0 : c->next = sub_ns->code;
1349 0 : sub_ns->code = caf_accessor_prepend;
1350 : }
1351 500 : caf_accessor_prepend = backup_caf_accessor_prepend;
1352 500 : return cb;
1353 : }
1354 :
1355 : static void
1356 500 : rewrite_caf_send (gfc_code *c)
1357 : {
1358 500 : gfc_expr *send_to_remote_expr, *send_to_remote_hash_expr, *lhs, *rhs;
1359 500 : gfc_actual_arglist *arg = c->ext.actual;
1360 :
1361 500 : lhs = arg->expr;
1362 500 : arg = arg->next;
1363 500 : rhs = arg->expr;
1364 : /* Detect an already rewritten caf_send. */
1365 500 : if (arg->next && arg->next->expr->expr_type == EXPR_CONSTANT
1366 0 : && arg->next->next && arg->next->next->expr->expr_type == EXPR_VARIABLE)
1367 : return;
1368 :
1369 500 : send_to_remote_expr = create_send_callback (lhs, rhs);
1370 500 : send_to_remote_hash_expr = gfc_get_expr ();
1371 500 : send_to_remote_hash_expr->expr_type = EXPR_CONSTANT;
1372 500 : send_to_remote_hash_expr->ts.type = BT_INTEGER;
1373 500 : send_to_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1374 500 : send_to_remote_hash_expr->where = lhs->where;
1375 500 : mpz_init_set_ui (send_to_remote_hash_expr->value.integer,
1376 500 : gfc_hash_value (send_to_remote_expr->symtree->n.sym));
1377 500 : arg->next = gfc_get_actual_arglist ();
1378 500 : arg = arg->next;
1379 500 : arg->expr = send_to_remote_hash_expr;
1380 500 : arg->next = gfc_get_actual_arglist ();
1381 500 : arg = arg->next;
1382 500 : arg->expr = send_to_remote_expr;
1383 500 : gfc_add_caf_accessor (send_to_remote_hash_expr, send_to_remote_expr);
1384 :
1385 500 : if (gfc_is_coindexed (rhs))
1386 : {
1387 140 : gfc_expr *get_from_remote_expr, *get_from_remote_hash_expr;
1388 :
1389 140 : c->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SENDGET);
1390 140 : get_from_remote_expr = create_get_callback (rhs);
1391 140 : get_from_remote_hash_expr = gfc_get_expr ();
1392 140 : get_from_remote_hash_expr->expr_type = EXPR_CONSTANT;
1393 140 : get_from_remote_hash_expr->ts.type = BT_INTEGER;
1394 140 : get_from_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1395 140 : get_from_remote_hash_expr->where = rhs->where;
1396 140 : mpz_init_set_ui (get_from_remote_hash_expr->value.integer,
1397 140 : gfc_hash_value (get_from_remote_expr->symtree->n.sym));
1398 140 : arg->next = gfc_get_actual_arglist ();
1399 140 : arg = arg->next;
1400 140 : arg->expr = get_from_remote_hash_expr;
1401 140 : arg->next = gfc_get_actual_arglist ();
1402 140 : arg = arg->next;
1403 140 : arg->expr = get_from_remote_expr;
1404 140 : gfc_add_caf_accessor (get_from_remote_hash_expr, get_from_remote_expr);
1405 : }
1406 : }
1407 :
1408 : static int
1409 69172 : coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
1410 : void *data ATTRIBUTE_UNUSED)
1411 : {
1412 69172 : *walk_subtrees = 1;
1413 :
1414 69172 : switch ((*e)->expr_type)
1415 : {
1416 26084 : case EXPR_VARIABLE:
1417 26084 : if (!caf_on_lhs && gfc_is_coindexed (*e))
1418 : {
1419 921 : add_caf_get_from_remote (*e);
1420 921 : *walk_subtrees = 0;
1421 : }
1422 : /* Clear the flag to rewrite caf_gets in sub expressions of the lhs. */
1423 26084 : caf_on_lhs = false;
1424 26084 : break;
1425 7750 : case EXPR_FUNCTION:
1426 7750 : if ((*e)->value.function.isym)
1427 7612 : switch ((*e)->value.function.isym->id)
1428 : {
1429 632 : case GFC_ISYM_ALLOCATED:
1430 632 : if ((*e)->value.function.actual->expr
1431 632 : && (gfc_is_coarray ((*e)->value.function.actual->expr)
1432 537 : || gfc_is_coindexed ((*e)->value.function.actual->expr)))
1433 : {
1434 167 : rewrite_caf_allocated (e);
1435 167 : *walk_subtrees = 0;
1436 : }
1437 : break;
1438 4 : case GFC_ISYM_CAF_GET:
1439 4 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
1440 4 : *walk_subtrees = 0;
1441 4 : break;
1442 : default:
1443 : break;
1444 : }
1445 : default:
1446 : break;
1447 : }
1448 :
1449 69172 : return 0;
1450 : }
1451 :
1452 : static int
1453 18598 : coindexed_code_callback (gfc_code **c, int *walk_subtrees,
1454 : void *data ATTRIBUTE_UNUSED)
1455 : {
1456 18598 : int ws = 1;
1457 18598 : current_code = c;
1458 :
1459 18598 : switch ((*c)->op)
1460 : {
1461 6562 : case EXEC_ASSIGN:
1462 6562 : case EXEC_POINTER_ASSIGN:
1463 6562 : caf_on_lhs = true;
1464 6562 : coindexed_expr_callback (&((*c)->expr1), &ws, NULL);
1465 6562 : caf_on_lhs = false;
1466 6562 : ws = 1;
1467 6562 : coindexed_expr_callback (&((*c)->expr2), &ws, NULL);
1468 6562 : *walk_subtrees = ws;
1469 6562 : break;
1470 127 : case EXEC_LOCK:
1471 127 : case EXEC_UNLOCK:
1472 127 : case EXEC_EVENT_POST:
1473 127 : case EXEC_EVENT_WAIT:
1474 127 : *walk_subtrees = 0;
1475 127 : break;
1476 1063 : case EXEC_CALL:
1477 1063 : *walk_subtrees = 1;
1478 1063 : if ((*c)->resolved_isym)
1479 836 : switch ((*c)->resolved_isym->id)
1480 : {
1481 500 : case GFC_ISYM_CAF_SEND:
1482 500 : rewrite_caf_send (*c);
1483 500 : *walk_subtrees = 0;
1484 500 : break;
1485 0 : case GFC_ISYM_CAF_SENDGET:
1486 : /* Seldomly this routine is called again with the symbol already
1487 : changed to CAF_SENDGET. Do not process the subtree again. The
1488 : rewrite has already been done by rewrite_caf_send (). */
1489 0 : *walk_subtrees = 0;
1490 0 : break;
1491 179 : case GFC_ISYM_ATOMIC_ADD:
1492 179 : case GFC_ISYM_ATOMIC_AND:
1493 179 : case GFC_ISYM_ATOMIC_CAS:
1494 179 : case GFC_ISYM_ATOMIC_DEF:
1495 179 : case GFC_ISYM_ATOMIC_FETCH_ADD:
1496 179 : case GFC_ISYM_ATOMIC_FETCH_AND:
1497 179 : case GFC_ISYM_ATOMIC_FETCH_OR:
1498 179 : case GFC_ISYM_ATOMIC_FETCH_XOR:
1499 179 : case GFC_ISYM_ATOMIC_OR:
1500 179 : case GFC_ISYM_ATOMIC_REF:
1501 179 : case GFC_ISYM_ATOMIC_XOR:
1502 179 : *walk_subtrees = 0;
1503 179 : break;
1504 : default:
1505 : break;
1506 : }
1507 : break;
1508 10846 : default:
1509 10846 : *walk_subtrees = 1;
1510 10846 : break;
1511 : }
1512 18598 : return 0;
1513 : }
1514 :
1515 : void
1516 1975 : gfc_coarray_rewrite (gfc_namespace *ns)
1517 : {
1518 1975 : gfc_namespace *saved_ns = gfc_current_ns;
1519 1975 : gfc_current_ns = ns;
1520 :
1521 1975 : if (flag_coarray == GFC_FCOARRAY_LIB)
1522 : {
1523 1975 : gfc_code_walker (&ns->code, coindexed_code_callback,
1524 : coindexed_expr_callback, NULL);
1525 :
1526 3434 : for (gfc_namespace *cns = ns->contained; cns; cns = cns->sibling)
1527 1459 : gfc_coarray_rewrite (cns);
1528 : }
1529 :
1530 1975 : gfc_current_ns = saved_ns;
1531 1975 : }
|
