1 /* Single-image implementation of GNU Fortran Coarray Library
2 Copyright (C) 2011-2014 Free Software Foundation, Inc.
3 Contributed by Tobias Burnus <burnus@net-b.de>
5 This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
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)
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.
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.
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/>. */
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. */
33 /* Define GFC_CAF_CHECK to enable run-time checking. */
34 /* #define GFC_CAF_CHECK 1 */
36 typedef void* single_token_t
;
37 #define TOKEN(X) ((single_token_t) (X))
39 /* Single-image implementation of the CAF library.
40 Note: For performance reasons -fcoarry=single should be used
41 rather than this library. */
43 /* Global variables. */
44 caf_static_t
*caf_static_list
= NULL
;
47 /* Keep in sync with mpi.c. */
49 caf_runtime_error (const char *message
, ...)
52 fprintf (stderr
, "Fortran runtime error: ");
53 va_start (ap
, message
);
54 vfprintf (stderr
, message
, ap
);
56 fprintf (stderr
, "\n");
58 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
63 _gfortran_caf_init (int *argc
__attribute__ ((unused
)),
64 char ***argv
__attribute__ ((unused
)))
70 _gfortran_caf_finalize (void)
72 while (caf_static_list
!= NULL
)
74 caf_static_t
*tmp
= caf_static_list
->prev
;
75 free (caf_static_list
->token
);
76 free (caf_static_list
);
77 caf_static_list
= tmp
;
83 _gfortran_caf_this_image (int distance
__attribute__ ((unused
)))
90 _gfortran_caf_num_images (int distance
__attribute__ ((unused
)),
91 int failed
__attribute__ ((unused
)))
98 _gfortran_caf_register (size_t size
, caf_register_t type
, caf_token_t
*token
,
99 int *stat
, char *errmsg
, int errmsg_len
)
103 if (type
== CAF_REGTYPE_LOCK_STATIC
|| type
== CAF_REGTYPE_LOCK_ALLOC
104 || type
== CAF_REGTYPE_CRITICAL
)
105 local
= calloc (size
, sizeof (bool));
107 local
= malloc (size
);
108 *token
= malloc (sizeof (single_token_t
));
110 if (unlikely (local
== NULL
|| token
== NULL
))
112 const char msg
[] = "Failed to allocate coarray";
118 int len
= ((int) sizeof (msg
) > errmsg_len
) ? errmsg_len
119 : (int) sizeof (msg
);
120 memcpy (errmsg
, msg
, len
);
121 if (errmsg_len
> len
)
122 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
127 caf_runtime_error (msg
);
135 if (type
== CAF_REGTYPE_COARRAY_STATIC
|| type
== CAF_REGTYPE_LOCK_STATIC
136 || type
== CAF_REGTYPE_CRITICAL
)
138 caf_static_t
*tmp
= malloc (sizeof (caf_static_t
));
139 tmp
->prev
= caf_static_list
;
141 caf_static_list
= tmp
;
148 _gfortran_caf_deregister (caf_token_t
*token
, int *stat
,
149 char *errmsg
__attribute__ ((unused
)),
150 int errmsg_len
__attribute__ ((unused
)))
152 free (TOKEN(*token
));
160 _gfortran_caf_sync_all (int *stat
,
161 char *errmsg
__attribute__ ((unused
)),
162 int errmsg_len
__attribute__ ((unused
)))
170 _gfortran_caf_sync_images (int count
__attribute__ ((unused
)),
171 int images
[] __attribute__ ((unused
)),
173 char *errmsg
__attribute__ ((unused
)),
174 int errmsg_len
__attribute__ ((unused
)))
179 for (i
= 0; i
< count
; i
++)
182 fprintf (stderr
, "COARRAY ERROR: Invalid image index %d to SYNC "
183 "IMAGES", images
[i
]);
194 _gfortran_caf_error_stop_str (const char *string
, int32_t len
)
196 fputs ("ERROR STOP ", stderr
);
198 fputc (*(string
++), stderr
);
199 fputs ("\n", stderr
);
206 _gfortran_caf_error_stop (int32_t error
)
208 fprintf (stderr
, "ERROR STOP %d\n", error
);
214 _gfortran_caf_co_broadcast (gfc_descriptor_t
*a
__attribute__ ((unused
)),
215 int source_image
__attribute__ ((unused
)),
216 int *stat
, char *errmsg
__attribute__ ((unused
)),
217 int errmsg_len
__attribute__ ((unused
)))
224 _gfortran_caf_co_sum (gfc_descriptor_t
*a
__attribute__ ((unused
)),
225 int result_image
__attribute__ ((unused
)),
226 int *stat
, char *errmsg
__attribute__ ((unused
)),
227 int errmsg_len
__attribute__ ((unused
)))
234 _gfortran_caf_co_min (gfc_descriptor_t
*a
__attribute__ ((unused
)),
235 int result_image
__attribute__ ((unused
)),
236 int *stat
, char *errmsg
__attribute__ ((unused
)),
237 int a_len
__attribute__ ((unused
)),
238 int errmsg_len
__attribute__ ((unused
)))
245 _gfortran_caf_co_max (gfc_descriptor_t
*a
__attribute__ ((unused
)),
246 int result_image
__attribute__ ((unused
)),
247 int *stat
, char *errmsg
__attribute__ ((unused
)),
248 int a_len
__attribute__ ((unused
)),
249 int errmsg_len
__attribute__ ((unused
)))
257 assign_char4_from_char1 (size_t dst_size
, size_t src_size
, uint32_t *dst
,
261 n
= dst_size
/4 > src_size
? src_size
: dst_size
/4;
262 for (i
= 0; i
< n
; ++i
)
263 dst
[i
] = (int32_t) src
[i
];
264 for (; i
< dst_size
/4; ++i
)
265 dst
[i
] = (int32_t) ' ';
270 assign_char1_from_char4 (size_t dst_size
, size_t src_size
, unsigned char *dst
,
274 n
= dst_size
> src_size
/4 ? src_size
/4 : dst_size
;
275 for (i
= 0; i
< n
; ++i
)
276 dst
[i
] = src
[i
] > UINT8_MAX
? (unsigned char) '?' : (unsigned char) src
[i
];
278 memset(&dst
[n
], ' ', dst_size
- n
);
283 convert_type (void *dst
, int dst_type
, int dst_kind
, void *src
, int src_type
,
286 #ifdef HAVE_GFC_INTEGER_16
287 typedef __int128 int128t
;
289 typedef int64_t int128t
;
292 #if defined(GFC_REAL_16_IS_LONG_DOUBLE)
293 typedef long double real128t
;
294 typedef _Complex
long double complex128t
;
295 #elif defined(HAVE_GFC_REAL_16)
296 typedef _Complex
float __attribute__((mode(TC
))) __complex128
;
297 typedef __float128 real128t
;
298 typedef __complex128 complex128t
;
299 #elif defined(HAVE_GFC_REAL_10)
300 typedef long double real128t
;
301 typedef long double complex128t
;
303 typedef double real128t
;
304 typedef _Complex
double complex128t
;
308 real128t real_val
= 0;
309 complex128t cmpx_val
= 0;
315 int_val
= *(int8_t*) src
;
316 else if (src_kind
== 2)
317 int_val
= *(int16_t*) src
;
318 else if (src_kind
== 4)
319 int_val
= *(int32_t*) src
;
320 else if (src_kind
== 8)
321 int_val
= *(int64_t*) src
;
322 #ifdef HAVE_GFC_INTEGER_16
323 else if (src_kind
== 16)
324 int_val
= *(int128t
*) src
;
331 real_val
= *(float*) src
;
332 else if (src_kind
== 8)
333 real_val
= *(double*) src
;
334 #ifdef HAVE_GFC_REAL_10
335 else if (src_kind
== 10)
336 real_val
= *(long double*) src
;
338 #ifdef HAVE_GFC_REAL_16
339 else if (src_kind
== 16)
340 real_val
= *(real128t
*) src
;
347 cmpx_val
= *(_Complex
float*) src
;
348 else if (src_kind
== 8)
349 cmpx_val
= *(_Complex
double*) src
;
350 #ifdef HAVE_GFC_REAL_10
351 else if (src_kind
== 10)
352 cmpx_val
= *(_Complex
long double*) src
;
354 #ifdef HAVE_GFC_REAL_16
355 else if (src_kind
== 16)
356 cmpx_val
= *(complex128t
*) src
;
368 if (src_type
== BT_INTEGER
)
371 *(int8_t*) dst
= (int8_t) int_val
;
372 else if (dst_kind
== 2)
373 *(int16_t*) dst
= (int16_t) int_val
;
374 else if (dst_kind
== 4)
375 *(int32_t*) dst
= (int32_t) int_val
;
376 else if (dst_kind
== 8)
377 *(int64_t*) dst
= (int64_t) int_val
;
378 #ifdef HAVE_GFC_INTEGER_16
379 else if (dst_kind
== 16)
380 *(int128t
*) dst
= (int128t
) int_val
;
385 else if (src_type
== BT_REAL
)
388 *(int8_t*) dst
= (int8_t) real_val
;
389 else if (dst_kind
== 2)
390 *(int16_t*) dst
= (int16_t) real_val
;
391 else if (dst_kind
== 4)
392 *(int32_t*) dst
= (int32_t) real_val
;
393 else if (dst_kind
== 8)
394 *(int64_t*) dst
= (int64_t) real_val
;
395 #ifdef HAVE_GFC_INTEGER_16
396 else if (dst_kind
== 16)
397 *(int128t
*) dst
= (int128t
) real_val
;
402 else if (src_type
== BT_COMPLEX
)
405 *(int8_t*) dst
= (int8_t) cmpx_val
;
406 else if (dst_kind
== 2)
407 *(int16_t*) dst
= (int16_t) cmpx_val
;
408 else if (dst_kind
== 4)
409 *(int32_t*) dst
= (int32_t) cmpx_val
;
410 else if (dst_kind
== 8)
411 *(int64_t*) dst
= (int64_t) cmpx_val
;
412 #ifdef HAVE_GFC_INTEGER_16
413 else if (dst_kind
== 16)
414 *(int128t
*) dst
= (int128t
) cmpx_val
;
423 if (src_type
== BT_INTEGER
)
426 *(float*) dst
= (float) int_val
;
427 else if (dst_kind
== 8)
428 *(double*) dst
= (double) int_val
;
429 #ifdef HAVE_GFC_REAL_10
430 else if (dst_kind
== 10)
431 *(long double*) dst
= (long double) int_val
;
433 #ifdef HAVE_GFC_REAL_16
434 else if (dst_kind
== 16)
435 *(real128t
*) dst
= (real128t
) int_val
;
440 else if (src_type
== BT_REAL
)
443 *(float*) dst
= (float) real_val
;
444 else if (dst_kind
== 8)
445 *(double*) dst
= (double) real_val
;
446 #ifdef HAVE_GFC_REAL_10
447 else if (dst_kind
== 10)
448 *(long double*) dst
= (long double) real_val
;
450 #ifdef HAVE_GFC_REAL_16
451 else if (dst_kind
== 16)
452 *(real128t
*) dst
= (real128t
) real_val
;
457 else if (src_type
== BT_COMPLEX
)
460 *(float*) dst
= (float) cmpx_val
;
461 else if (dst_kind
== 8)
462 *(double*) dst
= (double) cmpx_val
;
463 #ifdef HAVE_GFC_REAL_10
464 else if (dst_kind
== 10)
465 *(long double*) dst
= (long double) cmpx_val
;
467 #ifdef HAVE_GFC_REAL_16
468 else if (dst_kind
== 16)
469 *(real128t
*) dst
= (real128t
) cmpx_val
;
476 if (src_type
== BT_INTEGER
)
479 *(_Complex
float*) dst
= (_Complex
float) int_val
;
480 else if (dst_kind
== 8)
481 *(_Complex
double*) dst
= (_Complex
double) int_val
;
482 #ifdef HAVE_GFC_REAL_10
483 else if (dst_kind
== 10)
484 *(_Complex
long double*) dst
= (_Complex
long double) int_val
;
486 #ifdef HAVE_GFC_REAL_16
487 else if (dst_kind
== 16)
488 *(complex128t
*) dst
= (complex128t
) int_val
;
493 else if (src_type
== BT_REAL
)
496 *(_Complex
float*) dst
= (_Complex
float) real_val
;
497 else if (dst_kind
== 8)
498 *(_Complex
double*) dst
= (_Complex
double) real_val
;
499 #ifdef HAVE_GFC_REAL_10
500 else if (dst_kind
== 10)
501 *(_Complex
long double*) dst
= (_Complex
long double) real_val
;
503 #ifdef HAVE_GFC_REAL_16
504 else if (dst_kind
== 16)
505 *(complex128t
*) dst
= (complex128t
) real_val
;
510 else if (src_type
== BT_COMPLEX
)
513 *(_Complex
float*) dst
= (_Complex
float) cmpx_val
;
514 else if (dst_kind
== 8)
515 *(_Complex
double*) dst
= (_Complex
double) cmpx_val
;
516 #ifdef HAVE_GFC_REAL_10
517 else if (dst_kind
== 10)
518 *(_Complex
long double*) dst
= (_Complex
long double) cmpx_val
;
520 #ifdef HAVE_GFC_REAL_16
521 else if (dst_kind
== 16)
522 *(complex128t
*) dst
= (complex128t
) cmpx_val
;
535 fprintf (stderr
, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
536 "%d to type %d kind %d\n", src_type
, src_kind
, dst_type
, dst_kind
);
542 _gfortran_caf_get (caf_token_t token
, size_t offset
,
543 int image_index
__attribute__ ((unused
)),
544 gfc_descriptor_t
*src
,
545 caf_vector_t
*src_vector
__attribute__ ((unused
)),
546 gfc_descriptor_t
*dest
, int src_kind
, int dst_kind
,
547 bool may_require_tmp
)
549 /* FIXME: Handle vector subscripts. */
552 int rank
= GFC_DESCRIPTOR_RANK (dest
);
553 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
554 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dest
);
558 void *sr
= (void *) ((char *) TOKEN (token
) + offset
);
559 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
560 && dst_kind
== src_kind
)
562 memmove (GFC_DESCRIPTOR_DATA (dest
), sr
,
563 dst_size
> src_size
? src_size
: dst_size
);
564 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
567 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest
) + src_size
,
568 ' ', dst_size
- src_size
);
569 else /* dst_kind == 4. */
570 for (i
= src_size
/4; i
< dst_size
/4; i
++)
571 ((int32_t*) GFC_DESCRIPTOR_DATA (dest
))[i
] = (int32_t) ' ';
574 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
575 assign_char1_from_char4 (dst_size
, src_size
, GFC_DESCRIPTOR_DATA (dest
),
577 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
578 assign_char4_from_char1 (dst_size
, src_size
, GFC_DESCRIPTOR_DATA (dest
),
581 convert_type (GFC_DESCRIPTOR_DATA (dest
), GFC_DESCRIPTOR_TYPE (dest
),
582 dst_kind
, sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
);
587 for (j
= 0; j
< rank
; j
++)
589 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
600 ptrdiff_t array_offset_sr
, array_offset_dst
;
601 void *tmp
= malloc (size
*src_size
);
603 array_offset_dst
= 0;
604 for (i
= 0; i
< size
; i
++)
606 ptrdiff_t array_offset_sr
= 0;
607 ptrdiff_t stride
= 1;
608 ptrdiff_t extent
= 1;
609 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
611 array_offset_sr
+= ((i
/ (extent
*stride
))
612 % (src
->dim
[j
]._ubound
613 - src
->dim
[j
].lower_bound
+ 1))
614 * src
->dim
[j
]._stride
;
615 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
616 stride
= src
->dim
[j
]._stride
;
618 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
619 void *sr
= (void *)((char *) TOKEN (token
) + offset
620 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
621 memcpy ((void *) ((char *) tmp
+ array_offset_dst
), sr
, src_size
);
622 array_offset_dst
+= src_size
;
626 for (i
= 0; i
< size
; i
++)
628 ptrdiff_t array_offset_dst
= 0;
629 ptrdiff_t stride
= 1;
630 ptrdiff_t extent
= 1;
631 for (j
= 0; j
< rank
-1; j
++)
633 array_offset_dst
+= ((i
/ (extent
*stride
))
634 % (dest
->dim
[j
]._ubound
635 - dest
->dim
[j
].lower_bound
+ 1))
636 * dest
->dim
[j
]._stride
;
637 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
638 stride
= dest
->dim
[j
]._stride
;
640 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
641 void *dst
= dest
->base_addr
642 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
);
643 void *sr
= tmp
+ array_offset_sr
;
645 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
646 && dst_kind
== src_kind
)
648 memmove (dst
, sr
, dst_size
> src_size
? src_size
: dst_size
);
649 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
650 && dst_size
> src_size
)
653 memset ((void*)(char*) dst
+ src_size
, ' ',
655 else /* dst_kind == 4. */
656 for (k
= src_size
/4; k
< dst_size
/4; k
++)
657 ((int32_t*) dst
)[k
] = (int32_t) ' ';
660 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
661 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
662 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
663 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
665 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
666 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
);
667 array_offset_sr
+= src_size
;
674 for (i
= 0; i
< size
; i
++)
676 ptrdiff_t array_offset_dst
= 0;
677 ptrdiff_t stride
= 1;
678 ptrdiff_t extent
= 1;
679 for (j
= 0; j
< rank
-1; j
++)
681 array_offset_dst
+= ((i
/ (extent
*stride
))
682 % (dest
->dim
[j
]._ubound
683 - dest
->dim
[j
].lower_bound
+ 1))
684 * dest
->dim
[j
]._stride
;
685 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
686 stride
= dest
->dim
[j
]._stride
;
688 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
689 void *dst
= dest
->base_addr
+ array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
);
691 ptrdiff_t array_offset_sr
= 0;
694 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
696 array_offset_sr
+= ((i
/ (extent
*stride
))
697 % (src
->dim
[j
]._ubound
698 - src
->dim
[j
].lower_bound
+ 1))
699 * src
->dim
[j
]._stride
;
700 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
701 stride
= src
->dim
[j
]._stride
;
703 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
704 void *sr
= (void *)((char *) TOKEN (token
) + offset
705 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
707 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
708 && dst_kind
== src_kind
)
710 memmove (dst
, sr
, dst_size
> src_size
? src_size
: dst_size
);
711 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
714 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
715 else /* dst_kind == 4. */
716 for (k
= src_size
/4; k
< dst_size
/4; k
++)
717 ((int32_t*) dst
)[k
] = (int32_t) ' ';
720 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
721 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
722 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
723 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
725 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
726 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
);
732 _gfortran_caf_send (caf_token_t token
, size_t offset
,
733 int image_index
__attribute__ ((unused
)),
734 gfc_descriptor_t
*dest
,
735 caf_vector_t
*dst_vector
__attribute__ ((unused
)),
736 gfc_descriptor_t
*src
, int dst_kind
, int src_kind
,
737 bool may_require_tmp
)
739 /* FIXME: Handle vector subscripts. */
742 int rank
= GFC_DESCRIPTOR_RANK (dest
);
743 size_t src_size
= GFC_DESCRIPTOR_SIZE (src
);
744 size_t dst_size
= GFC_DESCRIPTOR_SIZE (dest
);
748 void *dst
= (void *) ((char *) TOKEN (token
) + offset
);
749 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
750 && dst_kind
== src_kind
)
752 memmove (dst
, GFC_DESCRIPTOR_DATA (src
),
753 dst_size
> src_size
? src_size
: dst_size
);
754 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
757 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
758 else /* dst_kind == 4. */
759 for (i
= src_size
/4; i
< dst_size
/4; i
++)
760 ((int32_t*) dst
)[i
] = (int32_t) ' ';
763 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
764 assign_char1_from_char4 (dst_size
, src_size
, dst
,
765 GFC_DESCRIPTOR_DATA (src
));
766 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
767 assign_char4_from_char1 (dst_size
, src_size
, dst
,
768 GFC_DESCRIPTOR_DATA (src
));
770 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
771 GFC_DESCRIPTOR_DATA (src
), GFC_DESCRIPTOR_TYPE (src
),
777 for (j
= 0; j
< rank
; j
++)
779 ptrdiff_t dimextent
= dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1;
790 ptrdiff_t array_offset_sr
, array_offset_dst
;
793 if (GFC_DESCRIPTOR_RANK (src
) == 0)
795 tmp
= malloc (src_size
);
796 memcpy (tmp
, GFC_DESCRIPTOR_DATA (src
), src_size
);
800 tmp
= malloc (size
*src_size
);
801 array_offset_dst
= 0;
802 for (i
= 0; i
< size
; i
++)
804 ptrdiff_t array_offset_sr
= 0;
805 ptrdiff_t stride
= 1;
806 ptrdiff_t extent
= 1;
807 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
809 array_offset_sr
+= ((i
/ (extent
*stride
))
810 % (src
->dim
[j
]._ubound
811 - src
->dim
[j
].lower_bound
+ 1))
812 * src
->dim
[j
]._stride
;
813 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
814 stride
= src
->dim
[j
]._stride
;
816 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
817 void *sr
= (void *) ((char *) src
->base_addr
818 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
819 memcpy ((void *) ((char *) tmp
+ array_offset_dst
), sr
, src_size
);
820 array_offset_dst
+= src_size
;
825 for (i
= 0; i
< size
; i
++)
827 ptrdiff_t array_offset_dst
= 0;
828 ptrdiff_t stride
= 1;
829 ptrdiff_t extent
= 1;
830 for (j
= 0; j
< rank
-1; j
++)
832 array_offset_dst
+= ((i
/ (extent
*stride
))
833 % (dest
->dim
[j
]._ubound
834 - dest
->dim
[j
].lower_bound
+ 1))
835 * dest
->dim
[j
]._stride
;
836 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
837 stride
= dest
->dim
[j
]._stride
;
839 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
840 void *dst
= (void *)((char *) TOKEN (token
) + offset
841 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
));
842 void *sr
= tmp
+ array_offset_sr
;
843 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
844 && dst_kind
== src_kind
)
847 dst_size
> src_size
? src_size
: dst_size
);
848 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
849 && dst_size
> src_size
)
852 memset ((void*)(char*) dst
+ src_size
, ' ',
854 else /* dst_kind == 4. */
855 for (k
= src_size
/4; k
< dst_size
/4; k
++)
856 ((int32_t*) dst
)[k
] = (int32_t) ' ';
859 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
860 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
861 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
862 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
864 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
865 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
);
866 if (GFC_DESCRIPTOR_RANK (src
))
867 array_offset_sr
+= src_size
;
873 for (i
= 0; i
< size
; i
++)
875 ptrdiff_t array_offset_dst
= 0;
876 ptrdiff_t stride
= 1;
877 ptrdiff_t extent
= 1;
878 for (j
= 0; j
< rank
-1; j
++)
880 array_offset_dst
+= ((i
/ (extent
*stride
))
881 % (dest
->dim
[j
]._ubound
882 - dest
->dim
[j
].lower_bound
+ 1))
883 * dest
->dim
[j
]._stride
;
884 extent
= (dest
->dim
[j
]._ubound
- dest
->dim
[j
].lower_bound
+ 1);
885 stride
= dest
->dim
[j
]._stride
;
887 array_offset_dst
+= (i
/ extent
) * dest
->dim
[rank
-1]._stride
;
888 void *dst
= (void *)((char *) TOKEN (token
) + offset
889 + array_offset_dst
*GFC_DESCRIPTOR_SIZE (dest
));
891 if (GFC_DESCRIPTOR_RANK (src
) != 0)
893 ptrdiff_t array_offset_sr
= 0;
896 for (j
= 0; j
< GFC_DESCRIPTOR_RANK (src
)-1; j
++)
898 array_offset_sr
+= ((i
/ (extent
*stride
))
899 % (src
->dim
[j
]._ubound
900 - src
->dim
[j
].lower_bound
+ 1))
901 * src
->dim
[j
]._stride
;
902 extent
= (src
->dim
[j
]._ubound
- src
->dim
[j
].lower_bound
+ 1);
903 stride
= src
->dim
[j
]._stride
;
905 array_offset_sr
+= (i
/ extent
) * src
->dim
[rank
-1]._stride
;
906 sr
= (void *)((char *) src
->base_addr
907 + array_offset_sr
*GFC_DESCRIPTOR_SIZE (src
));
912 if (GFC_DESCRIPTOR_TYPE (dest
) == GFC_DESCRIPTOR_TYPE (src
)
913 && dst_kind
== src_kind
)
916 dst_size
> src_size
? src_size
: dst_size
);
917 if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_size
> src_size
)
920 memset ((void*)(char*) dst
+ src_size
, ' ', dst_size
-src_size
);
921 else /* dst_kind == 4. */
922 for (k
= src_size
/4; k
< dst_size
/4; k
++)
923 ((int32_t*) dst
)[k
] = (int32_t) ' ';
926 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
&& dst_kind
== 1)
927 assign_char1_from_char4 (dst_size
, src_size
, dst
, sr
);
928 else if (GFC_DESCRIPTOR_TYPE (dest
) == BT_CHARACTER
)
929 assign_char4_from_char1 (dst_size
, src_size
, dst
, sr
);
931 convert_type (dst
, GFC_DESCRIPTOR_TYPE (dest
), dst_kind
,
932 sr
, GFC_DESCRIPTOR_TYPE (src
), src_kind
);
938 _gfortran_caf_sendget (caf_token_t dst_token
, size_t dst_offset
,
939 int dst_image_index
, gfc_descriptor_t
*dest
,
940 caf_vector_t
*dst_vector
, caf_token_t src_token
,
942 int src_image_index
__attribute__ ((unused
)),
943 gfc_descriptor_t
*src
,
944 caf_vector_t
*src_vector
__attribute__ ((unused
)),
945 int dst_kind
, int src_kind
, bool may_require_tmp
)
947 /* FIXME: Handle vector subscript of 'src_vector'. */
948 /* For a single image, src->base_addr should be the same as src_token + offset
949 but to play save, we do it properly. */
950 void *src_base
= GFC_DESCRIPTOR_DATA (src
);
951 GFC_DESCRIPTOR_DATA (src
) = (void *) ((char *) TOKEN (src_token
) + src_offset
);
952 _gfortran_caf_send (dst_token
, dst_offset
, dst_image_index
, dest
, dst_vector
,
953 src
, dst_kind
, src_kind
, may_require_tmp
);
954 GFC_DESCRIPTOR_DATA (src
) = src_base
;
959 _gfortran_caf_atomic_define (caf_token_t token
, size_t offset
,
960 int image_index
__attribute__ ((unused
)),
961 void *value
, int *stat
,
962 int type
__attribute__ ((unused
)), int kind
)
966 uint32_t *atom
= (uint32_t *) ((char *) TOKEN (token
) + offset
);
968 __atomic_store (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
975 _gfortran_caf_atomic_ref (caf_token_t token
, size_t offset
,
976 int image_index
__attribute__ ((unused
)),
977 void *value
, int *stat
,
978 int type
__attribute__ ((unused
)), int kind
)
982 uint32_t *atom
= (uint32_t *) ((char *) TOKEN (token
) + offset
);
984 __atomic_load (atom
, (uint32_t *) value
, __ATOMIC_RELAXED
);
992 _gfortran_caf_atomic_cas (caf_token_t token
, size_t offset
,
993 int image_index
__attribute__ ((unused
)),
994 void *old
, void *compare
, void *new_val
, int *stat
,
995 int type
__attribute__ ((unused
)), int kind
)
999 uint32_t *atom
= (uint32_t *) ((char *) TOKEN (token
) + offset
);
1001 *(uint32_t *) old
= *(uint32_t *) compare
;
1002 (void) __atomic_compare_exchange_n (atom
, (uint32_t *) old
,
1003 *(uint32_t *) new_val
, false,
1004 __ATOMIC_RELAXED
, __ATOMIC_RELAXED
);
1011 _gfortran_caf_atomic_op (int op
, caf_token_t token
, size_t offset
,
1012 int image_index
__attribute__ ((unused
)),
1013 void *value
, void *old
, int *stat
,
1014 int type
__attribute__ ((unused
)), int kind
)
1019 uint32_t *atom
= (uint32_t *) ((char *) TOKEN (token
) + offset
);
1023 case GFC_CAF_ATOMIC_ADD
:
1024 res
= __atomic_fetch_add (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
1026 case GFC_CAF_ATOMIC_AND
:
1027 res
= __atomic_fetch_and (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
1029 case GFC_CAF_ATOMIC_OR
:
1030 res
= __atomic_fetch_or (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
1032 case GFC_CAF_ATOMIC_XOR
:
1033 res
= __atomic_fetch_xor (atom
, *(uint32_t *) value
, __ATOMIC_RELAXED
);
1036 __builtin_unreachable();
1040 *(uint32_t *) old
= res
;
1048 _gfortran_caf_lock (caf_token_t token
, size_t index
,
1049 int image_index
__attribute__ ((unused
)),
1050 int *aquired_lock
, int *stat
, char *errmsg
, int errmsg_len
)
1052 const char *msg
= "Already locked";
1053 bool *lock
= &((bool *) TOKEN (token
))[index
];
1059 *aquired_lock
= (int) true;
1067 *aquired_lock
= (int) false;
1079 int len
= ((int) sizeof (msg
) > errmsg_len
) ? errmsg_len
1080 : (int) sizeof (msg
);
1081 memcpy (errmsg
, msg
, len
);
1082 if (errmsg_len
> len
)
1083 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
1087 _gfortran_caf_error_stop_str (msg
, (int32_t) strlen (msg
));
1092 _gfortran_caf_unlock (caf_token_t token
, size_t index
,
1093 int image_index
__attribute__ ((unused
)),
1094 int *stat
, char *errmsg
, int errmsg_len
)
1096 const char *msg
= "Variable is not locked";
1097 bool *lock
= &((bool *) TOKEN (token
))[index
];
1112 int len
= ((int) sizeof (msg
) > errmsg_len
) ? errmsg_len
1113 : (int) sizeof (msg
);
1114 memcpy (errmsg
, msg
, len
);
1115 if (errmsg_len
> len
)
1116 memset (&errmsg
[len
], ' ', errmsg_len
-len
);
1120 _gfortran_caf_error_stop_str (msg
, (int32_t) strlen (msg
));