Mercurial > hg > CbC > CbC_gcc

comparison libgfortran/intrinsics/spread_generic.c @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 /* Generic implementation of the SPREAD intrinsic
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
11
12 Ligbfortran 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 "libgfortran.h"
27 #include <string.h>
28
29 static void
30 spread_internal (gfc_array_char *ret, const gfc_array_char *source,
31 const index_type *along, const index_type *pncopies)
32 {
33 /* r.* indicates the return array. */
34 index_type rstride[GFC_MAX_DIMENSIONS];
35 index_type rstride0;
36 index_type rdelta = 0;
37 index_type rrank;
38 index_type rs;
39 char *rptr;
40 char *dest;
41 /* s.* indicates the source array. */
42 index_type sstride[GFC_MAX_DIMENSIONS];
43 index_type sstride0;
44 index_type srank;
45 const char *sptr;
46
47 index_type count[GFC_MAX_DIMENSIONS];
48 index_type extent[GFC_MAX_DIMENSIONS];
49 index_type n;
50 index_type dim;
51 index_type ncopies;
52 index_type size;
53
54 size = GFC_DESCRIPTOR_SIZE(source);
55
56 srank = GFC_DESCRIPTOR_RANK(source);
57
58 rrank = srank + 1;
59 if (rrank > GFC_MAX_DIMENSIONS)
60 runtime_error ("return rank too large in spread()");
61
62 if (*along > rrank)
63 runtime_error ("dim outside of rank in spread()");
64
65 ncopies = *pncopies;
66
67 if (ret->base_addr == NULL)
68 {
69 /* The front end has signalled that we need to populate the
70 return array descriptor. */
71
72 size_t ub, stride;
73
74 ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
75 dim = 0;
76 rs = 1;
77 for (n = 0; n < rrank; n++)
78 {
79 stride = rs;
80 if (n == *along - 1)
81 {
82 ub = ncopies - 1;
83 rdelta = rs * size;
84 rs *= ncopies;
85 }
86 else
87 {
88 count[dim] = 0;
89 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
90 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
91 rstride[dim] = rs * size;
92
93 ub = extent[dim]-1;
94 rs *= extent[dim];
95 dim++;
96 }
97
98 GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
99 }
100 ret->offset = 0;
101 ret->base_addr = xmallocarray (rs, size);
102
103 if (rs <= 0)
104 return;
105 }
106 else
107 {
108 int zero_sized;
109
110 zero_sized = 0;
111
112 dim = 0;
113 if (GFC_DESCRIPTOR_RANK(ret) != rrank)
114 runtime_error ("rank mismatch in spread()");
115
116 if (compile_options.bounds_check)
117 {
118 for (n = 0; n < rrank; n++)
119 {
120 index_type ret_extent;
121
122 ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
123 if (n == *along - 1)
124 {
125 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
126
127 if (ret_extent != ncopies)
128 runtime_error("Incorrect extent in return value of SPREAD"
129 " intrinsic in dimension %ld: is %ld,"
130 " should be %ld", (long int) n+1,
131 (long int) ret_extent, (long int) ncopies);
132 }
133 else
134 {
135 count[dim] = 0;
136 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
137 if (ret_extent != extent[dim])
138 runtime_error("Incorrect extent in return value of SPREAD"
139 " intrinsic in dimension %ld: is %ld,"
140 " should be %ld", (long int) n+1,
141 (long int) ret_extent,
142 (long int) extent[dim]);
143
144 if (extent[dim] <= 0)
145 zero_sized = 1;
146 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
147 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
148 dim++;
149 }
150 }
151 }
152 else
153 {
154 for (n = 0; n < rrank; n++)
155 {
156 if (n == *along - 1)
157 {
158 rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
159 }
160 else
161 {
162 count[dim] = 0;
163 extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
164 if (extent[dim] <= 0)
165 zero_sized = 1;
166 sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
167 rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
168 dim++;
169 }
170 }
171 }
172
173 if (zero_sized)
174 return;
175
176 if (sstride[0] == 0)
177 sstride[0] = size;
178 }
179 sstride0 = sstride[0];
180 rstride0 = rstride[0];
181 rptr = ret->base_addr;
182 sptr = source->base_addr;
183
184 while (sptr)
185 {
186 /* Spread this element. */
187 dest = rptr;
188 for (n = 0; n < ncopies; n++)
189 {
190 memcpy (dest, sptr, size);
191 dest += rdelta;
192 }
193 /* Advance to the next element. */
194 sptr += sstride0;
195 rptr += rstride0;
196 count[0]++;
197 n = 0;
198 while (count[n] == extent[n])
199 {
200 /* When we get to the end of a dimension, reset it and increment
201 the next dimension. */
202 count[n] = 0;
203 /* We could precalculate these products, but this is a less
204 frequently used path so probably not worth it. */
205 sptr -= sstride[n] * extent[n];
206 rptr -= rstride[n] * extent[n];
207 n++;
208 if (n >= srank)
209 {
210 /* Break out of the loop. */
211 sptr = NULL;
212 break;
213 }
214 else
215 {
216 count[n]++;
217 sptr += sstride[n];
218 rptr += rstride[n];
219 }
220 }
221 }
222 }
223
224 /* This version of spread_internal treats the special case of a scalar
225 source. This is much simpler than the more general case above. */
226
227 static void
228 spread_internal_scalar (gfc_array_char *ret, const char *source,
229 const index_type *along, const index_type *pncopies)
230 {
231 int n;
232 int ncopies = *pncopies;
233 char * dest;
234 size_t size;
235
236 size = GFC_DESCRIPTOR_SIZE(ret);
237
238 if (GFC_DESCRIPTOR_RANK (ret) != 1)
239 runtime_error ("incorrect destination rank in spread()");
240
241 if (*along > 1)
242 runtime_error ("dim outside of rank in spread()");
243
244 if (ret->base_addr == NULL)
245 {
246 ret->base_addr = xmallocarray (ncopies, size);
247 ret->offset = 0;
248 GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
249 }
250 else
251 {
252 if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
253 / GFC_DESCRIPTOR_STRIDE(ret,0))
254 runtime_error ("dim too large in spread()");
255 }
256
257 for (n = 0; n < ncopies; n++)
258 {
259 dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
260 memcpy (dest , source, size);
261 }
262 }
263
264 extern void spread (gfc_array_char *, const gfc_array_char *,
265 const index_type *, const index_type *);
266 export_proto(spread);
267
268 void
269 spread (gfc_array_char *ret, const gfc_array_char *source,
270 const index_type *along, const index_type *pncopies)
271 {
272 index_type type_size;
273
274 type_size = GFC_DTYPE_TYPE_SIZE(ret);
275 switch(type_size)
276 {
277 case GFC_DTYPE_DERIVED_1:
278 case GFC_DTYPE_LOGICAL_1:
279 case GFC_DTYPE_INTEGER_1:
280 spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
281 *along, *pncopies);
282 return;
283
284 case GFC_DTYPE_LOGICAL_2:
285 case GFC_DTYPE_INTEGER_2:
286 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
287 *along, *pncopies);
288 return;
289
290 case GFC_DTYPE_LOGICAL_4:
291 case GFC_DTYPE_INTEGER_4:
292 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
293 *along, *pncopies);
294 return;
295
296 case GFC_DTYPE_LOGICAL_8:
297 case GFC_DTYPE_INTEGER_8:
298 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
299 *along, *pncopies);
300 return;
301
302 #ifdef HAVE_GFC_INTEGER_16
303 case GFC_DTYPE_LOGICAL_16:
304 case GFC_DTYPE_INTEGER_16:
305 spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
306 *along, *pncopies);
307 return;
308 #endif
309
310 case GFC_DTYPE_REAL_4:
311 spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
312 *along, *pncopies);
313 return;
314
315 case GFC_DTYPE_REAL_8:
316 spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
317 *along, *pncopies);
318 return;
319
320 /* FIXME: This here is a hack, which will have to be removed when
321 the array descriptor is reworked. Currently, we don't store the
322 kind value for the type, but only the size. Because on targets with
323 __float128, we have sizeof(logn double) == sizeof(__float128),
324 we cannot discriminate here and have to fall back to the generic
325 handling (which is suboptimal). */
326 #if !defined(GFC_REAL_16_IS_FLOAT128)
327 # ifdef GFC_HAVE_REAL_10
328 case GFC_DTYPE_REAL_10:
329 spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
330 *along, *pncopies);
331 return;
332 # endif
333
334 # ifdef GFC_HAVE_REAL_16
335 case GFC_DTYPE_REAL_16:
336 spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
337 *along, *pncopies);
338 return;
339 # endif
340 #endif
341
342 case GFC_DTYPE_COMPLEX_4:
343 spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
344 *along, *pncopies);
345 return;
346
347 case GFC_DTYPE_COMPLEX_8:
348 spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
349 *along, *pncopies);
350 return;
351
352 /* FIXME: This here is a hack, which will have to be removed when
353 the array descriptor is reworked. Currently, we don't store the
354 kind value for the type, but only the size. Because on targets with
355 __float128, we have sizeof(logn double) == sizeof(__float128),
356 we cannot discriminate here and have to fall back to the generic
357 handling (which is suboptimal). */
358 #if !defined(GFC_REAL_16_IS_FLOAT128)
359 # ifdef GFC_HAVE_COMPLEX_10
360 case GFC_DTYPE_COMPLEX_10:
361 spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
362 *along, *pncopies);
363 return;
364 # endif
365
366 # ifdef GFC_HAVE_COMPLEX_16
367 case GFC_DTYPE_COMPLEX_16:
368 spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
369 *along, *pncopies);
370 return;
371 # endif
372 #endif
373
374 case GFC_DTYPE_DERIVED_2:
375 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
376 break;
377 else
378 {
379 spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
380 *along, *pncopies);
381 return;
382 }
383
384 case GFC_DTYPE_DERIVED_4:
385 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
386 break;
387 else
388 {
389 spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
390 *along, *pncopies);
391 return;
392 }
393
394 case GFC_DTYPE_DERIVED_8:
395 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
396 break;
397 else
398 {
399 spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
400 *along, *pncopies);
401 return;
402 }
403
404 #ifdef HAVE_GFC_INTEGER_16
405 case GFC_DTYPE_DERIVED_16:
406 if (GFC_UNALIGNED_16(ret->base_addr)
407 || GFC_UNALIGNED_16(source->base_addr))
408 break;
409 else
410 {
411 spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
412 *along, *pncopies);
413 return;
414 }
415 #endif
416 }
417
418 spread_internal (ret, source, along, pncopies);
419 }
420
421
422 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
423 const gfc_array_char *, const index_type *,
424 const index_type *, GFC_INTEGER_4);
425 export_proto(spread_char);
426
427 void
428 spread_char (gfc_array_char *ret,
429 GFC_INTEGER_4 ret_length __attribute__((unused)),
430 const gfc_array_char *source, const index_type *along,
431 const index_type *pncopies,
432 GFC_INTEGER_4 source_length __attribute__((unused)))
433 {
434 spread_internal (ret, source, along, pncopies);
435 }
436
437
438 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
439 const gfc_array_char *, const index_type *,
440 const index_type *, GFC_INTEGER_4);
441 export_proto(spread_char4);
442
443 void
444 spread_char4 (gfc_array_char *ret,
445 GFC_INTEGER_4 ret_length __attribute__((unused)),
446 const gfc_array_char *source, const index_type *along,
447 const index_type *pncopies,
448 GFC_INTEGER_4 source_length __attribute__((unused)))
449 {
450 spread_internal (ret, source, along, pncopies);
451 }
452
453
454 /* The following are the prototypes for the versions of spread with a
455 scalar source. */
456
457 extern void spread_scalar (gfc_array_char *, const char *,
458 const index_type *, const index_type *);
459 export_proto(spread_scalar);
460
461 void
462 spread_scalar (gfc_array_char *ret, const char *source,
463 const index_type *along, const index_type *pncopies)
464 {
465 index_type type_size;
466
467 if (!ret->dtype)
468 runtime_error ("return array missing descriptor in spread()");
469
470 type_size = GFC_DTYPE_TYPE_SIZE(ret);
471 switch(type_size)
472 {
473 case GFC_DTYPE_DERIVED_1:
474 case GFC_DTYPE_LOGICAL_1:
475 case GFC_DTYPE_INTEGER_1:
476 spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
477 *along, *pncopies);
478 return;
479
480 case GFC_DTYPE_LOGICAL_2:
481 case GFC_DTYPE_INTEGER_2:
482 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
483 *along, *pncopies);
484 return;
485
486 case GFC_DTYPE_LOGICAL_4:
487 case GFC_DTYPE_INTEGER_4:
488 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
489 *along, *pncopies);
490 return;
491
492 case GFC_DTYPE_LOGICAL_8:
493 case GFC_DTYPE_INTEGER_8:
494 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
495 *along, *pncopies);
496 return;
497
498 #ifdef HAVE_GFC_INTEGER_16
499 case GFC_DTYPE_LOGICAL_16:
500 case GFC_DTYPE_INTEGER_16:
501 spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
502 *along, *pncopies);
503 return;
504 #endif
505
506 case GFC_DTYPE_REAL_4:
507 spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
508 *along, *pncopies);
509 return;
510
511 case GFC_DTYPE_REAL_8:
512 spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
513 *along, *pncopies);
514 return;
515
516 /* FIXME: This here is a hack, which will have to be removed when
517 the array descriptor is reworked. Currently, we don't store the
518 kind value for the type, but only the size. Because on targets with
519 __float128, we have sizeof(logn double) == sizeof(__float128),
520 we cannot discriminate here and have to fall back to the generic
521 handling (which is suboptimal). */
522 #if !defined(GFC_REAL_16_IS_FLOAT128)
523 # ifdef HAVE_GFC_REAL_10
524 case GFC_DTYPE_REAL_10:
525 spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
526 *along, *pncopies);
527 return;
528 # endif
529
530 # ifdef HAVE_GFC_REAL_16
531 case GFC_DTYPE_REAL_16:
532 spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
533 *along, *pncopies);
534 return;
535 # endif
536 #endif
537
538 case GFC_DTYPE_COMPLEX_4:
539 spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
540 *along, *pncopies);
541 return;
542
543 case GFC_DTYPE_COMPLEX_8:
544 spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
545 *along, *pncopies);
546 return;
547
548 /* FIXME: This here is a hack, which will have to be removed when
549 the array descriptor is reworked. Currently, we don't store the
550 kind value for the type, but only the size. Because on targets with
551 __float128, we have sizeof(logn double) == sizeof(__float128),
552 we cannot discriminate here and have to fall back to the generic
553 handling (which is suboptimal). */
554 #if !defined(GFC_REAL_16_IS_FLOAT128)
555 # ifdef HAVE_GFC_COMPLEX_10
556 case GFC_DTYPE_COMPLEX_10:
557 spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
558 *along, *pncopies);
559 return;
560 # endif
561
562 # ifdef HAVE_GFC_COMPLEX_16
563 case GFC_DTYPE_COMPLEX_16:
564 spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
565 *along, *pncopies);
566 return;
567 # endif
568 #endif
569
570 case GFC_DTYPE_DERIVED_2:
571 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
572 break;
573 else
574 {
575 spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
576 *along, *pncopies);
577 return;
578 }
579
580 case GFC_DTYPE_DERIVED_4:
581 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
582 break;
583 else
584 {
585 spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
586 *along, *pncopies);
587 return;
588 }
589
590 case GFC_DTYPE_DERIVED_8:
591 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
592 break;
593 else
594 {
595 spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
596 *along, *pncopies);
597 return;
598 }
599 #ifdef HAVE_GFC_INTEGER_16
600 case GFC_DTYPE_DERIVED_16:
601 if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
602 break;
603 else
604 {
605 spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
606 *along, *pncopies);
607 return;
608 }
609 #endif
610 }
611
612 spread_internal_scalar (ret, source, along, pncopies);
613 }
614
615
616 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
617 const char *, const index_type *,
618 const index_type *, GFC_INTEGER_4);
619 export_proto(spread_char_scalar);
620
621 void
622 spread_char_scalar (gfc_array_char *ret,
623 GFC_INTEGER_4 ret_length __attribute__((unused)),
624 const char *source, const index_type *along,
625 const index_type *pncopies,
626 GFC_INTEGER_4 source_length __attribute__((unused)))
627 {
628 if (!ret->dtype)
629 runtime_error ("return array missing descriptor in spread()");
630 spread_internal_scalar (ret, source, along, pncopies);
631 }
632
633
634 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
635 const char *, const index_type *,
636 const index_type *, GFC_INTEGER_4);
637 export_proto(spread_char4_scalar);
638
639 void
640 spread_char4_scalar (gfc_array_char *ret,
641 GFC_INTEGER_4 ret_length __attribute__((unused)),
642 const char *source, const index_type *along,
643 const index_type *pncopies,
644 GFC_INTEGER_4 source_length __attribute__((unused)))
645 {
646 if (!ret->dtype)
647 runtime_error ("return array missing descriptor in spread()");
648 spread_internal_scalar (ret, source, along, pncopies);
649
650 }
651