]> git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/caf/single.c
projects / thirdparty / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
gcc/testsuite/ChangeLog:
[thirdparty/gcc.git] / libgfortran / caf / single.c
1 /* Single-image implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2017 Free Software Foundation, Inc.
3 Contributed by Tobias Burnus <burnus@net-b.de>
4
5 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
6
7 Libcaf is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
10 any later version.
11
12 Libcaf is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 #include "libcaf.h"
27 #include <stdio.h> /* For fputs and fprintf. */
28 #include <stdlib.h> /* For exit and malloc. */
29 #include <string.h> /* For memcpy and memset. */
30 #include <stdarg.h> /* For variadic arguments. */
31 #include <assert.h>
32
33 /* Define GFC_CAF_CHECK to enable run-time checking. */
34 /* #define GFC_CAF_CHECK 1 */
35
36 struct caf_single_token
37 {
38 /* The pointer to the memory registered. For arrays this is the data member
39 in the descriptor. For components it's the pure data pointer. */
40 void *memptr;
41 /* The descriptor when this token is associated to an allocatable array. */
42 gfc_descriptor_t *desc;
43 /* Set when the caf lib has allocated the memory in memptr and is responsible
44 for freeing it on deregister. */
45 bool owning_memory;
46 };
47 typedef struct caf_single_token *caf_single_token_t;
48
49 #define TOKEN(X) ((caf_single_token_t) (X))
50 #define MEMTOK(X) ((caf_single_token_t) (X))->memptr
51
52 /* Single-image implementation of the CAF library.
53 Note: For performance reasons -fcoarry=single should be used
54 rather than this library. */
55
56 /* Global variables. */
57 caf_static_t *caf_static_list = NULL;
58
59 /* Keep in sync with mpi.c. */
60 static void
61 caf_runtime_error (const char *message, ...)
62 {
63 va_list ap;
64 fprintf (stderr, "Fortran runtime error: ");
65 va_start (ap, message);
66 vfprintf (stderr, message, ap);
67 va_end (ap);
68 fprintf (stderr, "\n");
69
70 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
71 exit (EXIT_FAILURE);
72 }
73
74 /* Error handling is similar everytime. */
75 static void
76 caf_internal_error (const char *msg, int *stat, char *errmsg,
77 int errmsg_len, ...)
78 {
79 va_list args;
80 va_start (args, errmsg_len);
81 if (stat)
82 {
83 *stat = 1;
84 if (errmsg_len > 0)
85 {
86 size_t len = snprintf (errmsg, errmsg_len, msg, args);
87 if ((size_t)errmsg_len > len)
88 memset (&errmsg[len], ' ', errmsg_len - len);
89 }
90 va_end (args);
91 return;
92 }
93 else
94 caf_runtime_error (msg, args);
95 va_end (args);
96 }
97
98
99 void
100 _gfortran_caf_init (int *argc __attribute__ ((unused)),
101 char ***argv __attribute__ ((unused)))
102 {
103 }
104
105
106 void
107 _gfortran_caf_finalize (void)
108 {
109 while (caf_static_list != NULL)
110 {
111 caf_static_t *tmp = caf_static_list->prev;
112 free (caf_static_list->token);
113 free (caf_static_list);
114 caf_static_list = tmp;
115 }
116 }
117
118
119 int
120 _gfortran_caf_this_image (int distance __attribute__ ((unused)))
121 {
122 return 1;
123 }
124
125
126 int
127 _gfortran_caf_num_images (int distance __attribute__ ((unused)),
128 int failed __attribute__ ((unused)))
129 {
130 return 1;
131 }
132
133
134 void
135 _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
136 gfc_descriptor_t *data, int *stat, char *errmsg,
137 int errmsg_len)
138 {
139 const char alloc_fail_msg[] = "Failed to allocate coarray";
140 void *local;
141 caf_single_token_t single_token;
142
143 if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
144 || type == CAF_REGTYPE_CRITICAL)
145 local = calloc (size, sizeof (bool));
146 else if (type == CAF_REGTYPE_EVENT_STATIC || type == CAF_REGTYPE_EVENT_ALLOC)
147 /* In the event_(wait|post) function the counter for events is a uint32,
148 so better allocate enough memory here. */
149 local = calloc (size, sizeof (uint32_t));
150 else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
151 local = NULL;
152 else
153 local = malloc (size);
154
155 if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
156 *token = malloc (sizeof (struct caf_single_token));
157
158 if (unlikely (*token == NULL
159 || (local == NULL
160 && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
161 {
162 /* Freeing the memory conditionally seems pointless, but
163 caf_internal_error () may return, when a stat is given and then the
164 memory may be lost. */
165 if (local)
166 free (local);
167 if (*token)
168 free (*token);
169 caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
170 return;
171 }
172
173 single_token = TOKEN (*token);
174 single_token->memptr = local;
175 single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
176 single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
177
178
179 if (stat)
180 *stat = 0;
181
182 if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
183 || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
184 || type == CAF_REGTYPE_EVENT_ALLOC)
185 {
186 caf_static_t *tmp = malloc (sizeof (caf_static_t));
187 tmp->prev = caf_static_list;
188 tmp->token = *token;
189 caf_static_list = tmp;
190 }
191 GFC_DESCRIPTOR_DATA (data) = local;
192 }
193
194
195 void
196 _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
197 char *errmsg __attribute__ ((unused)),
198 int errmsg_len __attribute__ ((unused)))
199 {
200 caf_single_token_t single_token = TOKEN (*token);
201
202 if (single_token->owning_memory && single_token->memptr)
203 free (single_token->memptr);
204
205 if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
206 {
207 free (TOKEN (*token));
208 *token = NULL;
209 }
210 else
211 {
212 single_token->memptr = NULL;
213 single_token->owning_memory = false;
214 }
215
216 if (stat)
217 *stat = 0;
218 }
219
220
221 void
222 _gfortran_caf_sync_all (int *stat,
223 char *errmsg __attribute__ ((unused)),
224 int errmsg_len __attribute__ ((unused)))
225 {
226 __asm__ __volatile__ ("":::"memory");
227 if (stat)
228 *stat = 0;
229 }
230
231
232 void
233 _gfortran_caf_sync_memory (int *stat,
234 char *errmsg __attribute__ ((unused)),
235 int errmsg_len __attribute__ ((unused)))
236 {
237 __asm__ __volatile__ ("":::"memory");
238 if (stat)
239 *stat = 0;
240 }
241
242
243 void
244 _gfortran_caf_sync_images (int count __attribute__ ((unused)),
245 int images[] __attribute__ ((unused)),
246 int *stat,
247 char *errmsg __attribute__ ((unused)),
248 int errmsg_len __attribute__ ((unused)))
249 {
250 #ifdef GFC_CAF_CHECK
251 int i;
252
253 for (i = 0; i < count; i++)
254 if (images[i] != 1)
255 {
256 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
257 "IMAGES", images[i]);
258 exit (EXIT_FAILURE);
259 }
260 #endif
261
262 __asm__ __volatile__ ("":::"memory");
263 if (stat)
264 *stat = 0;
265 }
266
267 void
268 _gfortran_caf_stop_numeric(int32_t stop_code)
269 {
270 fprintf (stderr, "STOP %d\n", stop_code);
271 exit (0);
272 }
273
274 void
275 _gfortran_caf_stop_str(const char *string, int32_t len)
276 {
277 fputs ("STOP ", stderr);
278 while (len--)
279 fputc (*(string++), stderr);
280 fputs ("\n", stderr);
281
282 exit (0);
283 }
284
285 void
286 _gfortran_caf_error_stop_str (const char *string, int32_t len)
287 {
288 fputs ("ERROR STOP ", stderr);
289 while (len--)
290 fputc (*(string++), stderr);
291 fputs ("\n", stderr);
292
293 exit (1);
294 }
295
296
297 void
298 _gfortran_caf_error_stop (int32_t error)
299 {
300 fprintf (stderr, "ERROR STOP %d\n", error);
301 exit (error);
302 }
303
304
305 void
306 _gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
307 int source_image __attribute__ ((unused)),
308 int *stat, char *errmsg __attribute__ ((unused)),
309 int errmsg_len __attribute__ ((unused)))
310 {
311 if (stat)
312 *stat = 0;
313 }
314
315 void
316 _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
317 int result_image __attribute__ ((unused)),
318 int *stat, char *errmsg __attribute__ ((unused)),
319 int errmsg_len __attribute__ ((unused)))
320 {
321 if (stat)
322 *stat = 0;
323 }
324
325 void
326 _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
327 int result_image __attribute__ ((unused)),
328 int *stat, char *errmsg __attribute__ ((unused)),
329 int a_len __attribute__ ((unused)),
330 int errmsg_len __attribute__ ((unused)))
331 {
332 if (stat)
333 *stat = 0;
334 }
335
336 void
337 _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
338 int result_image __attribute__ ((unused)),
339 int *stat, char *errmsg __attribute__ ((unused)),
340 int a_len __attribute__ ((unused)),
341 int errmsg_len __attribute__ ((unused)))
342 {
343 if (stat)
344 *stat = 0;
345 }
346
347
348 void
349 _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
350 void * (*opr) (void *, void *)
351 __attribute__ ((unused)),
352 int opr_flags __attribute__ ((unused)),
353 int result_image __attribute__ ((unused)),
354 int *stat, char *errmsg __attribute__ ((unused)),
355 int a_len __attribute__ ((unused)),
356 int errmsg_len __attribute__ ((unused)))
357 {
358 if (stat)
359 *stat = 0;
360 }
361
362
363 static void
364 assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
365 unsigned char *src)
366 {
367 size_t i, n;
368 n = dst_size/4 > src_size ? src_size : dst_size/4;
369 for (i = 0; i < n; ++i)
370 dst[i] = (int32_t) src[i];
371 for (; i < dst_size/4; ++i)
372 dst[i] = (int32_t) ' ';
373 }
374
375
376 static void
377 assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
378 uint32_t *src)
379 {
380 size_t i, n;
381 n = dst_size > src_size/4 ? src_size/4 : dst_size;
382 for (i = 0; i < n; ++i)
383 dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
384 if (dst_size > n)
385 memset (&dst[n], ' ', dst_size - n);
386 }
387
388
389 static void
390 convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
391 int src_kind, int *stat)
392 {
393 #ifdef HAVE_GFC_INTEGER_16
394 typedef __int128 int128t;
395 #else
396 typedef int64_t int128t;
397 #endif
398
399 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
400 typedef long double real128t;
401 typedef _Complex long double complex128t;
402 #elif defined(HAVE_GFC_REAL_16)
403 typedef _Complex float __attribute__((mode(TC))) __complex128;
404 typedef __float128 real128t;
405 typedef __complex128 complex128t;
406 #elif defined(HAVE_GFC_REAL_10)
407 typedef long double real128t;
408 typedef long double complex128t;
409 #else
410 typedef double real128t;
411 typedef _Complex double complex128t;
412 #endif
413
414 int128t int_val = 0;
415 real128t real_val = 0;
416 complex128t cmpx_val = 0;
417
418 switch (src_type)
419 {
420 case BT_INTEGER:
421 if (src_kind == 1)
422 int_val = *(int8_t*) src;
423 else if (src_kind == 2)
424 int_val = *(int16_t*) src;
425 else if (src_kind == 4)
426 int_val = *(int32_t*) src;
427 else if (src_kind == 8)
428 int_val = *(int64_t*) src;
429 #ifdef HAVE_GFC_INTEGER_16
430 else if (src_kind == 16)
431 int_val = *(int128t*) src;
432 #endif
433 else
434 goto error;
435 break;
436 case BT_REAL:
437 if (src_kind == 4)
438 real_val = *(float*) src;
439 else if (src_kind == 8)
440 real_val = *(double*) src;
441 #ifdef HAVE_GFC_REAL_10
442 else if (src_kind == 10)
443 real_val = *(long double*) src;
444 #endif
445 #ifdef HAVE_GFC_REAL_16
446 else if (src_kind == 16)
447 real_val = *(real128t*) src;
448 #endif
449 else
450 goto error;
451 break;
452 case BT_COMPLEX:
453 if (src_kind == 4)
454 cmpx_val = *(_Complex float*) src;
455 else if (src_kind == 8)
456 cmpx_val = *(_Complex double*) src;
457 #ifdef HAVE_GFC_REAL_10
458 else if (src_kind == 10)
459 cmpx_val = *(_Complex long double*) src;
460 #endif
461 #ifdef HAVE_GFC_REAL_16
462 else if (src_kind == 16)
463 cmpx_val = *(complex128t*) src;
464 #endif
465 else
466 goto error;
467 break;
468 default:
469 goto error;
470 }
471
472 switch (dst_type)
473 {
474 case BT_INTEGER:
475 if (src_type == BT_INTEGER)
476 {
477 if (dst_kind == 1)
478 *(int8_t*) dst = (int8_t) int_val;
479 else if (dst_kind == 2)
480 *(int16_t*) dst = (int16_t) int_val;
481 else if (dst_kind == 4)
482 *(int32_t*) dst = (int32_t) int_val;
483 else if (dst_kind == 8)
484 *(int64_t*) dst = (int64_t) int_val;
485 #ifdef HAVE_GFC_INTEGER_16
486 else if (dst_kind == 16)
487 *(int128t*) dst = (int128t) int_val;
488 #endif
489 else
490 goto error;
491 }
492 else if (src_type == BT_REAL)
493 {
494 if (dst_kind == 1)
495 *(int8_t*) dst = (int8_t) real_val;
496 else if (dst_kind == 2)
497 *(int16_t*) dst = (int16_t) real_val;
498 else if (dst_kind == 4)
499 *(int32_t*) dst = (int32_t) real_val;
500 else if (dst_kind == 8)
501 *(int64_t*) dst = (int64_t) real_val;
502 #ifdef HAVE_GFC_INTEGER_16
503 else if (dst_kind == 16)
504 *(int128t*) dst = (int128t) real_val;
505 #endif
506 else
507 goto error;
508 }
509 else if (src_type == BT_COMPLEX)
510 {
511 if (dst_kind == 1)
512 *(int8_t*) dst = (int8_t) cmpx_val;
513 else if (dst_kind == 2)
514 *(int16_t*) dst = (int16_t) cmpx_val;
515 else if (dst_kind == 4)
516 *(int32_t*) dst = (int32_t) cmpx_val;
517 else if (dst_kind == 8)
518 *(int64_t*) dst = (int64_t) cmpx_val;
519 #ifdef HAVE_GFC_INTEGER_16
520 else if (dst_kind == 16)
521 *(int128t*) dst = (int128t) cmpx_val;
522 #endif
523 else
524 goto error;
525 }
526 else
527 goto error;
528 return;
529 case BT_REAL:
530 if (src_type == BT_INTEGER)
531 {
532 if (dst_kind == 4)
533 *(float*) dst = (float) int_val;
534 else if (dst_kind == 8)
535 *(double*) dst = (double) int_val;
536 #ifdef HAVE_GFC_REAL_10
537 else if (dst_kind == 10)
538 *(long double*) dst = (long double) int_val;
539 #endif
540 #ifdef HAVE_GFC_REAL_16
541 else if (dst_kind == 16)
542 *(real128t*) dst = (real128t) int_val;
543 #endif
544 else
545 goto error;
546 }
547 else if (src_type == BT_REAL)
548 {
549 if (dst_kind == 4)
550 *(float*) dst = (float) real_val;
551 else if (dst_kind == 8)
552 *(double*) dst = (double) real_val;
553 #ifdef HAVE_GFC_REAL_10
554 else if (dst_kind == 10)
555 *(long double*) dst = (long double) real_val;
556 #endif
557 #ifdef HAVE_GFC_REAL_16
558 else if (dst_kind == 16)
559 *(real128t*) dst = (real128t) real_val;
560 #endif
561 else
562 goto error;
563 }
564 else if (src_type == BT_COMPLEX)
565 {
566 if (dst_kind == 4)
567 *(float*) dst = (float) cmpx_val;
568 else if (dst_kind == 8)
569 *(double*) dst = (double) cmpx_val;
570 #ifdef HAVE_GFC_REAL_10
571 else if (dst_kind == 10)
572 *(long double*) dst = (long double) cmpx_val;
573 #endif
574 #ifdef HAVE_GFC_REAL_16
575 else if (dst_kind == 16)
576 *(real128t*) dst = (real128t) cmpx_val;
577 #endif
578 else
579 goto error;
580 }
581 return;
582 case BT_COMPLEX:
583 if (src_type == BT_INTEGER)
584 {
585 if (dst_kind == 4)
586 *(_Complex float*) dst = (_Complex float) int_val;
587 else if (dst_kind == 8)
588 *(_Complex double*) dst = (_Complex double) int_val;
589 #ifdef HAVE_GFC_REAL_10
590 else if (dst_kind == 10)
591 *(_Complex long double*) dst = (_Complex long double) int_val;
592 #endif
593 #ifdef HAVE_GFC_REAL_16
594 else if (dst_kind == 16)
595 *(complex128t*) dst = (complex128t) int_val;
596 #endif
597 else
598 goto error;
599 }
600 else if (src_type == BT_REAL)
601 {
602 if (dst_kind == 4)
603 *(_Complex float*) dst = (_Complex float) real_val;
604 else if (dst_kind == 8)
605 *(_Complex double*) dst = (_Complex double) real_val;
606 #ifdef HAVE_GFC_REAL_10
607 else if (dst_kind == 10)
608 *(_Complex long double*) dst = (_Complex long double) real_val;
609 #endif
610 #ifdef HAVE_GFC_REAL_16
611 else if (dst_kind == 16)
612 *(complex128t*) dst = (complex128t) real_val;
613 #endif
614 else
615 goto error;
616 }
617 else if (src_type == BT_COMPLEX)
618 {
619 if (dst_kind == 4)
620 *(_Complex float*) dst = (_Complex float) cmpx_val;
621 else if (dst_kind == 8)
622 *(_Complex double*) dst = (_Complex double) cmpx_val;
623 #ifdef HAVE_GFC_REAL_10
624 else if (dst_kind == 10)
625 *(_Complex long double*) dst = (_Complex long double) cmpx_val;
626 #endif
627 #ifdef HAVE_GFC_REAL_16
628 else if (dst_kind == 16)
629 *(complex128t*) dst = (complex128t) cmpx_val;
630 #endif
631 else
632 goto error;
633 }
634 else
635 goto error;
636 return;
637 default:
638 goto error;
639 }
640
641 error:
642 fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
643 "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
644 if (stat)
645 *stat = 1;
646 else
647 abort ();
648 }
649
650
651 void
652 _gfortran_caf_get (caf_token_t token, size_t offset,
653 int image_index __attribute__ ((unused)),
654 gfc_descriptor_t *src,
655 caf_vector_t *src_vector __attribute__ ((unused)),
656 gfc_descriptor_t *dest, int src_kind, int dst_kind,
657 bool may_require_tmp, int *stat)
658 {
659 /* FIXME: Handle vector subscripts. */
660 size_t i, k, size;
661 int j;
662 int rank = GFC_DESCRIPTOR_RANK (dest);
663 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
664 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
665
666 if (stat)
667 *stat = 0;
668
669 if (rank == 0)
670 {
671 void *sr = (void *) ((char *) MEMTOK (token) + offset);
672 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
673 && dst_kind == src_kind)
674 {
675 memmove (GFC_DESCRIPTOR_DATA (dest), sr,
676 dst_size > src_size ? src_size : dst_size);
677 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
678 {
679 if (dst_kind == 1)
680 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
681 ' ', dst_size - src_size);
682 else /* dst_kind == 4. */
683 for (i = src_size/4; i < dst_size/4; i++)
684 ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
685 }
686 }
687 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
688 assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
689 sr);
690 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
691 assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
692 sr);
693 else
694 convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
695 dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
696 return;
697 }
698
699 size = 1;
700 for (j = 0; j < rank; j++)
701 {
702 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
703 if (dimextent < 0)
704 dimextent = 0;
705 size *= dimextent;
706 }
707
708 if (size == 0)
709 return;
710
711 if (may_require_tmp)
712 {
713 ptrdiff_t array_offset_sr, array_offset_dst;
714 void *tmp = malloc (size*src_size);
715
716 array_offset_dst = 0;
717 for (i = 0; i < size; i++)
718 {
719 ptrdiff_t array_offset_sr = 0;
720 ptrdiff_t stride = 1;
721 ptrdiff_t extent = 1;
722 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
723 {
724 array_offset_sr += ((i / (extent*stride))
725 % (src->dim[j]._ubound
726 - src->dim[j].lower_bound + 1))
727 * src->dim[j]._stride;
728 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
729 stride = src->dim[j]._stride;
730 }
731 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
732 void *sr = (void *)((char *) MEMTOK (token) + offset
733 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
734 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
735 array_offset_dst += src_size;
736 }
737
738 array_offset_sr = 0;
739 for (i = 0; i < size; i++)
740 {
741 ptrdiff_t array_offset_dst = 0;
742 ptrdiff_t stride = 1;
743 ptrdiff_t extent = 1;
744 for (j = 0; j < rank-1; j++)
745 {
746 array_offset_dst += ((i / (extent*stride))
747 % (dest->dim[j]._ubound
748 - dest->dim[j].lower_bound + 1))
749 * dest->dim[j]._stride;
750 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
751 stride = dest->dim[j]._stride;
752 }
753 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
754 void *dst = dest->base_addr
755 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
756 void *sr = tmp + array_offset_sr;
757
758 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
759 && dst_kind == src_kind)
760 {
761 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
762 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
763 && dst_size > src_size)
764 {
765 if (dst_kind == 1)
766 memset ((void*)(char*) dst + src_size, ' ',
767 dst_size-src_size);
768 else /* dst_kind == 4. */
769 for (k = src_size/4; k < dst_size/4; k++)
770 ((int32_t*) dst)[k] = (int32_t) ' ';
771 }
772 }
773 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
774 assign_char1_from_char4 (dst_size, src_size, dst, sr);
775 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
776 assign_char4_from_char1 (dst_size, src_size, dst, sr);
777 else
778 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
779 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
780 array_offset_sr += src_size;
781 }
782
783 free (tmp);
784 return;
785 }
786
787 for (i = 0; i < size; i++)
788 {
789 ptrdiff_t array_offset_dst = 0;
790 ptrdiff_t stride = 1;
791 ptrdiff_t extent = 1;
792 for (j = 0; j < rank-1; j++)
793 {
794 array_offset_dst += ((i / (extent*stride))
795 % (dest->dim[j]._ubound
796 - dest->dim[j].lower_bound + 1))
797 * dest->dim[j]._stride;
798 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
799 stride = dest->dim[j]._stride;
800 }
801 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
802 void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
803
804 ptrdiff_t array_offset_sr = 0;
805 stride = 1;
806 extent = 1;
807 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
808 {
809 array_offset_sr += ((i / (extent*stride))
810 % (src->dim[j]._ubound
811 - src->dim[j].lower_bound + 1))
812 * src->dim[j]._stride;
813 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
814 stride = src->dim[j]._stride;
815 }
816 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
817 void *sr = (void *)((char *) MEMTOK (token) + offset
818 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
819
820 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
821 && dst_kind == src_kind)
822 {
823 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
824 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
825 {
826 if (dst_kind == 1)
827 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
828 else /* dst_kind == 4. */
829 for (k = src_size/4; k < dst_size/4; k++)
830 ((int32_t*) dst)[k] = (int32_t) ' ';
831 }
832 }
833 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
834 assign_char1_from_char4 (dst_size, src_size, dst, sr);
835 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
836 assign_char4_from_char1 (dst_size, src_size, dst, sr);
837 else
838 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
839 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
840 }
841 }
842
843
844 void
845 _gfortran_caf_send (caf_token_t token, size_t offset,
846 int image_index __attribute__ ((unused)),
847 gfc_descriptor_t *dest,
848 caf_vector_t *dst_vector __attribute__ ((unused)),
849 gfc_descriptor_t *src, int dst_kind, int src_kind,
850 bool may_require_tmp, int *stat)
851 {
852 /* FIXME: Handle vector subscripts. */
853 size_t i, k, size;
854 int j;
855 int rank = GFC_DESCRIPTOR_RANK (dest);
856 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
857 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
858
859 if (stat)
860 *stat = 0;
861
862 if (rank == 0)
863 {
864 void *dst = (void *) ((char *) MEMTOK (token) + offset);
865 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
866 && dst_kind == src_kind)
867 {
868 memmove (dst, GFC_DESCRIPTOR_DATA (src),
869 dst_size > src_size ? src_size : dst_size);
870 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
871 {
872 if (dst_kind == 1)
873 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
874 else /* dst_kind == 4. */
875 for (i = src_size/4; i < dst_size/4; i++)
876 ((int32_t*) dst)[i] = (int32_t) ' ';
877 }
878 }
879 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
880 assign_char1_from_char4 (dst_size, src_size, dst,
881 GFC_DESCRIPTOR_DATA (src));
882 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
883 assign_char4_from_char1 (dst_size, src_size, dst,
884 GFC_DESCRIPTOR_DATA (src));
885 else
886 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
887 GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
888 src_kind, stat);
889 return;
890 }
891
892 size = 1;
893 for (j = 0; j < rank; j++)
894 {
895 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
896 if (dimextent < 0)
897 dimextent = 0;
898 size *= dimextent;
899 }
900
901 if (size == 0)
902 return;
903
904 if (may_require_tmp)
905 {
906 ptrdiff_t array_offset_sr, array_offset_dst;
907 void *tmp;
908
909 if (GFC_DESCRIPTOR_RANK (src) == 0)
910 {
911 tmp = malloc (src_size);
912 memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
913 }
914 else
915 {
916 tmp = malloc (size*src_size);
917 array_offset_dst = 0;
918 for (i = 0; i < size; i++)
919 {
920 ptrdiff_t array_offset_sr = 0;
921 ptrdiff_t stride = 1;
922 ptrdiff_t extent = 1;
923 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
924 {
925 array_offset_sr += ((i / (extent*stride))
926 % (src->dim[j]._ubound
927 - src->dim[j].lower_bound + 1))
928 * src->dim[j]._stride;
929 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
930 stride = src->dim[j]._stride;
931 }
932 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
933 void *sr = (void *) ((char *) src->base_addr
934 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
935 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
936 array_offset_dst += src_size;
937 }
938 }
939
940 array_offset_sr = 0;
941 for (i = 0; i < size; i++)
942 {
943 ptrdiff_t array_offset_dst = 0;
944 ptrdiff_t stride = 1;
945 ptrdiff_t extent = 1;
946 for (j = 0; j < rank-1; j++)
947 {
948 array_offset_dst += ((i / (extent*stride))
949 % (dest->dim[j]._ubound
950 - dest->dim[j].lower_bound + 1))
951 * dest->dim[j]._stride;
952 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
953 stride = dest->dim[j]._stride;
954 }
955 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
956 void *dst = (void *)((char *) MEMTOK (token) + offset
957 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
958 void *sr = tmp + array_offset_sr;
959 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
960 && dst_kind == src_kind)
961 {
962 memmove (dst, sr,
963 dst_size > src_size ? src_size : dst_size);
964 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
965 && dst_size > src_size)
966 {
967 if (dst_kind == 1)
968 memset ((void*)(char*) dst + src_size, ' ',
969 dst_size-src_size);
970 else /* dst_kind == 4. */
971 for (k = src_size/4; k < dst_size/4; k++)
972 ((int32_t*) dst)[k] = (int32_t) ' ';
973 }
974 }
975 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
976 assign_char1_from_char4 (dst_size, src_size, dst, sr);
977 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
978 assign_char4_from_char1 (dst_size, src_size, dst, sr);
979 else
980 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
981 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
982 if (GFC_DESCRIPTOR_RANK (src))
983 array_offset_sr += src_size;
984 }
985 free (tmp);
986 return;
987 }
988
989 for (i = 0; i < size; i++)
990 {
991 ptrdiff_t array_offset_dst = 0;
992 ptrdiff_t stride = 1;
993 ptrdiff_t extent = 1;
994 for (j = 0; j < rank-1; j++)
995 {
996 array_offset_dst += ((i / (extent*stride))
997 % (dest->dim[j]._ubound
998 - dest->dim[j].lower_bound + 1))
999 * dest->dim[j]._stride;
1000 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
1001 stride = dest->dim[j]._stride;
1002 }
1003 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
1004 void *dst = (void *)((char *) MEMTOK (token) + offset
1005 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
1006 void *sr;
1007 if (GFC_DESCRIPTOR_RANK (src) != 0)
1008 {
1009 ptrdiff_t array_offset_sr = 0;
1010 stride = 1;
1011 extent = 1;
1012 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
1013 {
1014 array_offset_sr += ((i / (extent*stride))
1015 % (src->dim[j]._ubound
1016 - src->dim[j].lower_bound + 1))
1017 * src->dim[j]._stride;
1018 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
1019 stride = src->dim[j]._stride;
1020 }
1021 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
1022 sr = (void *)((char *) src->base_addr
1023 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
1024 }
1025 else
1026 sr = src->base_addr;
1027
1028 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
1029 && dst_kind == src_kind)
1030 {
1031 memmove (dst, sr,
1032 dst_size > src_size ? src_size : dst_size);
1033 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
1034 {
1035 if (dst_kind == 1)
1036 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
1037 else /* dst_kind == 4. */
1038 for (k = src_size/4; k < dst_size/4; k++)
1039 ((int32_t*) dst)[k] = (int32_t) ' ';
1040 }
1041 }
1042 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
1043 assign_char1_from_char4 (dst_size, src_size, dst, sr);
1044 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
1045 assign_char4_from_char1 (dst_size, src_size, dst, sr);
1046 else
1047 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
1048 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
1049 }
1050 }
1051
1052
1053 void
1054 _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
1055 int dst_image_index, gfc_descriptor_t *dest,
1056 caf_vector_t *dst_vector, caf_token_t src_token,
1057 size_t src_offset,
1058 int src_image_index __attribute__ ((unused)),
1059 gfc_descriptor_t *src,
1060 caf_vector_t *src_vector __attribute__ ((unused)),
1061 int dst_kind, int src_kind, bool may_require_tmp)
1062 {
1063 /* FIXME: Handle vector subscript of 'src_vector'. */
1064 /* For a single image, src->base_addr should be the same as src_token + offset
1065 but to play save, we do it properly. */
1066 void *src_base = GFC_DESCRIPTOR_DATA (src);
1067 GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token)
1068 + src_offset);
1069 _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
1070 src, dst_kind, src_kind, may_require_tmp, NULL);
1071 GFC_DESCRIPTOR_DATA (src) = src_base;
1072 }
1073
1074
1075 /* Emitted when a theorectically unreachable part is reached. */
1076 const char unreachable[] = "Fatal error: unreachable alternative found.\n";
1077
1078
1079 static void
1080 copy_data (void *ds, void *sr, int dst_type, int src_type,
1081 int dst_kind, int src_kind, size_t dst_size, size_t src_size,
1082 size_t num, int *stat)
1083 {
1084 size_t k;
1085 if (dst_type == src_type && dst_kind == src_kind)
1086 {
1087 memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num);
1088 if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
1089 && dst_size > src_size)
1090 {
1091 if (dst_kind == 1)
1092 memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
1093 else /* dst_kind == 4. */
1094 for (k = src_size/4; k < dst_size/4; k++)
1095 ((int32_t*) ds)[k] = (int32_t) ' ';
1096 }
1097 }
1098 else if (dst_type == BT_CHARACTER && dst_kind == 1)
1099 assign_char1_from_char4 (dst_size, src_size, ds, sr);
1100 else if (dst_type == BT_CHARACTER)
1101 assign_char4_from_char1 (dst_size, src_size, ds, sr);
1102 else
1103 for (k = 0; k < num; ++k)
1104 {
1105 convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat);
1106 ds += dst_size;
1107 sr += src_size;
1108 }
1109 }
1110
1111
1112 #define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
1113 do { \
1114 index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
1115 num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
1116 if (num <= 0 || abs_stride < 1) return; \
1117 num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
1118 } while (0)
1119
1120
1121 static void
1122 get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index,
1123 caf_single_token_t single_token, gfc_descriptor_t *dst,
1124 gfc_descriptor_t *src, void *ds, void *sr,
1125 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
1126 size_t num, int *stat)
1127 {
1128 ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
1129 size_t next_dst_dim;
1130
1131 if (unlikely (ref == NULL))
1132 /* May be we should issue an error here, because this case should not
1133 occur. */
1134 return;
1135
1136 if (ref->next == NULL)
1137 {
1138 size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
1139 ptrdiff_t array_offset_dst = 0;;
1140 size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
1141 int src_type = -1;
1142
1143 switch (ref->type)
1144 {
1145 case CAF_REF_COMPONENT:
1146 /* Because the token is always registered after the component, its
1147 offset is always greater zeor. */
1148 if (ref->u.c.caf_token_offset > 0)
1149 copy_data (ds, *(void **)(sr + ref->u.c.offset),
1150 GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst),
1151 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1152 else
1153 copy_data (ds, sr + ref->u.c.offset,
1154 GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src),
1155 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1156 ++(*i);
1157 return;
1158 case CAF_REF_STATIC_ARRAY:
1159 src_type = ref->u.a.static_array_type;
1160 /* Intentionally fall through. */
1161 case CAF_REF_ARRAY:
1162 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1163 {
1164 for (size_t d = 0; d < dst_rank; ++d)
1165 array_offset_dst += dst_index[d];
1166 copy_data (ds + array_offset_dst * dst_size, sr,
1167 GFC_DESCRIPTOR_TYPE (dst),
1168 src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type,
1169 dst_kind, src_kind, dst_size, ref->item_size, num,
1170 stat);
1171 *i += num;
1172 return;
1173 }
1174 break;
1175 default:
1176 caf_runtime_error (unreachable);
1177 }
1178 }
1179
1180 switch (ref->type)
1181 {
1182 case CAF_REF_COMPONENT:
1183 if (ref->u.c.caf_token_offset > 0)
1184 get_for_ref (ref->next, i, dst_index,
1185 *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst,
1186 (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc,
1187 ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0,
1188 1, stat);
1189 else
1190 get_for_ref (ref->next, i, dst_index, single_token, dst,
1191 (gfc_descriptor_t *)(sr + ref->u.c.offset), ds,
1192 sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1,
1193 stat);
1194 return;
1195 case CAF_REF_ARRAY:
1196 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1197 {
1198 get_for_ref (ref->next, i, dst_index, single_token, dst,
1199 src, ds, sr, dst_kind, src_kind,
1200 dst_dim, 0, 1, stat);
1201 return;
1202 }
1203 /* Only when on the left most index switch the data pointer to
1204 the array's data pointer. */
1205 if (src_dim == 0)
1206 sr = GFC_DESCRIPTOR_DATA (src);
1207 switch (ref->u.a.mode[src_dim])
1208 {
1209 case CAF_ARR_REF_VECTOR:
1210 extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]);
1211 array_offset_src = 0;
1212 dst_index[dst_dim] = 0;
1213 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1214 ++idx)
1215 {
1216 #define KINDCASE(kind, type) case kind: \
1217 array_offset_src = (((index_type) \
1218 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
1219 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
1220 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
1221 break
1222
1223 switch (ref->u.a.dim[src_dim].v.kind)
1224 {
1225 KINDCASE (1, GFC_INTEGER_1);
1226 KINDCASE (2, GFC_INTEGER_2);
1227 KINDCASE (4, GFC_INTEGER_4);
1228 #ifdef HAVE_GFC_INTEGER_8
1229 KINDCASE (8, GFC_INTEGER_8);
1230 #endif
1231 #ifdef HAVE_GFC_INTEGER_16
1232 KINDCASE (16, GFC_INTEGER_16);
1233 #endif
1234 default:
1235 caf_runtime_error (unreachable);
1236 return;
1237 }
1238 #undef KINDCASE
1239
1240 get_for_ref (ref, i, dst_index, single_token, dst, src,
1241 ds, sr + array_offset_src * ref->item_size,
1242 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1243 1, stat);
1244 dst_index[dst_dim]
1245 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1246 }
1247 return;
1248 case CAF_ARR_REF_FULL:
1249 COMPUTE_NUM_ITEMS (extent_src,
1250 ref->u.a.dim[src_dim].s.stride,
1251 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1252 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1253 stride_src = src->dim[src_dim]._stride
1254 * ref->u.a.dim[src_dim].s.stride;
1255 array_offset_src = 0;
1256 dst_index[dst_dim] = 0;
1257 for (index_type idx = 0; idx < extent_src;
1258 ++idx, array_offset_src += stride_src)
1259 {
1260 get_for_ref (ref, i, dst_index, single_token, dst, src,
1261 ds, sr + array_offset_src * ref->item_size,
1262 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1263 1, stat);
1264 dst_index[dst_dim]
1265 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1266 }
1267 return;
1268 case CAF_ARR_REF_RANGE:
1269 COMPUTE_NUM_ITEMS (extent_src,
1270 ref->u.a.dim[src_dim].s.stride,
1271 ref->u.a.dim[src_dim].s.start,
1272 ref->u.a.dim[src_dim].s.end);
1273 array_offset_src = (ref->u.a.dim[src_dim].s.start
1274 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1275 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1276 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1277 * ref->u.a.dim[src_dim].s.stride;
1278 dst_index[dst_dim] = 0;
1279 /* Increase the dst_dim only, when the src_extent is greater one
1280 or src and dst extent are both one. Don't increase when the scalar
1281 source is not present in the dst. */
1282 next_dst_dim = extent_src > 1
1283 || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1
1284 && extent_src == 1) ? (dst_dim + 1) : dst_dim;
1285 for (index_type idx = 0; idx < extent_src; ++idx)
1286 {
1287 get_for_ref (ref, i, dst_index, single_token, dst, src,
1288 ds, sr + array_offset_src * ref->item_size,
1289 dst_kind, src_kind, next_dst_dim, src_dim + 1,
1290 1, stat);
1291 dst_index[dst_dim]
1292 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1293 array_offset_src += stride_src;
1294 }
1295 return;
1296 case CAF_ARR_REF_SINGLE:
1297 array_offset_src = (ref->u.a.dim[src_dim].s.start
1298 - src->dim[src_dim].lower_bound)
1299 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1300 dst_index[dst_dim] = 0;
1301 get_for_ref (ref, i, dst_index, single_token, dst, src, ds,
1302 sr + array_offset_src * ref->item_size,
1303 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
1304 stat);
1305 return;
1306 case CAF_ARR_REF_OPEN_END:
1307 COMPUTE_NUM_ITEMS (extent_src,
1308 ref->u.a.dim[src_dim].s.stride,
1309 ref->u.a.dim[src_dim].s.start,
1310 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1311 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1312 * ref->u.a.dim[src_dim].s.stride;
1313 array_offset_src = (ref->u.a.dim[src_dim].s.start
1314 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1315 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1316 dst_index[dst_dim] = 0;
1317 for (index_type idx = 0; idx < extent_src; ++idx)
1318 {
1319 get_for_ref (ref, i, dst_index, single_token, dst, src,
1320 ds, sr + array_offset_src * ref->item_size,
1321 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1322 1, stat);
1323 dst_index[dst_dim]
1324 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1325 array_offset_src += stride_src;
1326 }
1327 return;
1328 case CAF_ARR_REF_OPEN_START:
1329 COMPUTE_NUM_ITEMS (extent_src,
1330 ref->u.a.dim[src_dim].s.stride,
1331 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1332 ref->u.a.dim[src_dim].s.end);
1333 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1334 * ref->u.a.dim[src_dim].s.stride;
1335 array_offset_src = 0;
1336 dst_index[dst_dim] = 0;
1337 for (index_type idx = 0; idx < extent_src; ++idx)
1338 {
1339 get_for_ref (ref, i, dst_index, single_token, dst, src,
1340 ds, sr + array_offset_src * ref->item_size,
1341 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1342 1, stat);
1343 dst_index[dst_dim]
1344 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1345 array_offset_src += stride_src;
1346 }
1347 return;
1348 default:
1349 caf_runtime_error (unreachable);
1350 }
1351 return;
1352 case CAF_REF_STATIC_ARRAY:
1353 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1354 {
1355 get_for_ref (ref->next, i, dst_index, single_token, dst,
1356 NULL, ds, sr, dst_kind, src_kind,
1357 dst_dim, 0, 1, stat);
1358 return;
1359 }
1360 switch (ref->u.a.mode[src_dim])
1361 {
1362 case CAF_ARR_REF_VECTOR:
1363 array_offset_src = 0;
1364 dst_index[dst_dim] = 0;
1365 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1366 ++idx)
1367 {
1368 #define KINDCASE(kind, type) case kind: \
1369 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
1370 break
1371
1372 switch (ref->u.a.dim[src_dim].v.kind)
1373 {
1374 KINDCASE (1, GFC_INTEGER_1);
1375 KINDCASE (2, GFC_INTEGER_2);
1376 KINDCASE (4, GFC_INTEGER_4);
1377 #ifdef HAVE_GFC_INTEGER_8
1378 KINDCASE (8, GFC_INTEGER_8);
1379 #endif
1380 #ifdef HAVE_GFC_INTEGER_16
1381 KINDCASE (16, GFC_INTEGER_16);
1382 #endif
1383 default:
1384 caf_runtime_error (unreachable);
1385 return;
1386 }
1387 #undef KINDCASE
1388
1389 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1390 ds, sr + array_offset_src * ref->item_size,
1391 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1392 1, stat);
1393 dst_index[dst_dim]
1394 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1395 }
1396 return;
1397 case CAF_ARR_REF_FULL:
1398 dst_index[dst_dim] = 0;
1399 for (array_offset_src = 0 ;
1400 array_offset_src <= ref->u.a.dim[src_dim].s.end;
1401 array_offset_src += ref->u.a.dim[src_dim].s.stride)
1402 {
1403 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1404 ds, sr + array_offset_src * ref->item_size,
1405 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1406 1, stat);
1407 dst_index[dst_dim]
1408 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1409 }
1410 return;
1411 case CAF_ARR_REF_RANGE:
1412 COMPUTE_NUM_ITEMS (extent_src,
1413 ref->u.a.dim[src_dim].s.stride,
1414 ref->u.a.dim[src_dim].s.start,
1415 ref->u.a.dim[src_dim].s.end);
1416 array_offset_src = ref->u.a.dim[src_dim].s.start;
1417 dst_index[dst_dim] = 0;
1418 for (index_type idx = 0; idx < extent_src; ++idx)
1419 {
1420 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1421 ds, sr + array_offset_src * ref->item_size,
1422 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
1423 1, stat);
1424 dst_index[dst_dim]
1425 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1426 array_offset_src += ref->u.a.dim[src_dim].s.stride;
1427 }
1428 return;
1429 case CAF_ARR_REF_SINGLE:
1430 array_offset_src = ref->u.a.dim[src_dim].s.start;
1431 get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds,
1432 sr + array_offset_src * ref->item_size,
1433 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
1434 stat);
1435 return;
1436 /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
1437 case CAF_ARR_REF_OPEN_END:
1438 case CAF_ARR_REF_OPEN_START:
1439 default:
1440 caf_runtime_error (unreachable);
1441 }
1442 return;
1443 default:
1444 caf_runtime_error (unreachable);
1445 }
1446 }
1447
1448
1449 void
1450 _gfortran_caf_get_by_ref (caf_token_t token,
1451 int image_index __attribute__ ((unused)),
1452 gfc_descriptor_t *dst, caf_reference_t *refs,
1453 int dst_kind, int src_kind,
1454 bool may_require_tmp __attribute__ ((unused)),
1455 bool dst_reallocatable, int *stat)
1456 {
1457 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
1458 "unknown kind in vector-ref.\n";
1459 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
1460 "unknown reference type.\n";
1461 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
1462 "unknown array reference type.\n";
1463 const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1464 "rank out of range.\n";
1465 const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1466 "extent out of range.\n";
1467 const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
1468 "can not allocate memory.\n";
1469 const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
1470 "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
1471 const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
1472 "two or more array part references are not supported.\n";
1473 size_t size, i;
1474 size_t dst_index[GFC_MAX_DIMENSIONS];
1475 int dst_rank = GFC_DESCRIPTOR_RANK (dst);
1476 int dst_cur_dim = 0;
1477 size_t src_size = 0;
1478 caf_single_token_t single_token = TOKEN (token);
1479 void *memptr = single_token->memptr;
1480 gfc_descriptor_t *src = single_token->desc;
1481 caf_reference_t *riter = refs;
1482 long delta;
1483 /* Reallocation of dst.data is needed (e.g., array to small). */
1484 bool realloc_needed;
1485 /* Reallocation of dst.data is required, because data is not alloced at
1486 all. */
1487 bool realloc_required;
1488 bool extent_mismatch = false;
1489 /* Set when the first non-scalar array reference is encountered. */
1490 bool in_array_ref = false;
1491 bool array_extent_fixed = false;
1492 realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
1493
1494 assert (!realloc_needed || dst_reallocatable);
1495
1496 if (stat)
1497 *stat = 0;
1498
1499 /* Compute the size of the result. In the beginning size just counts the
1500 number of elements. */
1501 size = 1;
1502 while (riter)
1503 {
1504 switch (riter->type)
1505 {
1506 case CAF_REF_COMPONENT:
1507 if (riter->u.c.caf_token_offset)
1508 {
1509 single_token = *(caf_single_token_t*)
1510 (memptr + riter->u.c.caf_token_offset);
1511 memptr = single_token->memptr;
1512 src = single_token->desc;
1513 }
1514 else
1515 {
1516 memptr += riter->u.c.offset;
1517 src = (gfc_descriptor_t *)memptr;
1518 }
1519 break;
1520 case CAF_REF_ARRAY:
1521 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1522 {
1523 switch (riter->u.a.mode[i])
1524 {
1525 case CAF_ARR_REF_VECTOR:
1526 delta = riter->u.a.dim[i].v.nvec;
1527 #define KINDCASE(kind, type) case kind: \
1528 memptr += (((index_type) \
1529 ((type *)riter->u.a.dim[i].v.vector)[0]) \
1530 - GFC_DIMENSION_LBOUND (src->dim[i])) \
1531 * GFC_DIMENSION_STRIDE (src->dim[i]) \
1532 * riter->item_size; \
1533 break
1534
1535 switch (riter->u.a.dim[i].v.kind)
1536 {
1537 KINDCASE (1, GFC_INTEGER_1);
1538 KINDCASE (2, GFC_INTEGER_2);
1539 KINDCASE (4, GFC_INTEGER_4);
1540 #ifdef HAVE_GFC_INTEGER_8
1541 KINDCASE (8, GFC_INTEGER_8);
1542 #endif
1543 #ifdef HAVE_GFC_INTEGER_16
1544 KINDCASE (16, GFC_INTEGER_16);
1545 #endif
1546 default:
1547 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1548 return;
1549 }
1550 #undef KINDCASE
1551 break;
1552 case CAF_ARR_REF_FULL:
1553 COMPUTE_NUM_ITEMS (delta,
1554 riter->u.a.dim[i].s.stride,
1555 GFC_DIMENSION_LBOUND (src->dim[i]),
1556 GFC_DIMENSION_UBOUND (src->dim[i]));
1557 /* The memptr stays unchanged when ref'ing the first element
1558 in a dimension. */
1559 break;
1560 case CAF_ARR_REF_RANGE:
1561 COMPUTE_NUM_ITEMS (delta,
1562 riter->u.a.dim[i].s.stride,
1563 riter->u.a.dim[i].s.start,
1564 riter->u.a.dim[i].s.end);
1565 memptr += (riter->u.a.dim[i].s.start
1566 - GFC_DIMENSION_LBOUND (src->dim[i]))
1567 * GFC_DIMENSION_STRIDE (src->dim[i])
1568 * riter->item_size;
1569 break;
1570 case CAF_ARR_REF_SINGLE:
1571 delta = 1;
1572 memptr += (riter->u.a.dim[i].s.start
1573 - GFC_DIMENSION_LBOUND (src->dim[i]))
1574 * GFC_DIMENSION_STRIDE (src->dim[i])
1575 * riter->item_size;
1576 break;
1577 case CAF_ARR_REF_OPEN_END:
1578 COMPUTE_NUM_ITEMS (delta,
1579 riter->u.a.dim[i].s.stride,
1580 riter->u.a.dim[i].s.start,
1581 GFC_DIMENSION_UBOUND (src->dim[i]));
1582 memptr += (riter->u.a.dim[i].s.start
1583 - GFC_DIMENSION_LBOUND (src->dim[i]))
1584 * GFC_DIMENSION_STRIDE (src->dim[i])
1585 * riter->item_size;
1586 break;
1587 case CAF_ARR_REF_OPEN_START:
1588 COMPUTE_NUM_ITEMS (delta,
1589 riter->u.a.dim[i].s.stride,
1590 GFC_DIMENSION_LBOUND (src->dim[i]),
1591 riter->u.a.dim[i].s.end);
1592 /* The memptr stays unchanged when ref'ing the first element
1593 in a dimension. */
1594 break;
1595 default:
1596 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1597 return;
1598 }
1599 if (delta <= 0)
1600 return;
1601 /* Check the various properties of the destination array.
1602 Is an array expected and present? */
1603 if (delta > 1 && dst_rank == 0)
1604 {
1605 /* No, an array is required, but not provided. */
1606 caf_internal_error (extentoutofrange, stat, NULL, 0);
1607 return;
1608 }
1609 /* When dst is an array. */
1610 if (dst_rank > 0)
1611 {
1612 /* Check that dst_cur_dim is valid for dst. Can be
1613 superceeded only by scalar data. */
1614 if (dst_cur_dim >= dst_rank && delta != 1)
1615 {
1616 caf_internal_error (rankoutofrange, stat, NULL, 0);
1617 return;
1618 }
1619 /* Do further checks, when the source is not scalar. */
1620 else if (delta != 1)
1621 {
1622 /* Check that the extent is not scalar and we are not in
1623 an array ref for the dst side. */
1624 if (!in_array_ref)
1625 {
1626 /* Check that this is the non-scalar extent. */
1627 if (!array_extent_fixed)
1628 {
1629 /* In an array extent now. */
1630 in_array_ref = true;
1631 /* Check that we haven't skipped any scalar
1632 dimensions yet and that the dst is
1633 compatible. */
1634 if (i > 0
1635 && dst_rank == GFC_DESCRIPTOR_RANK (src))
1636 {
1637 if (dst_reallocatable)
1638 {
1639 /* Dst is reallocatable, which means that
1640 the bounds are not set. Set them. */
1641 for (dst_cur_dim= 0; dst_cur_dim < (int)i;
1642 ++dst_cur_dim)
1643 GFC_DIMENSION_SET (dst->dim[dst_cur_dim],
1644 1, 1, 1);
1645 }
1646 else
1647 dst_cur_dim = i;
1648 }
1649 /* Else press thumbs, that there are enough
1650 dimensional refs to come. Checked below. */
1651 }
1652 else
1653 {
1654 caf_internal_error (doublearrayref, stat, NULL,
1655 0);
1656 return;
1657 }
1658 }
1659 /* When the realloc is required, then no extent may have
1660 been set. */
1661 extent_mismatch = realloc_required
1662 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1663 /* When it already known, that a realloc is needed or
1664 the extent does not match the needed one. */
1665 if (realloc_required || realloc_needed
1666 || extent_mismatch)
1667 {
1668 /* Check whether dst is reallocatable. */
1669 if (unlikely (!dst_reallocatable))
1670 {
1671 caf_internal_error (nonallocextentmismatch, stat,
1672 NULL, 0, delta,
1673 GFC_DESCRIPTOR_EXTENT (dst,
1674 dst_cur_dim));
1675 return;
1676 }
1677 /* Only report an error, when the extent needs to be
1678 modified, which is not allowed. */
1679 else if (!dst_reallocatable && extent_mismatch)
1680 {
1681 caf_internal_error (extentoutofrange, stat, NULL,
1682 0);
1683 return;
1684 }
1685 realloc_needed = true;
1686 }
1687 /* Only change the extent when it does not match. This is
1688 to prevent resetting given array bounds. */
1689 if (extent_mismatch)
1690 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1691 size);
1692 }
1693
1694 /* Only increase the dim counter, when in an array ref. */
1695 if (in_array_ref && dst_cur_dim < dst_rank)
1696 ++dst_cur_dim;
1697 }
1698 size *= (index_type)delta;
1699 }
1700 if (in_array_ref)
1701 {
1702 array_extent_fixed = true;
1703 in_array_ref = false;
1704 /* Check, if we got less dimensional refs than the rank of dst
1705 expects. */
1706 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1707 }
1708 break;
1709 case CAF_REF_STATIC_ARRAY:
1710 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1711 {
1712 switch (riter->u.a.mode[i])
1713 {
1714 case CAF_ARR_REF_VECTOR:
1715 delta = riter->u.a.dim[i].v.nvec;
1716 #define KINDCASE(kind, type) case kind: \
1717 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
1718 * riter->item_size; \
1719 break
1720
1721 switch (riter->u.a.dim[i].v.kind)
1722 {
1723 KINDCASE (1, GFC_INTEGER_1);
1724 KINDCASE (2, GFC_INTEGER_2);
1725 KINDCASE (4, GFC_INTEGER_4);
1726 #ifdef HAVE_GFC_INTEGER_8
1727 KINDCASE (8, GFC_INTEGER_8);
1728 #endif
1729 #ifdef HAVE_GFC_INTEGER_16
1730 KINDCASE (16, GFC_INTEGER_16);
1731 #endif
1732 default:
1733 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1734 return;
1735 }
1736 #undef KINDCASE
1737 break;
1738 case CAF_ARR_REF_FULL:
1739 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
1740 + 1;
1741 /* The memptr stays unchanged when ref'ing the first element
1742 in a dimension. */
1743 break;
1744 case CAF_ARR_REF_RANGE:
1745 COMPUTE_NUM_ITEMS (delta,
1746 riter->u.a.dim[i].s.stride,
1747 riter->u.a.dim[i].s.start,
1748 riter->u.a.dim[i].s.end);
1749 memptr += riter->u.a.dim[i].s.start
1750 * riter->u.a.dim[i].s.stride
1751 * riter->item_size;
1752 break;
1753 case CAF_ARR_REF_SINGLE:
1754 delta = 1;
1755 memptr += riter->u.a.dim[i].s.start
1756 * riter->u.a.dim[i].s.stride
1757 * riter->item_size;
1758 break;
1759 case CAF_ARR_REF_OPEN_END:
1760 /* This and OPEN_START are mapped to a RANGE and therefore
1761 can not occur here. */
1762 case CAF_ARR_REF_OPEN_START:
1763 default:
1764 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1765 return;
1766 }
1767 if (delta <= 0)
1768 return;
1769 /* Check the various properties of the destination array.
1770 Is an array expected and present? */
1771 if (delta > 1 && dst_rank == 0)
1772 {
1773 /* No, an array is required, but not provided. */
1774 caf_internal_error (extentoutofrange, stat, NULL, 0);
1775 return;
1776 }
1777 /* When dst is an array. */
1778 if (dst_rank > 0)
1779 {
1780 /* Check that dst_cur_dim is valid for dst. Can be
1781 superceeded only by scalar data. */
1782 if (dst_cur_dim >= dst_rank && delta != 1)
1783 {
1784 caf_internal_error (rankoutofrange, stat, NULL, 0);
1785 return;
1786 }
1787 /* Do further checks, when the source is not scalar. */
1788 else if (delta != 1)
1789 {
1790 /* Check that the extent is not scalar and we are not in
1791 an array ref for the dst side. */
1792 if (!in_array_ref)
1793 {
1794 /* Check that this is the non-scalar extent. */
1795 if (!array_extent_fixed)
1796 {
1797 /* In an array extent now. */
1798 in_array_ref = true;
1799 /* The dst is not reallocatable, so nothing more
1800 to do, then correct the dim counter. */
1801 dst_cur_dim = i;
1802 }
1803 else
1804 {
1805 caf_internal_error (doublearrayref, stat, NULL,
1806 0);
1807 return;
1808 }
1809 }
1810 /* When the realloc is required, then no extent may have
1811 been set. */
1812 extent_mismatch = realloc_required
1813 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1814 /* When it is already known, that a realloc is needed or
1815 the extent does not match the needed one. */
1816 if (realloc_required || realloc_needed
1817 || extent_mismatch)
1818 {
1819 /* Check whether dst is reallocatable. */
1820 if (unlikely (!dst_reallocatable))
1821 {
1822 caf_internal_error (nonallocextentmismatch, stat,
1823 NULL, 0, delta,
1824 GFC_DESCRIPTOR_EXTENT (dst,
1825 dst_cur_dim));
1826 return;
1827 }
1828 /* Only report an error, when the extent needs to be
1829 modified, which is not allowed. */
1830 else if (!dst_reallocatable && extent_mismatch)
1831 {
1832 caf_internal_error (extentoutofrange, stat, NULL,
1833 0);
1834 return;
1835 }
1836 realloc_needed = true;
1837 }
1838 /* Only change the extent when it does not match. This is
1839 to prevent resetting given array bounds. */
1840 if (extent_mismatch)
1841 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1842 size);
1843 }
1844 /* Only increase the dim counter, when in an array ref. */
1845 if (in_array_ref && dst_cur_dim < dst_rank)
1846 ++dst_cur_dim;
1847 }
1848 size *= (index_type)delta;
1849 }
1850 if (in_array_ref)
1851 {
1852 array_extent_fixed = true;
1853 in_array_ref = false;
1854 /* Check, if we got less dimensional refs than the rank of dst
1855 expects. */
1856 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1857 }
1858 break;
1859 default:
1860 caf_internal_error (unknownreftype, stat, NULL, 0);
1861 return;
1862 }
1863 src_size = riter->item_size;
1864 riter = riter->next;
1865 }
1866 if (size == 0 || src_size == 0)
1867 return;
1868 /* Postcondition:
1869 - size contains the number of elements to store in the destination array,
1870 - src_size gives the size in bytes of each item in the destination array.
1871 */
1872
1873 if (realloc_needed)
1874 {
1875 if (!array_extent_fixed)
1876 {
1877 assert (size == 1);
1878 /* This can happen only, when the result is scalar. */
1879 for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim)
1880 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1);
1881 }
1882
1883 GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
1884 if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL))
1885 {
1886 caf_internal_error (cannotallocdst, stat, NULL, 0);
1887 return;
1888 }
1889 }
1890
1891 /* Reset the token. */
1892 single_token = TOKEN (token);
1893 memptr = single_token->memptr;
1894 src = single_token->desc;
1895 memset(dst_index, 0, sizeof (dst_index));
1896 i = 0;
1897 get_for_ref (refs, &i, dst_index, single_token, dst, src,
1898 GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0,
1899 1, stat);
1900 }
1901
1902
1903 static void
1904 send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
1905 caf_single_token_t single_token, gfc_descriptor_t *dst,
1906 gfc_descriptor_t *src, void *ds, void *sr,
1907 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
1908 size_t num, size_t size, int *stat)
1909 {
1910 const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
1911 "unknown kind in vector-ref.\n";
1912 ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst;
1913 const size_t src_rank = GFC_DESCRIPTOR_RANK (src);
1914
1915 if (unlikely (ref == NULL))
1916 /* May be we should issue an error here, because this case should not
1917 occur. */
1918 return;
1919
1920 if (ref->next == NULL)
1921 {
1922 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
1923 ptrdiff_t array_offset_src = 0;;
1924 int dst_type = -1;
1925
1926 switch (ref->type)
1927 {
1928 case CAF_REF_COMPONENT:
1929 if (ref->u.c.caf_token_offset > 0)
1930 {
1931 if (*(void**)(ds + ref->u.c.offset) == NULL)
1932 {
1933 /* Create a scalar temporary array descriptor. */
1934 gfc_descriptor_t static_dst;
1935 GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
1936 GFC_DESCRIPTOR_DTYPE (&static_dst)
1937 = GFC_DESCRIPTOR_DTYPE (src);
1938 /* The component can be allocated now, because it is a
1939 scalar. */
1940 _gfortran_caf_register (ref->item_size,
1941 CAF_REGTYPE_COARRAY_ALLOC,
1942 ds + ref->u.c.caf_token_offset,
1943 &static_dst, stat, NULL, 0);
1944 single_token = *(caf_single_token_t *)
1945 (ds + ref->u.c.caf_token_offset);
1946 /* In case of an error in allocation return. When stat is
1947 NULL, then register_component() terminates on error. */
1948 if (stat != NULL && *stat)
1949 return;
1950 /* Publish the allocated memory. */
1951 *((void **)(ds + ref->u.c.offset))
1952 = GFC_DESCRIPTOR_DATA (&static_dst);
1953 ds = GFC_DESCRIPTOR_DATA (&static_dst);
1954 /* Set the type from the src. */
1955 dst_type = GFC_DESCRIPTOR_TYPE (src);
1956 }
1957 else
1958 {
1959 single_token = *(caf_single_token_t *)
1960 (ds + ref->u.c.caf_token_offset);
1961 dst = single_token->desc;
1962 if (dst)
1963 {
1964 ds = GFC_DESCRIPTOR_DATA (dst);
1965 dst_type = GFC_DESCRIPTOR_TYPE (dst);
1966 }
1967 else
1968 {
1969 /* When no destination descriptor is present, assume that
1970 source and dest type are identical. */
1971 dst_type = GFC_DESCRIPTOR_TYPE (src);
1972 ds = *(void **)(ds + ref->u.c.offset);
1973 }
1974 }
1975 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
1976 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
1977 }
1978 else
1979 copy_data (ds + ref->u.c.offset, sr,
1980 dst != NULL ? GFC_DESCRIPTOR_TYPE (dst)
1981 : GFC_DESCRIPTOR_TYPE (src),
1982 GFC_DESCRIPTOR_TYPE (src),
1983 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
1984 ++(*i);
1985 return;
1986 case CAF_REF_STATIC_ARRAY:
1987 dst_type = ref->u.a.static_array_type;
1988 /* Intentionally fall through. */
1989 case CAF_REF_ARRAY:
1990 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
1991 {
1992 if (src_rank > 0)
1993 {
1994 for (size_t d = 0; d < src_rank; ++d)
1995 array_offset_src += src_index[d];
1996 copy_data (ds, sr + array_offset_src * ref->item_size,
1997 dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
1998 : dst_type,
1999 GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
2000 ref->item_size, src_size, num, stat);
2001 }
2002 else
2003 copy_data (ds, sr,
2004 dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
2005 : dst_type,
2006 GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
2007 ref->item_size, src_size, num, stat);
2008 *i += num;
2009 return;
2010 }
2011 break;
2012 default:
2013 caf_runtime_error (unreachable);
2014 }
2015 }
2016
2017 switch (ref->type)
2018 {
2019 case CAF_REF_COMPONENT:
2020 if (ref->u.c.caf_token_offset > 0)
2021 {
2022 if (*(void**)(ds + ref->u.c.offset) == NULL)
2023 {
2024 /* This component refs an unallocated array. Non-arrays are
2025 caught in the if (!ref->next) above. */
2026 dst = (gfc_descriptor_t *)(ds + ref->u.c.offset);
2027 /* Assume that the rank and the dimensions fit for copying src
2028 to dst. */
2029 GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
2030 dst->offset = 0;
2031 stride_dst = 1;
2032 for (size_t d = 0; d < src_rank; ++d)
2033 {
2034 extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
2035 GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
2036 GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
2037 GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
2038 stride_dst *= extent_dst;
2039 }
2040 /* Null the data-pointer to make register_component allocate
2041 its own memory. */
2042 GFC_DESCRIPTOR_DATA (dst) = NULL;
2043
2044 /* The size of the array is given by size. */
2045 _gfortran_caf_register (size * ref->item_size,
2046 CAF_REGTYPE_COARRAY_ALLOC,
2047 ds + ref->u.c.caf_token_offset,
2048 dst, stat, NULL, 0);
2049 /* In case of an error in allocation return. When stat is
2050 NULL, then register_component() terminates on error. */
2051 if (stat != NULL && *stat)
2052 return;
2053 }
2054 single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
2055 send_by_ref (ref->next, i, src_index, single_token,
2056 single_token->desc, src, ds + ref->u.c.offset, sr,
2057 dst_kind, src_kind, 0, src_dim, 1, size, stat);
2058 }
2059 else
2060 send_by_ref (ref->next, i, src_index, single_token,
2061 (gfc_descriptor_t *)(ds + ref->u.c.offset), src,
2062 ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim,
2063 1, size, stat);
2064 return;
2065 case CAF_REF_ARRAY:
2066 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2067 {
2068 send_by_ref (ref->next, i, src_index, single_token,
2069 (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind,
2070 0, src_dim, 1, size, stat);
2071 return;
2072 }
2073 /* Only when on the left most index switch the data pointer to
2074 the array's data pointer. And only for non-static arrays. */
2075 if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
2076 ds = GFC_DESCRIPTOR_DATA (dst);
2077 switch (ref->u.a.mode[dst_dim])
2078 {
2079 case CAF_ARR_REF_VECTOR:
2080 array_offset_dst = 0;
2081 src_index[src_dim] = 0;
2082 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2083 ++idx)
2084 {
2085 #define KINDCASE(kind, type) case kind: \
2086 array_offset_dst = (((index_type) \
2087 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
2088 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
2089 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
2090 break
2091
2092 switch (ref->u.a.dim[dst_dim].v.kind)
2093 {
2094 KINDCASE (1, GFC_INTEGER_1);
2095 KINDCASE (2, GFC_INTEGER_2);
2096 KINDCASE (4, GFC_INTEGER_4);
2097 #ifdef HAVE_GFC_INTEGER_8
2098 KINDCASE (8, GFC_INTEGER_8);
2099 #endif
2100 #ifdef HAVE_GFC_INTEGER_16
2101 KINDCASE (16, GFC_INTEGER_16);
2102 #endif
2103 default:
2104 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2105 return;
2106 }
2107 #undef KINDCASE
2108
2109 send_by_ref (ref, i, src_index, single_token, dst, src,
2110 ds + array_offset_dst * ref->item_size, sr,
2111 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2112 1, size, stat);
2113 if (src_rank > 0)
2114 src_index[src_dim]
2115 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2116 }
2117 return;
2118 case CAF_ARR_REF_FULL:
2119 COMPUTE_NUM_ITEMS (extent_dst,
2120 ref->u.a.dim[dst_dim].s.stride,
2121 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2122 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2123 array_offset_dst = 0;
2124 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2125 * ref->u.a.dim[dst_dim].s.stride;
2126 src_index[src_dim] = 0;
2127 for (index_type idx = 0; idx < extent_dst;
2128 ++idx, array_offset_dst += stride_dst)
2129 {
2130 send_by_ref (ref, i, src_index, single_token, dst, src,
2131 ds + array_offset_dst * ref->item_size, sr,
2132 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2133 1, size, stat);
2134 if (src_rank > 0)
2135 src_index[src_dim]
2136 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2137 }
2138 return;
2139 case CAF_ARR_REF_RANGE:
2140 COMPUTE_NUM_ITEMS (extent_dst,
2141 ref->u.a.dim[dst_dim].s.stride,
2142 ref->u.a.dim[dst_dim].s.start,
2143 ref->u.a.dim[dst_dim].s.end);
2144 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2145 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2146 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2147 * ref->u.a.dim[dst_dim].s.stride;
2148 src_index[src_dim] = 0;
2149 for (index_type idx = 0; idx < extent_dst; ++idx)
2150 {
2151 send_by_ref (ref, i, src_index, single_token, dst, src,
2152 ds + array_offset_dst * ref->item_size, sr,
2153 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2154 1, size, stat);
2155 if (src_rank > 0)
2156 src_index[src_dim]
2157 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2158 array_offset_dst += stride_dst;
2159 }
2160 return;
2161 case CAF_ARR_REF_SINGLE:
2162 array_offset_dst = (ref->u.a.dim[dst_dim].s.start
2163 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]))
2164 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
2165 send_by_ref (ref, i, src_index, single_token, dst, src, ds
2166 + array_offset_dst * ref->item_size, sr,
2167 dst_kind, src_kind, dst_dim + 1, src_dim, 1,
2168 size, stat);
2169 return;
2170 case CAF_ARR_REF_OPEN_END:
2171 COMPUTE_NUM_ITEMS (extent_dst,
2172 ref->u.a.dim[dst_dim].s.stride,
2173 ref->u.a.dim[dst_dim].s.start,
2174 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2175 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2176 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2177 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2178 * ref->u.a.dim[dst_dim].s.stride;
2179 src_index[src_dim] = 0;
2180 for (index_type idx = 0; idx < extent_dst; ++idx)
2181 {
2182 send_by_ref (ref, i, src_index, single_token, dst, src,
2183 ds + array_offset_dst * ref->item_size, sr,
2184 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2185 1, size, stat);
2186 if (src_rank > 0)
2187 src_index[src_dim]
2188 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2189 array_offset_dst += stride_dst;
2190 }
2191 return;
2192 case CAF_ARR_REF_OPEN_START:
2193 COMPUTE_NUM_ITEMS (extent_dst,
2194 ref->u.a.dim[dst_dim].s.stride,
2195 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2196 ref->u.a.dim[dst_dim].s.end);
2197 array_offset_dst = 0;
2198 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2199 * ref->u.a.dim[dst_dim].s.stride;
2200 src_index[src_dim] = 0;
2201 for (index_type idx = 0; idx < extent_dst; ++idx)
2202 {
2203 send_by_ref (ref, i, src_index, single_token, dst, src,
2204 ds + array_offset_dst * ref->item_size, sr,
2205 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2206 1, size, stat);
2207 if (src_rank > 0)
2208 src_index[src_dim]
2209 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2210 array_offset_dst += stride_dst;
2211 }
2212 return;
2213 default:
2214 caf_runtime_error (unreachable);
2215 }
2216 return;
2217 case CAF_REF_STATIC_ARRAY:
2218 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2219 {
2220 send_by_ref (ref->next, i, src_index, single_token, NULL,
2221 src, ds, sr, dst_kind, src_kind,
2222 0, src_dim, 1, size, stat);
2223 return;
2224 }
2225 switch (ref->u.a.mode[dst_dim])
2226 {
2227 case CAF_ARR_REF_VECTOR:
2228 array_offset_dst = 0;
2229 src_index[src_dim] = 0;
2230 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2231 ++idx)
2232 {
2233 #define KINDCASE(kind, type) case kind: \
2234 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
2235 break
2236
2237 switch (ref->u.a.dim[dst_dim].v.kind)
2238 {
2239 KINDCASE (1, GFC_INTEGER_1);
2240 KINDCASE (2, GFC_INTEGER_2);
2241 KINDCASE (4, GFC_INTEGER_4);
2242 #ifdef HAVE_GFC_INTEGER_8
2243 KINDCASE (8, GFC_INTEGER_8);
2244 #endif
2245 #ifdef HAVE_GFC_INTEGER_16
2246 KINDCASE (16, GFC_INTEGER_16);
2247 #endif
2248 default:
2249 caf_runtime_error (unreachable);
2250 return;
2251 }
2252 #undef KINDCASE
2253
2254 send_by_ref (ref, i, src_index, single_token, NULL, src,
2255 ds + array_offset_dst * ref->item_size, sr,
2256 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2257 1, size, stat);
2258 src_index[src_dim]
2259 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2260 }
2261 return;
2262 case CAF_ARR_REF_FULL:
2263 src_index[src_dim] = 0;
2264 for (array_offset_dst = 0 ;
2265 array_offset_dst <= ref->u.a.dim[dst_dim].s.end;
2266 array_offset_dst += ref->u.a.dim[dst_dim].s.stride)
2267 {
2268 send_by_ref (ref, i, src_index, single_token, NULL, src,
2269 ds + array_offset_dst * ref->item_size, sr,
2270 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2271 1, size, stat);
2272 if (src_rank > 0)
2273 src_index[src_dim]
2274 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2275 }
2276 return;
2277 case CAF_ARR_REF_RANGE:
2278 COMPUTE_NUM_ITEMS (extent_dst,
2279 ref->u.a.dim[dst_dim].s.stride,
2280 ref->u.a.dim[dst_dim].s.start,
2281 ref->u.a.dim[dst_dim].s.end);
2282 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
2283 src_index[src_dim] = 0;
2284 for (index_type idx = 0; idx < extent_dst; ++idx)
2285 {
2286 send_by_ref (ref, i, src_index, single_token, NULL, src,
2287 ds + array_offset_dst * ref->item_size, sr,
2288 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
2289 1, size, stat);
2290 if (src_rank > 0)
2291 src_index[src_dim]
2292 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2293 array_offset_dst += ref->u.a.dim[dst_dim].s.stride;
2294 }
2295 return;
2296 case CAF_ARR_REF_SINGLE:
2297 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
2298 send_by_ref (ref, i, src_index, single_token, NULL, src,
2299 ds + array_offset_dst * ref->item_size, sr,
2300 dst_kind, src_kind, dst_dim + 1, src_dim, 1,
2301 size, stat);
2302 return;
2303 /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
2304 case CAF_ARR_REF_OPEN_END:
2305 case CAF_ARR_REF_OPEN_START:
2306 default:
2307 caf_runtime_error (unreachable);
2308 }
2309 return;
2310 default:
2311 caf_runtime_error (unreachable);
2312 }
2313 }
2314
2315
2316 void
2317 _gfortran_caf_send_by_ref (caf_token_t token,
2318 int image_index __attribute__ ((unused)),
2319 gfc_descriptor_t *src, caf_reference_t *refs,
2320 int dst_kind, int src_kind,
2321 bool may_require_tmp __attribute__ ((unused)),
2322 bool dst_reallocatable, int *stat)
2323 {
2324 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
2325 "unknown kind in vector-ref.\n";
2326 const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): "
2327 "unknown reference type.\n";
2328 const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): "
2329 "unknown array reference type.\n";
2330 const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): "
2331 "rank out of range.\n";
2332 const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): "
2333 "reallocation of array followed by component ref not allowed.\n";
2334 const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): "
2335 "can not allocate memory.\n";
2336 const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): "
2337 "extent of non-allocatable array mismatch.\n";
2338 const char innercompref[] = "libcaf_single::caf_send_by_ref(): "
2339 "inner unallocated component detected.\n";
2340 size_t size, i;
2341 size_t dst_index[GFC_MAX_DIMENSIONS];
2342 int src_rank = GFC_DESCRIPTOR_RANK (src);
2343 int src_cur_dim = 0;
2344 size_t src_size = 0;
2345 caf_single_token_t single_token = TOKEN (token);
2346 void *memptr = single_token->memptr;
2347 gfc_descriptor_t *dst = single_token->desc;
2348 caf_reference_t *riter = refs;
2349 long delta;
2350 bool extent_mismatch;
2351 /* Note that the component is not allocated yet. */
2352 index_type new_component_idx = -1;
2353
2354 if (stat)
2355 *stat = 0;
2356
2357 /* Compute the size of the result. In the beginning size just counts the
2358 number of elements. */
2359 size = 1;
2360 while (riter)
2361 {
2362 switch (riter->type)
2363 {
2364 case CAF_REF_COMPONENT:
2365 if (unlikely (new_component_idx != -1))
2366 {
2367 /* Allocating a component in the middle of a component ref is not
2368 support. We don't know the type to allocate. */
2369 caf_internal_error (innercompref, stat, NULL, 0);
2370 return;
2371 }
2372 if (riter->u.c.caf_token_offset > 0)
2373 {
2374 /* Check whether the allocatable component is zero, then no
2375 token is present, too. The token's pointer is not cleared
2376 when the structure is initialized. */
2377 if (*(void**)(memptr + riter->u.c.offset) == NULL)
2378 {
2379 /* This component is not yet allocated. Check that it is
2380 allocatable here. */
2381 if (!dst_reallocatable)
2382 {
2383 caf_internal_error (cannotallocdst, stat, NULL, 0);
2384 return;
2385 }
2386 single_token = NULL;
2387 memptr = NULL;
2388 dst = NULL;
2389 break;
2390 }
2391 single_token = *(caf_single_token_t*)
2392 (memptr + riter->u.c.caf_token_offset);
2393 memptr += riter->u.c.offset;
2394 dst = single_token->desc;
2395 }
2396 else
2397 {
2398 /* Regular component. */
2399 memptr += riter->u.c.offset;
2400 dst = (gfc_descriptor_t *)memptr;
2401 }
2402 break;
2403 case CAF_REF_ARRAY:
2404 if (dst != NULL)
2405 memptr = GFC_DESCRIPTOR_DATA (dst);
2406 else
2407 dst = src;
2408 /* When the dst array needs to be allocated, then look at the
2409 extent of the source array in the dimension dst_cur_dim. */
2410 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2411 {
2412 switch (riter->u.a.mode[i])
2413 {
2414 case CAF_ARR_REF_VECTOR:
2415 delta = riter->u.a.dim[i].v.nvec;
2416 #define KINDCASE(kind, type) case kind: \
2417 memptr += (((index_type) \
2418 ((type *)riter->u.a.dim[i].v.vector)[0]) \
2419 - GFC_DIMENSION_LBOUND (dst->dim[i])) \
2420 * GFC_DIMENSION_STRIDE (dst->dim[i]) \
2421 * riter->item_size; \
2422 break
2423
2424 switch (riter->u.a.dim[i].v.kind)
2425 {
2426 KINDCASE (1, GFC_INTEGER_1);
2427 KINDCASE (2, GFC_INTEGER_2);
2428 KINDCASE (4, GFC_INTEGER_4);
2429 #ifdef HAVE_GFC_INTEGER_8
2430 KINDCASE (8, GFC_INTEGER_8);
2431 #endif
2432 #ifdef HAVE_GFC_INTEGER_16
2433 KINDCASE (16, GFC_INTEGER_16);
2434 #endif
2435 default:
2436 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2437 return;
2438 }
2439 #undef KINDCASE
2440 break;
2441 case CAF_ARR_REF_FULL:
2442 if (dst)
2443 COMPUTE_NUM_ITEMS (delta,
2444 riter->u.a.dim[i].s.stride,
2445 GFC_DIMENSION_LBOUND (dst->dim[i]),
2446 GFC_DIMENSION_UBOUND (dst->dim[i]));
2447 else
2448 COMPUTE_NUM_ITEMS (delta,
2449 riter->u.a.dim[i].s.stride,
2450 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2451 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2452 break;
2453 case CAF_ARR_REF_RANGE:
2454 COMPUTE_NUM_ITEMS (delta,
2455 riter->u.a.dim[i].s.stride,
2456 riter->u.a.dim[i].s.start,
2457 riter->u.a.dim[i].s.end);
2458 memptr += (riter->u.a.dim[i].s.start
2459 - dst->dim[i].lower_bound)
2460 * GFC_DIMENSION_STRIDE (dst->dim[i])
2461 * riter->item_size;
2462 break;
2463 case CAF_ARR_REF_SINGLE:
2464 delta = 1;
2465 memptr += (riter->u.a.dim[i].s.start
2466 - dst->dim[i].lower_bound)
2467 * GFC_DIMENSION_STRIDE (dst->dim[i])
2468 * riter->item_size;
2469 break;
2470 case CAF_ARR_REF_OPEN_END:
2471 if (dst)
2472 COMPUTE_NUM_ITEMS (delta,
2473 riter->u.a.dim[i].s.stride,
2474 riter->u.a.dim[i].s.start,
2475 GFC_DIMENSION_UBOUND (dst->dim[i]));
2476 else
2477 COMPUTE_NUM_ITEMS (delta,
2478 riter->u.a.dim[i].s.stride,
2479 riter->u.a.dim[i].s.start,
2480 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2481 memptr += (riter->u.a.dim[i].s.start
2482 - dst->dim[i].lower_bound)
2483 * GFC_DIMENSION_STRIDE (dst->dim[i])
2484 * riter->item_size;
2485 break;
2486 case CAF_ARR_REF_OPEN_START:
2487 if (dst)
2488 COMPUTE_NUM_ITEMS (delta,
2489 riter->u.a.dim[i].s.stride,
2490 GFC_DIMENSION_LBOUND (dst->dim[i]),
2491 riter->u.a.dim[i].s.end);
2492 else
2493 COMPUTE_NUM_ITEMS (delta,
2494 riter->u.a.dim[i].s.stride,
2495 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2496 riter->u.a.dim[i].s.end);
2497 /* The memptr stays unchanged when ref'ing the first element
2498 in a dimension. */
2499 break;
2500 default:
2501 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2502 return;
2503 }
2504
2505 if (delta <= 0)
2506 return;
2507 /* Check the various properties of the source array.
2508 When src is an array. */
2509 if (delta > 1 && src_rank > 0)
2510 {
2511 /* Check that src_cur_dim is valid for src. Can be
2512 superceeded only by scalar data. */
2513 if (src_cur_dim >= src_rank)
2514 {
2515 caf_internal_error (rankoutofrange, stat, NULL, 0);
2516 return;
2517 }
2518 /* Do further checks, when the source is not scalar. */
2519 else
2520 {
2521 /* When the realloc is required, then no extent may have
2522 been set. */
2523 extent_mismatch = memptr == NULL
2524 || (dst
2525 && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim)
2526 != delta);
2527 /* When it already known, that a realloc is needed or
2528 the extent does not match the needed one. */
2529 if (extent_mismatch)
2530 {
2531 /* Check whether dst is reallocatable. */
2532 if (unlikely (!dst_reallocatable))
2533 {
2534 caf_internal_error (nonallocextentmismatch, stat,
2535 NULL, 0, delta,
2536 GFC_DESCRIPTOR_EXTENT (dst,
2537 src_cur_dim));
2538 return;
2539 }
2540 /* Report error on allocatable but missing inner
2541 ref. */
2542 else if (riter->next != NULL)
2543 {
2544 caf_internal_error (realloconinnerref, stat, NULL,
2545 0);
2546 return;
2547 }
2548 }
2549 /* Only change the extent when it does not match. This is
2550 to prevent resetting given array bounds. */
2551 if (extent_mismatch)
2552 GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta,
2553 size);
2554 }
2555 /* Increase the dim-counter of the src only when the extent
2556 matches. */
2557 if (src_cur_dim < src_rank
2558 && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta)
2559 ++src_cur_dim;
2560 }
2561 size *= (index_type)delta;
2562 }
2563 break;
2564 case CAF_REF_STATIC_ARRAY:
2565 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2566 {
2567 switch (riter->u.a.mode[i])
2568 {
2569 case CAF_ARR_REF_VECTOR:
2570 delta = riter->u.a.dim[i].v.nvec;
2571 #define KINDCASE(kind, type) case kind: \
2572 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
2573 * riter->item_size; \
2574 break
2575
2576 switch (riter->u.a.dim[i].v.kind)
2577 {
2578 KINDCASE (1, GFC_INTEGER_1);
2579 KINDCASE (2, GFC_INTEGER_2);
2580 KINDCASE (4, GFC_INTEGER_4);
2581 #ifdef HAVE_GFC_INTEGER_8
2582 KINDCASE (8, GFC_INTEGER_8);
2583 #endif
2584 #ifdef HAVE_GFC_INTEGER_16
2585 KINDCASE (16, GFC_INTEGER_16);
2586 #endif
2587 default:
2588 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2589 return;
2590 }
2591 #undef KINDCASE
2592 break;
2593 case CAF_ARR_REF_FULL:
2594 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
2595 + 1;
2596 /* The memptr stays unchanged when ref'ing the first element
2597 in a dimension. */
2598 break;
2599 case CAF_ARR_REF_RANGE:
2600 COMPUTE_NUM_ITEMS (delta,
2601 riter->u.a.dim[i].s.stride,
2602 riter->u.a.dim[i].s.start,
2603 riter->u.a.dim[i].s.end);
2604 memptr += riter->u.a.dim[i].s.start
2605 * riter->u.a.dim[i].s.stride
2606 * riter->item_size;
2607 break;
2608 case CAF_ARR_REF_SINGLE:
2609 delta = 1;
2610 memptr += riter->u.a.dim[i].s.start
2611 * riter->u.a.dim[i].s.stride
2612 * riter->item_size;
2613 break;
2614 case CAF_ARR_REF_OPEN_END:
2615 /* This and OPEN_START are mapped to a RANGE and therefore
2616 can not occur here. */
2617 case CAF_ARR_REF_OPEN_START:
2618 default:
2619 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2620 return;
2621 }
2622 if (delta <= 0)
2623 return;
2624 /* Check the various properties of the source array.
2625 Only when the source array is not scalar examine its
2626 properties. */
2627 if (delta > 1 && src_rank > 0)
2628 {
2629 /* Check that src_cur_dim is valid for src. Can be
2630 superceeded only by scalar data. */
2631 if (src_cur_dim >= src_rank)
2632 {
2633 caf_internal_error (rankoutofrange, stat, NULL, 0);
2634 return;
2635 }
2636 else
2637 {
2638 /* We will not be able to realloc the dst, because that's
2639 a fixed size array. */
2640 extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim)
2641 != delta;
2642 /* When the extent does not match the needed one we can
2643 only stop here. */
2644 if (extent_mismatch)
2645 {
2646 caf_internal_error (nonallocextentmismatch, stat,
2647 NULL, 0, delta,
2648 GFC_DESCRIPTOR_EXTENT (src,
2649 src_cur_dim));
2650 return;
2651 }
2652 }
2653 ++src_cur_dim;
2654 }
2655 size *= (index_type)delta;
2656 }
2657 break;
2658 default:
2659 caf_internal_error (unknownreftype, stat, NULL, 0);
2660 return;
2661 }
2662 src_size = riter->item_size;
2663 riter = riter->next;
2664 }
2665 if (size == 0 || src_size == 0)
2666 return;
2667 /* Postcondition:
2668 - size contains the number of elements to store in the destination array,
2669 - src_size gives the size in bytes of each item in the destination array.
2670 */
2671
2672 /* Reset the token. */
2673 single_token = TOKEN (token);
2674 memptr = single_token->memptr;
2675 dst = single_token->desc;
2676 memset (dst_index, 0, sizeof (dst_index));
2677 i = 0;
2678 send_by_ref (refs, &i, dst_index, single_token, dst, src,
2679 memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0,
2680 1, size, stat);
2681 assert (i == size);
2682 }
2683
2684
2685 void
2686 _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index,
2687 caf_reference_t *dst_refs, caf_token_t src_token,
2688 int src_image_index,
2689 caf_reference_t *src_refs, int dst_kind,
2690 int src_kind, bool may_require_tmp, int *dst_stat,
2691 int *src_stat)
2692 {
2693 gfc_array_void temp;
2694
2695 _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs,
2696 dst_kind, src_kind, may_require_tmp, true,
2697 src_stat);
2698
2699 if (src_stat && *src_stat != 0)
2700 return;
2701
2702 _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs,
2703 dst_kind, src_kind, may_require_tmp, true,
2704 dst_stat);
2705 if (GFC_DESCRIPTOR_DATA (&temp))
2706 free (GFC_DESCRIPTOR_DATA (&temp));
2707 }
2708
2709
2710 void
2711 _gfortran_caf_atomic_define (caf_token_t token, size_t offset,
2712 int image_index __attribute__ ((unused)),
2713 void *value, int *stat,
2714 int type __attribute__ ((unused)), int kind)
2715 {
2716 assert(kind == 4);
2717
2718 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2719
2720 __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2721
2722 if (stat)
2723 *stat = 0;
2724 }
2725
2726 void
2727 _gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
2728 int image_index __attribute__ ((unused)),
2729 void *value, int *stat,
2730 int type __attribute__ ((unused)), int kind)
2731 {
2732 assert(kind == 4);
2733
2734 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2735
2736 __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2737
2738 if (stat)
2739 *stat = 0;
2740 }
2741
2742
2743 void
2744 _gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
2745 int image_index __attribute__ ((unused)),
2746 void *old, void *compare, void *new_val, int *stat,
2747 int type __attribute__ ((unused)), int kind)
2748 {
2749 assert(kind == 4);
2750
2751 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2752
2753 *(uint32_t *) old = *(uint32_t *) compare;
2754 (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
2755 *(uint32_t *) new_val, false,
2756 __ATOMIC_RELAXED, __ATOMIC_RELAXED);
2757 if (stat)
2758 *stat = 0;
2759 }
2760
2761
2762 void
2763 _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
2764 int image_index __attribute__ ((unused)),
2765 void *value, void *old, int *stat,
2766 int type __attribute__ ((unused)), int kind)
2767 {
2768 assert(kind == 4);
2769
2770 uint32_t res;
2771 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
2772
2773 switch (op)
2774 {
2775 case GFC_CAF_ATOMIC_ADD:
2776 res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2777 break;
2778 case GFC_CAF_ATOMIC_AND:
2779 res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2780 break;
2781 case GFC_CAF_ATOMIC_OR:
2782 res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2783 break;
2784 case GFC_CAF_ATOMIC_XOR:
2785 res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2786 break;
2787 default:
2788 __builtin_unreachable();
2789 }
2790
2791 if (old)
2792 *(uint32_t *) old = res;
2793
2794 if (stat)
2795 *stat = 0;
2796 }
2797
2798 void
2799 _gfortran_caf_event_post (caf_token_t token, size_t index,
2800 int image_index __attribute__ ((unused)),
2801 int *stat, char *errmsg __attribute__ ((unused)),
2802 int errmsg_len __attribute__ ((unused)))
2803 {
2804 uint32_t value = 1;
2805 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2806 * sizeof (uint32_t));
2807 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2808
2809 if(stat)
2810 *stat = 0;
2811 }
2812
2813 void
2814 _gfortran_caf_event_wait (caf_token_t token, size_t index,
2815 int until_count, int *stat,
2816 char *errmsg __attribute__ ((unused)),
2817 int errmsg_len __attribute__ ((unused)))
2818 {
2819 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2820 * sizeof (uint32_t));
2821 uint32_t value = (uint32_t)-until_count;
2822 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2823
2824 if(stat)
2825 *stat = 0;
2826 }
2827
2828 void
2829 _gfortran_caf_event_query (caf_token_t token, size_t index,
2830 int image_index __attribute__ ((unused)),
2831 int *count, int *stat)
2832 {
2833 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2834 * sizeof (uint32_t));
2835 __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
2836
2837 if(stat)
2838 *stat = 0;
2839 }
2840
2841 void
2842 _gfortran_caf_lock (caf_token_t token, size_t index,
2843 int image_index __attribute__ ((unused)),
2844 int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
2845 {
2846 const char *msg = "Already locked";
2847 bool *lock = &((bool *) MEMTOK (token))[index];
2848
2849 if (!*lock)
2850 {
2851 *lock = true;
2852 if (aquired_lock)
2853 *aquired_lock = (int) true;
2854 if (stat)
2855 *stat = 0;
2856 return;
2857 }
2858
2859 if (aquired_lock)
2860 {
2861 *aquired_lock = (int) false;
2862 if (stat)
2863 *stat = 0;
2864 return;
2865 }
2866
2867
2868 if (stat)
2869 {
2870 *stat = 1;
2871 if (errmsg_len > 0)
2872 {
2873 int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
2874 : (int) sizeof (msg);
2875 memcpy (errmsg, msg, len);
2876 if (errmsg_len > len)
2877 memset (&errmsg[len], ' ', errmsg_len-len);
2878 }
2879 return;
2880 }
2881 _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
2882 }
2883
2884
2885 void
2886 _gfortran_caf_unlock (caf_token_t token, size_t index,
2887 int image_index __attribute__ ((unused)),
2888 int *stat, char *errmsg, int errmsg_len)
2889 {
2890 const char *msg = "Variable is not locked";
2891 bool *lock = &((bool *) MEMTOK (token))[index];
2892
2893 if (*lock)
2894 {
2895 *lock = false;
2896 if (stat)
2897 *stat = 0;
2898 return;
2899 }
2900
2901 if (stat)
2902 {
2903 *stat = 1;
2904 if (errmsg_len > 0)
2905 {
2906 int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
2907 : (int) sizeof (msg);
2908 memcpy (errmsg, msg, len);
2909 if (errmsg_len > len)
2910 memset (&errmsg[len], ' ', errmsg_len-len);
2911 }
2912 return;
2913 }
2914 _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
2915 }
2916
2917 int
2918 _gfortran_caf_is_present (caf_token_t token,
2919 int image_index __attribute__ ((unused)),
2920 caf_reference_t *refs)
2921 {
2922 const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
2923 "only scalar indexes allowed.\n";
2924 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
2925 "unknown reference type.\n";
2926 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
2927 "unknown array reference type.\n";
2928 size_t i;
2929 caf_single_token_t single_token = TOKEN (token);
2930 void *memptr = single_token->memptr;
2931 gfc_descriptor_t *src = single_token->desc;
2932 caf_reference_t *riter = refs;
2933
2934 while (riter)
2935 {
2936 switch (riter->type)
2937 {
2938 case CAF_REF_COMPONENT:
2939 if (riter->u.c.caf_token_offset)
2940 {
2941 single_token = *(caf_single_token_t*)
2942 (memptr + riter->u.c.caf_token_offset);
2943 memptr = single_token->memptr;
2944 src = single_token->desc;
2945 }
2946 else
2947 {
2948 memptr += riter->u.c.offset;
2949 src = (gfc_descriptor_t *)memptr;
2950 }
2951 break;
2952 case CAF_REF_ARRAY:
2953 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2954 {
2955 switch (riter->u.a.mode[i])
2956 {
2957 case CAF_ARR_REF_SINGLE:
2958 memptr += (riter->u.a.dim[i].s.start
2959 - GFC_DIMENSION_LBOUND (src->dim[i]))
2960 * GFC_DIMENSION_STRIDE (src->dim[i])
2961 * riter->item_size;
2962 break;
2963 case CAF_ARR_REF_FULL:
2964 /* A full array ref is allowed on the last reference only. */
2965 if (riter->next == NULL)
2966 break;
2967 /* else fall through reporting an error. */
2968 /* FALLTHROUGH */
2969 case CAF_ARR_REF_VECTOR:
2970 case CAF_ARR_REF_RANGE:
2971 case CAF_ARR_REF_OPEN_END:
2972 case CAF_ARR_REF_OPEN_START:
2973 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
2974 return 0;
2975 default:
2976 caf_internal_error (unknownarrreftype, 0, NULL, 0);
2977 return 0;
2978 }
2979 }
2980 break;
2981 case CAF_REF_STATIC_ARRAY:
2982 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2983 {
2984 switch (riter->u.a.mode[i])
2985 {
2986 case CAF_ARR_REF_SINGLE:
2987 memptr += riter->u.a.dim[i].s.start
2988 * riter->u.a.dim[i].s.stride
2989 * riter->item_size;
2990 break;
2991 case CAF_ARR_REF_FULL:
2992 /* A full array ref is allowed on the last reference only. */
2993 if (riter->next == NULL)
2994 break;
2995 /* else fall through reporting an error. */
2996 /* FALLTHROUGH */
2997 case CAF_ARR_REF_VECTOR:
2998 case CAF_ARR_REF_RANGE:
2999 case CAF_ARR_REF_OPEN_END:
3000 case CAF_ARR_REF_OPEN_START:
3001 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
3002 return 0;
3003 default:
3004 caf_internal_error (unknownarrreftype, 0, NULL, 0);
3005 return 0;
3006 }
3007 }
3008 break;
3009 default:
3010 caf_internal_error (unknownreftype, 0, NULL, 0);
3011 return 0;
3012 }
3013 riter = riter->next;
3014 }
3015 return memptr != NULL;
3016 }
Mirror of https://gcc.gnu.org/git/gcc.git