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