1 /* Generic implementation of the CSHIFT intrinsic
2 Copyright (C) 2003-2013 Free Software Foundation, Inc.
3 Contributed by Feng Wang <wf_cs@yahoo.com>
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 Libgfortran 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 <stdlib.h>
28 #include <assert.h>
29 #include <string.h>
30
31 static void
cshift0(gfc_array_char * ret,const gfc_array_char * array,ptrdiff_t shift,int which,index_type size)32 cshift0 (gfc_array_char * ret, const gfc_array_char * array,
33 ptrdiff_t shift, int which, index_type size)
34 {
35 /* r.* indicates the return array. */
36 index_type rstride[GFC_MAX_DIMENSIONS];
37 index_type rstride0;
38 index_type roffset;
39 char *rptr;
40
41 /* s.* indicates the source array. */
42 index_type sstride[GFC_MAX_DIMENSIONS];
43 index_type sstride0;
44 index_type soffset;
45 const char *sptr;
46
47 index_type count[GFC_MAX_DIMENSIONS];
48 index_type extent[GFC_MAX_DIMENSIONS];
49 index_type dim;
50 index_type len;
51 index_type n;
52 index_type arraysize;
53
54 index_type type_size;
55
56 if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
57 runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
58
59 arraysize = size0 ((array_t *) array);
60
61 if (ret->base_addr == NULL)
62 {
63 int i;
64
65 ret->offset = 0;
66 ret->dtype = array->dtype;
67 for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
68 {
69 index_type ub, str;
70
71 ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
72
73 if (i == 0)
74 str = 1;
75 else
76 str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
77 GFC_DESCRIPTOR_STRIDE(ret,i-1);
78
79 GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
80 }
81
82 /* xmalloc allocates a single byte for zero size. */
83 ret->base_addr = xmalloc (size * arraysize);
84 }
85 else if (unlikely (compile_options.bounds_check))
86 {
87 bounds_equal_extents ((array_t *) ret, (array_t *) array,
88 "return value", "CSHIFT");
89 }
90
91 if (arraysize == 0)
92 return;
93
94 type_size = GFC_DTYPE_TYPE_SIZE (array);
95
96 switch(type_size)
97 {
98 case GFC_DTYPE_LOGICAL_1:
99 case GFC_DTYPE_INTEGER_1:
100 case GFC_DTYPE_DERIVED_1:
101 cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
102 return;
103
104 case GFC_DTYPE_LOGICAL_2:
105 case GFC_DTYPE_INTEGER_2:
106 cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
107 return;
108
109 case GFC_DTYPE_LOGICAL_4:
110 case GFC_DTYPE_INTEGER_4:
111 cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
112 return;
113
114 case GFC_DTYPE_LOGICAL_8:
115 case GFC_DTYPE_INTEGER_8:
116 cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
117 return;
118
119 #ifdef HAVE_GFC_INTEGER_16
120 case GFC_DTYPE_LOGICAL_16:
121 case GFC_DTYPE_INTEGER_16:
122 cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
123 which);
124 return;
125 #endif
126
127 case GFC_DTYPE_REAL_4:
128 cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
129 return;
130
131 case GFC_DTYPE_REAL_8:
132 cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
133 return;
134
135 /* FIXME: This here is a hack, which will have to be removed when
136 the array descriptor is reworked. Currently, we don't store the
137 kind value for the type, but only the size. Because on targets with
138 __float128, we have sizeof(logn double) == sizeof(__float128),
139 we cannot discriminate here and have to fall back to the generic
140 handling (which is suboptimal). */
141 #if !defined(GFC_REAL_16_IS_FLOAT128)
142 # ifdef HAVE_GFC_REAL_10
143 case GFC_DTYPE_REAL_10:
144 cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
145 which);
146 return;
147 # endif
148
149 # ifdef HAVE_GFC_REAL_16
150 case GFC_DTYPE_REAL_16:
151 cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
152 which);
153 return;
154 # endif
155 #endif
156
157 case GFC_DTYPE_COMPLEX_4:
158 cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
159 return;
160
161 case GFC_DTYPE_COMPLEX_8:
162 cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
163 return;
164
165 /* FIXME: This here is a hack, which will have to be removed when
166 the array descriptor is reworked. Currently, we don't store the
167 kind value for the type, but only the size. Because on targets with
168 __float128, we have sizeof(logn double) == sizeof(__float128),
169 we cannot discriminate here and have to fall back to the generic
170 handling (which is suboptimal). */
171 #if !defined(GFC_REAL_16_IS_FLOAT128)
172 # ifdef HAVE_GFC_COMPLEX_10
173 case GFC_DTYPE_COMPLEX_10:
174 cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
175 which);
176 return;
177 # endif
178
179 # ifdef HAVE_GFC_COMPLEX_16
180 case GFC_DTYPE_COMPLEX_16:
181 cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
182 which);
183 return;
184 # endif
185 #endif
186
187 default:
188 break;
189 }
190
191 switch (size)
192 {
193 /* Let's check the actual alignment of the data pointers. If they
194 are suitably aligned, we can safely call the unpack functions. */
195
196 case sizeof (GFC_INTEGER_1):
197 cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift,
198 which);
199 break;
200
201 case sizeof (GFC_INTEGER_2):
202 if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr))
203 break;
204 else
205 {
206 cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift,
207 which);
208 return;
209 }
210
211 case sizeof (GFC_INTEGER_4):
212 if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr))
213 break;
214 else
215 {
216 cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift,
217 which);
218 return;
219 }
220
221 case sizeof (GFC_INTEGER_8):
222 if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr))
223 {
224 /* Let's try to use the complex routines. First, a sanity
225 check that the sizes match; this should be optimized to
226 a no-op. */
227 if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4))
228 break;
229
230 if (GFC_UNALIGNED_C4(ret->base_addr)
231 || GFC_UNALIGNED_C4(array->base_addr))
232 break;
233
234 cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
235 which);
236 return;
237 }
238 else
239 {
240 cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
241 which);
242 return;
243 }
244
245 #ifdef HAVE_GFC_INTEGER_16
246 case sizeof (GFC_INTEGER_16):
247 if (GFC_UNALIGNED_16(ret->base_addr)
248 || GFC_UNALIGNED_16(array->base_addr))
249 {
250 /* Let's try to use the complex routines. First, a sanity
251 check that the sizes match; this should be optimized to
252 a no-op. */
253 if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
254 break;
255
256 if (GFC_UNALIGNED_C8(ret->base_addr)
257 || GFC_UNALIGNED_C8(array->base_addr))
258 break;
259
260 cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
261 which);
262 return;
263 }
264 else
265 {
266 cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
267 shift, which);
268 return;
269 }
270 #else
271 case sizeof (GFC_COMPLEX_8):
272
273 if (GFC_UNALIGNED_C8(ret->base_addr)
274 || GFC_UNALIGNED_C8(array->base_addr))
275 break;
276 else
277 {
278 cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
279 which);
280 return;
281 }
282 #endif
283
284 default:
285 break;
286 }
287
288
289 which = which - 1;
290 sstride[0] = 0;
291 rstride[0] = 0;
292
293 extent[0] = 1;
294 count[0] = 0;
295 n = 0;
296 /* Initialized for avoiding compiler warnings. */
297 roffset = size;
298 soffset = size;
299 len = 0;
300
301 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
302 {
303 if (dim == which)
304 {
305 roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
306 if (roffset == 0)
307 roffset = size;
308 soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
309 if (soffset == 0)
310 soffset = size;
311 len = GFC_DESCRIPTOR_EXTENT(array,dim);
312 }
313 else
314 {
315 count[n] = 0;
316 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
317 rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
318 sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
319 n++;
320 }
321 }
322 if (sstride[0] == 0)
323 sstride[0] = size;
324 if (rstride[0] == 0)
325 rstride[0] = size;
326
327 dim = GFC_DESCRIPTOR_RANK (array);
328 rstride0 = rstride[0];
329 sstride0 = sstride[0];
330 rptr = ret->base_addr;
331 sptr = array->base_addr;
332
333 shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
334 if (shift < 0)
335 shift += len;
336
337 while (rptr)
338 {
339 /* Do the shift for this dimension. */
340
341 /* If elements are contiguous, perform the operation
342 in two block moves. */
343 if (soffset == size && roffset == size)
344 {
345 size_t len1 = shift * size;
346 size_t len2 = (len - shift) * size;
347 memcpy (rptr, sptr + len1, len2);
348 memcpy (rptr + len2, sptr, len1);
349 }
350 else
351 {
352 /* Otherwise, we'll have to perform the copy one element at
353 a time. */
354 char *dest = rptr;
355 const char *src = &sptr[shift * soffset];
356
357 for (n = 0; n < len - shift; n++)
358 {
359 memcpy (dest, src, size);
360 dest += roffset;
361 src += soffset;
362 }
363 for (src = sptr, n = 0; n < shift; n++)
364 {
365 memcpy (dest, src, size);
366 dest += roffset;
367 src += soffset;
368 }
369 }
370
371 /* Advance to the next section. */
372 rptr += rstride0;
373 sptr += sstride0;
374 count[0]++;
375 n = 0;
376 while (count[n] == extent[n])
377 {
378 /* When we get to the end of a dimension, reset it and increment
379 the next dimension. */
380 count[n] = 0;
381 /* We could precalculate these products, but this is a less
382 frequently used path so probably not worth it. */
383 rptr -= rstride[n] * extent[n];
384 sptr -= sstride[n] * extent[n];
385 n++;
386 if (n >= dim - 1)
387 {
388 /* Break out of the loop. */
389 rptr = NULL;
390 break;
391 }
392 else
393 {
394 count[n]++;
395 rptr += rstride[n];
396 sptr += sstride[n];
397 }
398 }
399 }
400 }
401
402 #define DEFINE_CSHIFT(N) \
403 extern void cshift0_##N (gfc_array_char *, const gfc_array_char *, \
404 const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
405 export_proto(cshift0_##N); \
406 \
407 void \
408 cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \
409 const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \
410 { \
411 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
412 GFC_DESCRIPTOR_SIZE (array)); \
413 } \
414 \
415 extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \
416 const gfc_array_char *, \
417 const GFC_INTEGER_##N *, \
418 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
419 export_proto(cshift0_##N##_char); \
420 \
421 void \
422 cshift0_##N##_char (gfc_array_char *ret, \
423 GFC_INTEGER_4 ret_length __attribute__((unused)), \
424 const gfc_array_char *array, \
425 const GFC_INTEGER_##N *pshift, \
426 const GFC_INTEGER_##N *pdim, \
427 GFC_INTEGER_4 array_length) \
428 { \
429 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \
430 } \
431 \
432 extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \
433 const gfc_array_char *, \
434 const GFC_INTEGER_##N *, \
435 const GFC_INTEGER_##N *, GFC_INTEGER_4); \
436 export_proto(cshift0_##N##_char4); \
437 \
438 void \
439 cshift0_##N##_char4 (gfc_array_char *ret, \
440 GFC_INTEGER_4 ret_length __attribute__((unused)), \
441 const gfc_array_char *array, \
442 const GFC_INTEGER_##N *pshift, \
443 const GFC_INTEGER_##N *pdim, \
444 GFC_INTEGER_4 array_length) \
445 { \
446 cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \
447 array_length * sizeof (gfc_char4_t)); \
448 }
449
450 DEFINE_CSHIFT (1);
451 DEFINE_CSHIFT (2);
452 DEFINE_CSHIFT (4);
453 DEFINE_CSHIFT (8);
454 #ifdef HAVE_GFC_INTEGER_16
455 DEFINE_CSHIFT (16);
456 #endif
457