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