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