]> git.ipfire.org Git - thirdparty/gcc.git/blame - libgfortran/caf/single.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update copyright years.
[thirdparty/gcc.git] / libgfortran / caf / single.c
CommitLineData
e60f31f1 1/* Single-image implementation of GNU Fortran Coarray Library
f1717362 2 Copyright (C) 2011-2016 Free Software Foundation, Inc.
e60f31f1 3 Contributed by Tobias Burnus <burnus@net-b.de>
4
5This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
6
7Libcaf is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 3, or (at your option)
10any later version.
11
12Libcaf is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see 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. */
84deca68 28#include <stdlib.h> /* For exit and malloc. */
be1bfb34 29#include <string.h> /* For memcpy and memset. */
1964dc6f 30#include <stdarg.h> /* For variadic arguments. */
97b9ac34 31#include <assert.h>
e60f31f1 32
33/* Define GFC_CAF_CHECK to enable run-time checking. */
34/* #define GFC_CAF_CHECK 1 */
35
3c3f24bc 36typedef void* single_token_t;
37#define TOKEN(X) ((single_token_t) (X))
38
e60f31f1 39/* Single-image implementation of the CAF library.
40 Note: For performance reasons -fcoarry=single should be used
41 rather than this library. */
42
75626a1f 43/* Global variables. */
44caf_static_t *caf_static_list = NULL;
45
84deca68 46
1964dc6f 47/* Keep in sync with mpi.c. */
48static void
49caf_runtime_error (const char *message, ...)
50{
51 va_list ap;
52 fprintf (stderr, "Fortran runtime error: ");
53 va_start (ap, message);
95fb5ef9 54 vfprintf (stderr, message, ap);
1964dc6f 55 va_end (ap);
56 fprintf (stderr, "\n");
83ba0e65 57
1964dc6f 58 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
59 exit (EXIT_FAILURE);
60}
61
e60f31f1 62void
63_gfortran_caf_init (int *argc __attribute__ ((unused)),
3c3f24bc 64 char ***argv __attribute__ ((unused)))
e60f31f1 65{
e60f31f1 66}
67
84deca68 68
e60f31f1 69void
70_gfortran_caf_finalize (void)
71{
75626a1f 72 while (caf_static_list != NULL)
73 {
4f5fe475 74 caf_static_t *tmp = caf_static_list->prev;
4f5fe475 75 free (caf_static_list->token);
76 free (caf_static_list);
77 caf_static_list = tmp;
75626a1f 78 }
e60f31f1 79}
80
84deca68 81
3c3f24bc 82int
83_gfortran_caf_this_image (int distance __attribute__ ((unused)))
84{
85 return 1;
86}
87
88
89int
90_gfortran_caf_num_images (int distance __attribute__ ((unused)),
da82fa7c 91 int failed __attribute__ ((unused)))
3c3f24bc 92{
93 return 1;
94}
95
96
84deca68 97void *
3c3f24bc 98_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
be1bfb34 99 int *stat, char *errmsg, int errmsg_len)
84deca68 100{
75626a1f 101 void *local;
102
498b946e 103 if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
bd47f0bc 104 || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
105 || type == CAF_REGTYPE_EVENT_ALLOC)
498b946e 106 local = calloc (size, sizeof (bool));
107 else
108 local = malloc (size);
3c3f24bc 109 *token = malloc (sizeof (single_token_t));
75626a1f 110
be1bfb34 111 if (unlikely (local == NULL || token == NULL))
112 {
1964dc6f 113 const char msg[] = "Failed to allocate coarray";
be1bfb34 114 if (stat)
115 {
116 *stat = 1;
117 if (errmsg_len > 0)
118 {
be1bfb34 119 int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
120 : (int) sizeof (msg);
121 memcpy (errmsg, msg, len);
122 if (errmsg_len > len)
123 memset (&errmsg[len], ' ', errmsg_len-len);
124 }
125 return NULL;
126 }
127 else
1964dc6f 128 caf_runtime_error (msg);
be1bfb34 129 }
130
3c3f24bc 131 *token = local;
132
be1bfb34 133 if (stat)
134 *stat = 0;
135
498b946e 136 if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
bd47f0bc 137 || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
138 || type == CAF_REGTYPE_EVENT_ALLOC)
75626a1f 139 {
140 caf_static_t *tmp = malloc (sizeof (caf_static_t));
141 tmp->prev = caf_static_list;
d0d776fb 142 tmp->token = *token;
75626a1f 143 caf_static_list = tmp;
144 }
145 return local;
84deca68 146}
147
148
4f5fe475 149void
3c3f24bc 150_gfortran_caf_deregister (caf_token_t *token, int *stat,
4f5fe475 151 char *errmsg __attribute__ ((unused)),
152 int errmsg_len __attribute__ ((unused)))
84deca68 153{
3c3f24bc 154 free (TOKEN(*token));
4f5fe475 155
156 if (stat)
157 *stat = 0;
84deca68 158}
159
160
96b417f0 161void
162_gfortran_caf_sync_all (int *stat,
163 char *errmsg __attribute__ ((unused)),
e60f31f1 164 int errmsg_len __attribute__ ((unused)))
165{
71cf3ae6 166 __asm__ __volatile__ ("":::"memory");
167 if (stat)
168 *stat = 0;
169}
170
171
172void
173_gfortran_caf_sync_memory (int *stat,
174 char *errmsg __attribute__ ((unused)),
175 int errmsg_len __attribute__ ((unused)))
176{
177 __asm__ __volatile__ ("":::"memory");
96b417f0 178 if (stat)
179 *stat = 0;
e60f31f1 180}
181
75626a1f 182
96b417f0 183void
e60f31f1 184_gfortran_caf_sync_images (int count __attribute__ ((unused)),
185 int images[] __attribute__ ((unused)),
96b417f0 186 int *stat,
e60f31f1 187 char *errmsg __attribute__ ((unused)),
188 int errmsg_len __attribute__ ((unused)))
189{
190#ifdef GFC_CAF_CHECK
191 int i;
192
193 for (i = 0; i < count; i++)
194 if (images[i] != 1)
195 {
196 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
197 "IMAGES", images[i]);
1964dc6f 198 exit (EXIT_FAILURE);
e60f31f1 199 }
200#endif
201
71cf3ae6 202 __asm__ __volatile__ ("":::"memory");
96b417f0 203 if (stat)
204 *stat = 0;
e60f31f1 205}
206
e60f31f1 207
208void
209_gfortran_caf_error_stop_str (const char *string, int32_t len)
210{
211 fputs ("ERROR STOP ", stderr);
212 while (len--)
213 fputc (*(string++), stderr);
214 fputs ("\n", stderr);
215
216 exit (1);
217}
218
84deca68 219
e60f31f1 220void
221_gfortran_caf_error_stop (int32_t error)
222{
223 fprintf (stderr, "ERROR STOP %d\n", error);
224 exit (error);
225}
79ed4a8e 226
227
52306a18 228void
229_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
230 int source_image __attribute__ ((unused)),
231 int *stat, char *errmsg __attribute__ ((unused)),
232 int errmsg_len __attribute__ ((unused)))
233{
234 if (stat)
235 *stat = 0;
236}
237
79ed4a8e 238void
5f4a118e 239_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
79ed4a8e 240 int result_image __attribute__ ((unused)),
241 int *stat, char *errmsg __attribute__ ((unused)),
242 int errmsg_len __attribute__ ((unused)))
243{
244 if (stat)
8c68cf35 245 *stat = 0;
79ed4a8e 246}
247
248void
5f4a118e 249_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
79ed4a8e 250 int result_image __attribute__ ((unused)),
251 int *stat, char *errmsg __attribute__ ((unused)),
52306a18 252 int a_len __attribute__ ((unused)),
79ed4a8e 253 int errmsg_len __attribute__ ((unused)))
254{
255 if (stat)
8c68cf35 256 *stat = 0;
79ed4a8e 257}
258
259void
5f4a118e 260_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
79ed4a8e 261 int result_image __attribute__ ((unused)),
262 int *stat, char *errmsg __attribute__ ((unused)),
52306a18 263 int a_len __attribute__ ((unused)),
79ed4a8e 264 int errmsg_len __attribute__ ((unused)))
265{
266 if (stat)
8c68cf35 267 *stat = 0;
79ed4a8e 268}
5f4a118e 269
a10fb10a 270
71a1e0b3 271void
272_gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
273 void * (*opr) (void *, void *)
274 __attribute__ ((unused)),
275 int opr_flags __attribute__ ((unused)),
276 int result_image __attribute__ ((unused)),
277 int *stat, char *errmsg __attribute__ ((unused)),
278 int a_len __attribute__ ((unused)),
279 int errmsg_len __attribute__ ((unused)))
280 {
281 if (stat)
282 *stat = 0;
283 }
284
285
a10fb10a 286static void
287assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
288 unsigned char *src)
289{
290 size_t i, n;
291 n = dst_size/4 > src_size ? src_size : dst_size/4;
292 for (i = 0; i < n; ++i)
293 dst[i] = (int32_t) src[i];
294 for (; i < dst_size/4; ++i)
295 dst[i] = (int32_t) ' ';
296}
297
298
299static void
300assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
301 uint32_t *src)
302{
303 size_t i, n;
304 n = dst_size > src_size/4 ? src_size/4 : dst_size;
305 for (i = 0; i < n; ++i)
306 dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
307 if (dst_size > n)
308 memset(&dst[n], ' ', dst_size - n);
309}
310
311
312static void
313convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
314 int src_kind)
315{
316#ifdef HAVE_GFC_INTEGER_16
317 typedef __int128 int128t;
318#else
319 typedef int64_t int128t;
320#endif
321
322#if defined(GFC_REAL_16_IS_LONG_DOUBLE)
323 typedef long double real128t;
324 typedef _Complex long double complex128t;
325#elif defined(HAVE_GFC_REAL_16)
326 typedef _Complex float __attribute__((mode(TC))) __complex128;
327 typedef __float128 real128t;
328 typedef __complex128 complex128t;
329#elif defined(HAVE_GFC_REAL_10)
330 typedef long double real128t;
331 typedef long double complex128t;
332#else
333 typedef double real128t;
334 typedef _Complex double complex128t;
335#endif
336
337 int128t int_val = 0;
338 real128t real_val = 0;
339 complex128t cmpx_val = 0;
340
341 switch (src_type)
342 {
343 case BT_INTEGER:
344 if (src_kind == 1)
345 int_val = *(int8_t*) src;
346 else if (src_kind == 2)
347 int_val = *(int16_t*) src;
348 else if (src_kind == 4)
349 int_val = *(int32_t*) src;
350 else if (src_kind == 8)
351 int_val = *(int64_t*) src;
352#ifdef HAVE_GFC_INTEGER_16
353 else if (src_kind == 16)
354 int_val = *(int128t*) src;
355#endif
356 else
357 goto error;
358 break;
359 case BT_REAL:
360 if (src_kind == 4)
361 real_val = *(float*) src;
362 else if (src_kind == 8)
363 real_val = *(double*) src;
364#ifdef HAVE_GFC_REAL_10
365 else if (src_kind == 10)
366 real_val = *(long double*) src;
367#endif
368#ifdef HAVE_GFC_REAL_16
369 else if (src_kind == 16)
370 real_val = *(real128t*) src;
371#endif
372 else
373 goto error;
374 break;
375 case BT_COMPLEX:
376 if (src_kind == 4)
377 cmpx_val = *(_Complex float*) src;
378 else if (src_kind == 8)
379 cmpx_val = *(_Complex double*) src;
380#ifdef HAVE_GFC_REAL_10
381 else if (src_kind == 10)
382 cmpx_val = *(_Complex long double*) src;
383#endif
384#ifdef HAVE_GFC_REAL_16
385 else if (src_kind == 16)
386 cmpx_val = *(complex128t*) src;
387#endif
388 else
389 goto error;
390 break;
391 default:
392 goto error;
393 }
394
395 switch (dst_type)
396 {
397 case BT_INTEGER:
398 if (src_type == BT_INTEGER)
399 {
400 if (dst_kind == 1)
401 *(int8_t*) dst = (int8_t) int_val;
402 else if (dst_kind == 2)
403 *(int16_t*) dst = (int16_t) int_val;
404 else if (dst_kind == 4)
405 *(int32_t*) dst = (int32_t) int_val;
406 else if (dst_kind == 8)
407 *(int64_t*) dst = (int64_t) int_val;
408#ifdef HAVE_GFC_INTEGER_16
409 else if (dst_kind == 16)
410 *(int128t*) dst = (int128t) int_val;
411#endif
412 else
413 goto error;
414 }
415 else if (src_type == BT_REAL)
416 {
417 if (dst_kind == 1)
418 *(int8_t*) dst = (int8_t) real_val;
419 else if (dst_kind == 2)
420 *(int16_t*) dst = (int16_t) real_val;
421 else if (dst_kind == 4)
422 *(int32_t*) dst = (int32_t) real_val;
423 else if (dst_kind == 8)
424 *(int64_t*) dst = (int64_t) real_val;
425#ifdef HAVE_GFC_INTEGER_16
426 else if (dst_kind == 16)
427 *(int128t*) dst = (int128t) real_val;
428#endif
429 else
430 goto error;
431 }
432 else if (src_type == BT_COMPLEX)
433 {
434 if (dst_kind == 1)
435 *(int8_t*) dst = (int8_t) cmpx_val;
436 else if (dst_kind == 2)
437 *(int16_t*) dst = (int16_t) cmpx_val;
438 else if (dst_kind == 4)
439 *(int32_t*) dst = (int32_t) cmpx_val;
440 else if (dst_kind == 8)
441 *(int64_t*) dst = (int64_t) cmpx_val;
442#ifdef HAVE_GFC_INTEGER_16
443 else if (dst_kind == 16)
444 *(int128t*) dst = (int128t) cmpx_val;
445#endif
446 else
447 goto error;
448 }
449 else
450 goto error;
451 break;
452 case BT_REAL:
453 if (src_type == BT_INTEGER)
454 {
455 if (dst_kind == 4)
456 *(float*) dst = (float) int_val;
457 else if (dst_kind == 8)
458 *(double*) dst = (double) int_val;
459#ifdef HAVE_GFC_REAL_10
460 else if (dst_kind == 10)
461 *(long double*) dst = (long double) int_val;
462#endif
463#ifdef HAVE_GFC_REAL_16
464 else if (dst_kind == 16)
465 *(real128t*) dst = (real128t) int_val;
466#endif
467 else
468 goto error;
469 }
470 else if (src_type == BT_REAL)
471 {
472 if (dst_kind == 4)
473 *(float*) dst = (float) real_val;
474 else if (dst_kind == 8)
475 *(double*) dst = (double) real_val;
476#ifdef HAVE_GFC_REAL_10
477 else if (dst_kind == 10)
478 *(long double*) dst = (long double) real_val;
479#endif
480#ifdef HAVE_GFC_REAL_16
481 else if (dst_kind == 16)
482 *(real128t*) dst = (real128t) real_val;
483#endif
484 else
485 goto error;
486 }
487 else if (src_type == BT_COMPLEX)
488 {
489 if (dst_kind == 4)
490 *(float*) dst = (float) cmpx_val;
491 else if (dst_kind == 8)
492 *(double*) dst = (double) cmpx_val;
493#ifdef HAVE_GFC_REAL_10
494 else if (dst_kind == 10)
495 *(long double*) dst = (long double) cmpx_val;
496#endif
497#ifdef HAVE_GFC_REAL_16
498 else if (dst_kind == 16)
499 *(real128t*) dst = (real128t) cmpx_val;
500#endif
501 else
502 goto error;
503 }
504 break;
505 case BT_COMPLEX:
506 if (src_type == BT_INTEGER)
507 {
508 if (dst_kind == 4)
509 *(_Complex float*) dst = (_Complex float) int_val;
510 else if (dst_kind == 8)
511 *(_Complex double*) dst = (_Complex double) int_val;
512#ifdef HAVE_GFC_REAL_10
513 else if (dst_kind == 10)
514 *(_Complex long double*) dst = (_Complex long double) int_val;
515#endif
516#ifdef HAVE_GFC_REAL_16
517 else if (dst_kind == 16)
518 *(complex128t*) dst = (complex128t) int_val;
519#endif
520 else
521 goto error;
522 }
523 else if (src_type == BT_REAL)
524 {
525 if (dst_kind == 4)
526 *(_Complex float*) dst = (_Complex float) real_val;
527 else if (dst_kind == 8)
528 *(_Complex double*) dst = (_Complex double) real_val;
529#ifdef HAVE_GFC_REAL_10
530 else if (dst_kind == 10)
531 *(_Complex long double*) dst = (_Complex long double) real_val;
532#endif
533#ifdef HAVE_GFC_REAL_16
534 else if (dst_kind == 16)
535 *(complex128t*) dst = (complex128t) real_val;
536#endif
537 else
538 goto error;
539 }
540 else if (src_type == BT_COMPLEX)
541 {
542 if (dst_kind == 4)
543 *(_Complex float*) dst = (_Complex float) cmpx_val;
544 else if (dst_kind == 8)
545 *(_Complex double*) dst = (_Complex double) cmpx_val;
546#ifdef HAVE_GFC_REAL_10
547 else if (dst_kind == 10)
548 *(_Complex long double*) dst = (_Complex long double) cmpx_val;
549#endif
550#ifdef HAVE_GFC_REAL_16
551 else if (dst_kind == 16)
552 *(complex128t*) dst = (complex128t) cmpx_val;
553#endif
554 else
555 goto error;
556 }
557 else
558 goto error;
559 break;
560 default:
561 goto error;
562 }
563
564error:
565 fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
566 "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
567 abort();
568}
569
570
5f4a118e 571void
572_gfortran_caf_get (caf_token_t token, size_t offset,
573 int image_index __attribute__ ((unused)),
498b946e 574 gfc_descriptor_t *src,
5f4a118e 575 caf_vector_t *src_vector __attribute__ ((unused)),
9f1c76f9 576 gfc_descriptor_t *dest, int src_kind, int dst_kind,
577 bool may_require_tmp)
5f4a118e 578{
a10fb10a 579 /* FIXME: Handle vector subscripts. */
5f4a118e 580 size_t i, k, size;
581 int j;
582 int rank = GFC_DESCRIPTOR_RANK (dest);
583 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
584 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
585
586 if (rank == 0)
587 {
588 void *sr = (void *) ((char *) TOKEN (token) + offset);
a10fb10a 589 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
590 && dst_kind == src_kind)
5f4a118e 591 {
a10fb10a 592 memmove (GFC_DESCRIPTOR_DATA (dest), sr,
593 dst_size > src_size ? src_size : dst_size);
594 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
595 {
596 if (dst_kind == 1)
597 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
598 ' ', dst_size - src_size);
599 else /* dst_kind == 4. */
600 for (i = src_size/4; i < dst_size/4; i++)
601 ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
602 }
5f4a118e 603 }
a10fb10a 604 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
605 assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
606 sr);
607 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
608 assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
609 sr);
610 else
611 convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
612 dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
5f4a118e 613 return;
614 }
615
616 size = 1;
617 for (j = 0; j < rank; j++)
618 {
619 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
620 if (dimextent < 0)
621 dimextent = 0;
622 size *= dimextent;
623 }
624
625 if (size == 0)
626 return;
627
9f1c76f9 628 if (may_require_tmp)
629 {
630 ptrdiff_t array_offset_sr, array_offset_dst;
631 void *tmp = malloc (size*src_size);
632
633 array_offset_dst = 0;
634 for (i = 0; i < size; i++)
635 {
636 ptrdiff_t array_offset_sr = 0;
637 ptrdiff_t stride = 1;
638 ptrdiff_t extent = 1;
639 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
640 {
641 array_offset_sr += ((i / (extent*stride))
642 % (src->dim[j]._ubound
643 - src->dim[j].lower_bound + 1))
644 * src->dim[j]._stride;
645 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
646 stride = src->dim[j]._stride;
647 }
648 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
649 void *sr = (void *)((char *) TOKEN (token) + offset
650 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
651 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
652 array_offset_dst += src_size;
653 }
654
655 array_offset_sr = 0;
656 for (i = 0; i < size; i++)
657 {
658 ptrdiff_t array_offset_dst = 0;
659 ptrdiff_t stride = 1;
660 ptrdiff_t extent = 1;
661 for (j = 0; j < rank-1; j++)
662 {
663 array_offset_dst += ((i / (extent*stride))
664 % (dest->dim[j]._ubound
665 - dest->dim[j].lower_bound + 1))
666 * dest->dim[j]._stride;
667 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
668 stride = dest->dim[j]._stride;
669 }
670 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
671 void *dst = dest->base_addr
672 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
673 void *sr = tmp + array_offset_sr;
674
675 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
676 && dst_kind == src_kind)
677 {
678 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
679 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
680 && dst_size > src_size)
681 {
682 if (dst_kind == 1)
683 memset ((void*)(char*) dst + src_size, ' ',
684 dst_size-src_size);
685 else /* dst_kind == 4. */
686 for (k = src_size/4; k < dst_size/4; k++)
687 ((int32_t*) dst)[k] = (int32_t) ' ';
688 }
689 }
690 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
691 assign_char1_from_char4 (dst_size, src_size, dst, sr);
692 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
693 assign_char4_from_char1 (dst_size, src_size, dst, sr);
694 else
695 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
696 sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
697 array_offset_sr += src_size;
698 }
699
700 free (tmp);
701 return;
702 }
703
5f4a118e 704 for (i = 0; i < size; i++)
705 {
706 ptrdiff_t array_offset_dst = 0;
707 ptrdiff_t stride = 1;
708 ptrdiff_t extent = 1;
709 for (j = 0; j < rank-1; j++)
710 {
711 array_offset_dst += ((i / (extent*stride))
712 % (dest->dim[j]._ubound
713 - dest->dim[j].lower_bound + 1))
714 * dest->dim[j]._stride;
715 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
716 stride = dest->dim[j]._stride;
717 }
718 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
719 void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
720
a10fb10a 721 ptrdiff_t array_offset_sr = 0;
722 stride = 1;
723 extent = 1;
724 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
5f4a118e 725 {
a10fb10a 726 array_offset_sr += ((i / (extent*stride))
727 % (src->dim[j]._ubound
728 - src->dim[j].lower_bound + 1))
729 * src->dim[j]._stride;
730 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
731 stride = src->dim[j]._stride;
5f4a118e 732 }
a10fb10a 733 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
734 void *sr = (void *)((char *) TOKEN (token) + offset
735 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
5f4a118e 736
a10fb10a 737 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
738 && dst_kind == src_kind)
5f4a118e 739 {
a10fb10a 740 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
741 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
742 {
743 if (dst_kind == 1)
744 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
745 else /* dst_kind == 4. */
746 for (k = src_size/4; k < dst_size/4; k++)
747 ((int32_t*) dst)[k] = (int32_t) ' ';
748 }
5f4a118e 749 }
a10fb10a 750 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
751 assign_char1_from_char4 (dst_size, src_size, dst, sr);
752 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
753 assign_char4_from_char1 (dst_size, src_size, dst, sr);
754 else
755 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
756 sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
5f4a118e 757 }
758}
759
760
761void
762_gfortran_caf_send (caf_token_t token, size_t offset,
763 int image_index __attribute__ ((unused)),
764 gfc_descriptor_t *dest,
765 caf_vector_t *dst_vector __attribute__ ((unused)),
9f1c76f9 766 gfc_descriptor_t *src, int dst_kind, int src_kind,
767 bool may_require_tmp)
5f4a118e 768{
a10fb10a 769 /* FIXME: Handle vector subscripts. */
5f4a118e 770 size_t i, k, size;
771 int j;
772 int rank = GFC_DESCRIPTOR_RANK (dest);
773 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
774 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
775
776 if (rank == 0)
777 {
778 void *dst = (void *) ((char *) TOKEN (token) + offset);
a10fb10a 779 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
780 && dst_kind == src_kind)
5f4a118e 781 {
a10fb10a 782 memmove (dst, GFC_DESCRIPTOR_DATA (src),
783 dst_size > src_size ? src_size : dst_size);
784 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
785 {
786 if (dst_kind == 1)
787 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
788 else /* dst_kind == 4. */
789 for (i = src_size/4; i < dst_size/4; i++)
790 ((int32_t*) dst)[i] = (int32_t) ' ';
791 }
5f4a118e 792 }
a10fb10a 793 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
794 assign_char1_from_char4 (dst_size, src_size, dst,
795 GFC_DESCRIPTOR_DATA (src));
796 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
797 assign_char4_from_char1 (dst_size, src_size, dst,
798 GFC_DESCRIPTOR_DATA (src));
799 else
800 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
801 GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
802 src_kind);
5f4a118e 803 return;
804 }
805
806 size = 1;
807 for (j = 0; j < rank; j++)
808 {
809 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
810 if (dimextent < 0)
811 dimextent = 0;
812 size *= dimextent;
813 }
814
815 if (size == 0)
816 return;
817
9f1c76f9 818 if (may_require_tmp)
819 {
820 ptrdiff_t array_offset_sr, array_offset_dst;
821 void *tmp;
822
823 if (GFC_DESCRIPTOR_RANK (src) == 0)
824 {
825 tmp = malloc (src_size);
826 memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
827 }
828 else
829 {
830 tmp = malloc (size*src_size);
831 array_offset_dst = 0;
832 for (i = 0; i < size; i++)
833 {
834 ptrdiff_t array_offset_sr = 0;
835 ptrdiff_t stride = 1;
836 ptrdiff_t extent = 1;
837 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
838 {
839 array_offset_sr += ((i / (extent*stride))
840 % (src->dim[j]._ubound
841 - src->dim[j].lower_bound + 1))
842 * src->dim[j]._stride;
843 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
844 stride = src->dim[j]._stride;
845 }
846 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
847 void *sr = (void *) ((char *) src->base_addr
848 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
849 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
850 array_offset_dst += src_size;
851 }
852 }
853
854 array_offset_sr = 0;
855 for (i = 0; i < size; i++)
856 {
857 ptrdiff_t array_offset_dst = 0;
858 ptrdiff_t stride = 1;
859 ptrdiff_t extent = 1;
860 for (j = 0; j < rank-1; j++)
861 {
862 array_offset_dst += ((i / (extent*stride))
863 % (dest->dim[j]._ubound
864 - dest->dim[j].lower_bound + 1))
865 * dest->dim[j]._stride;
866 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
867 stride = dest->dim[j]._stride;
868 }
869 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
870 void *dst = (void *)((char *) TOKEN (token) + offset
871 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
872 void *sr = tmp + array_offset_sr;
873 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
874 && dst_kind == src_kind)
875 {
876 memmove (dst, sr,
877 dst_size > src_size ? src_size : dst_size);
878 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
879 && dst_size > src_size)
880 {
881 if (dst_kind == 1)
882 memset ((void*)(char*) dst + src_size, ' ',
883 dst_size-src_size);
884 else /* dst_kind == 4. */
885 for (k = src_size/4; k < dst_size/4; k++)
886 ((int32_t*) dst)[k] = (int32_t) ' ';
887 }
888 }
889 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
890 assign_char1_from_char4 (dst_size, src_size, dst, sr);
891 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
892 assign_char4_from_char1 (dst_size, src_size, dst, sr);
893 else
894 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
895 sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
896 if (GFC_DESCRIPTOR_RANK (src))
897 array_offset_sr += src_size;
898 }
899 free (tmp);
900 return;
901 }
902
5f4a118e 903 for (i = 0; i < size; i++)
904 {
905 ptrdiff_t array_offset_dst = 0;
906 ptrdiff_t stride = 1;
907 ptrdiff_t extent = 1;
908 for (j = 0; j < rank-1; j++)
909 {
910 array_offset_dst += ((i / (extent*stride))
911 % (dest->dim[j]._ubound
912 - dest->dim[j].lower_bound + 1))
913 * dest->dim[j]._stride;
914 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
915 stride = dest->dim[j]._stride;
916 }
917 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
918 void *dst = (void *)((char *) TOKEN (token) + offset
919 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
920 void *sr;
921 if (GFC_DESCRIPTOR_RANK (src) != 0)
922 {
923 ptrdiff_t array_offset_sr = 0;
924 stride = 1;
925 extent = 1;
926 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
927 {
928 array_offset_sr += ((i / (extent*stride))
929 % (src->dim[j]._ubound
930 - src->dim[j].lower_bound + 1))
931 * src->dim[j]._stride;
932 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
933 stride = src->dim[j]._stride;
934 }
935 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
936 sr = (void *)((char *) src->base_addr
937 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
938 }
939 else
940 sr = src->base_addr;
941
a10fb10a 942 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
943 && dst_kind == src_kind)
5f4a118e 944 {
a10fb10a 945 memmove (dst, sr,
946 dst_size > src_size ? src_size : dst_size);
947 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
948 {
949 if (dst_kind == 1)
950 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
951 else /* dst_kind == 4. */
952 for (k = src_size/4; k < dst_size/4; k++)
953 ((int32_t*) dst)[k] = (int32_t) ' ';
954 }
5f4a118e 955 }
a10fb10a 956 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
957 assign_char1_from_char4 (dst_size, src_size, dst, sr);
958 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
959 assign_char4_from_char1 (dst_size, src_size, dst, sr);
960 else
961 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
962 sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
5f4a118e 963 }
964}
965
966
967void
968_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
969 int dst_image_index, gfc_descriptor_t *dest,
970 caf_vector_t *dst_vector, caf_token_t src_token,
971 size_t src_offset,
972 int src_image_index __attribute__ ((unused)),
973 gfc_descriptor_t *src,
974 caf_vector_t *src_vector __attribute__ ((unused)),
9f1c76f9 975 int dst_kind, int src_kind, bool may_require_tmp)
5f4a118e 976{
977 /* FIXME: Handle vector subscript of 'src_vector'. */
978 /* For a single image, src->base_addr should be the same as src_token + offset
979 but to play save, we do it properly. */
980 void *src_base = GFC_DESCRIPTOR_DATA (src);
981 GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
982 _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
9f1c76f9 983 src, dst_kind, src_kind, may_require_tmp);
5f4a118e 984 GFC_DESCRIPTOR_DATA (src) = src_base;
985}
97b9ac34 986
987
988void
989_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
990 int image_index __attribute__ ((unused)),
991 void *value, int *stat,
992 int type __attribute__ ((unused)), int kind)
993{
994 assert(kind == 4);
995
996 uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
997
998 __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
999
1000 if (stat)
1001 *stat = 0;
1002}
1003
1004void
1005_gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
1006 int image_index __attribute__ ((unused)),
1007 void *value, int *stat,
1008 int type __attribute__ ((unused)), int kind)
1009{
1010 assert(kind == 4);
1011
1012 uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1013
1014 __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
1015
1016 if (stat)
1017 *stat = 0;
1018}
1019
1020
1021void
1022_gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
1023 int image_index __attribute__ ((unused)),
1024 void *old, void *compare, void *new_val, int *stat,
1025 int type __attribute__ ((unused)), int kind)
1026{
1027 assert(kind == 4);
1028
1029 uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1030
1031 *(uint32_t *) old = *(uint32_t *) compare;
1032 (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
1033 *(uint32_t *) new_val, false,
1034 __ATOMIC_RELAXED, __ATOMIC_RELAXED);
1035 if (stat)
1036 *stat = 0;
1037}
1038
1039
1040void
1041_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
1042 int image_index __attribute__ ((unused)),
1043 void *value, void *old, int *stat,
1044 int type __attribute__ ((unused)), int kind)
1045{
1046 assert(kind == 4);
1047
1048 uint32_t res;
1049 uint32_t *atom = (uint32_t *) ((char *) TOKEN (token) + offset);
1050
1051 switch (op)
1052 {
1053 case GFC_CAF_ATOMIC_ADD:
1054 res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1055 break;
1056 case GFC_CAF_ATOMIC_AND:
1057 res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1058 break;
1059 case GFC_CAF_ATOMIC_OR:
1060 res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1061 break;
1062 case GFC_CAF_ATOMIC_XOR:
1063 res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
1064 break;
1065 default:
1066 __builtin_unreachable();
1067 }
1068
1069 if (old)
1070 *(uint32_t *) old = res;
1071
1072 if (stat)
1073 *stat = 0;
1074}
498b946e 1075
bd47f0bc 1076void
1077_gfortran_caf_event_post (caf_token_t token, size_t index,
1078 int image_index __attribute__ ((unused)),
1079 int *stat, char *errmsg __attribute__ ((unused)),
1080 int errmsg_len __attribute__ ((unused)))
1081{
1082 uint32_t value = 1;
1083 uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1084 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
1085
1086 if(stat)
1087 *stat = 0;
1088}
1089
1090void
1091_gfortran_caf_event_wait (caf_token_t token, size_t index,
1092 int until_count, int *stat,
1093 char *errmsg __attribute__ ((unused)),
1094 int errmsg_len __attribute__ ((unused)))
1095{
1096 uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1097 uint32_t value = (uint32_t)-until_count;
1098 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
1099
1100 if(stat)
1101 *stat = 0;
1102}
1103
1104void
1105_gfortran_caf_event_query (caf_token_t token, size_t index,
1106 int image_index __attribute__ ((unused)),
1107 int *count, int *stat)
1108{
1109 uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
1110 __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
1111
1112 if(stat)
1113 *stat = 0;
1114}
498b946e 1115
1116void
1117_gfortran_caf_lock (caf_token_t token, size_t index,
1118 int image_index __attribute__ ((unused)),
1119 int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
1120{
1121 const char *msg = "Already locked";
1122 bool *lock = &((bool *) TOKEN (token))[index];
1123
1124 if (!*lock)
1125 {
1126 *lock = true;
1127 if (aquired_lock)
1128 *aquired_lock = (int) true;
1129 if (stat)
1130 *stat = 0;
1131 return;
1132 }
1133
1134 if (aquired_lock)
1135 {
1136 *aquired_lock = (int) false;
1137 if (stat)
1138 *stat = 0;
1139 return;
1140 }
1141
1142
1143 if (stat)
1144 {
1145 *stat = 1;
1146 if (errmsg_len > 0)
1147 {
1148 int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1149 : (int) sizeof (msg);
1150 memcpy (errmsg, msg, len);
1151 if (errmsg_len > len)
1152 memset (&errmsg[len], ' ', errmsg_len-len);
1153 }
1154 return;
1155 }
1156 _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1157}
1158
1159
1160void
1161_gfortran_caf_unlock (caf_token_t token, size_t index,
1162 int image_index __attribute__ ((unused)),
1163 int *stat, char *errmsg, int errmsg_len)
1164{
1165 const char *msg = "Variable is not locked";
1166 bool *lock = &((bool *) TOKEN (token))[index];
1167
1168 if (*lock)
1169 {
1170 *lock = false;
1171 if (stat)
1172 *stat = 0;
1173 return;
1174 }
1175
1176 if (stat)
1177 {
1178 *stat = 1;
1179 if (errmsg_len > 0)
1180 {
1181 int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
1182 : (int) sizeof (msg);
1183 memcpy (errmsg, msg, len);
1184 if (errmsg_len > len)
1185 memset (&errmsg[len], ' ', errmsg_len-len);
1186 }
1187 return;
1188 }
1189 _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
1190}
Mirror of https://gcc.gnu.org/git/gcc.git