OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [intrinsics/] [cshift0.c] - Blame information for rev 733

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
/* Generic implementation of the CSHIFT intrinsic
2
   Copyright 2003, 2005, 2006, 2007, 2010 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
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->data == 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
      /* internal_malloc_size allocates a single byte for zero size.  */
83
      ret->data = internal_malloc_size (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->data) || GFC_UNALIGNED_2(array->data))
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->data) || GFC_UNALIGNED_4(array->data))
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->data) || GFC_UNALIGNED_8(array->data))
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->data) || GFC_UNALIGNED_C4(array->data))
231
            break;
232
 
233
          cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
234
                      which);
235
          return;
236
        }
237
      else
238
        {
239
          cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
240
                      which);
241
          return;
242
        }
243
 
244
#ifdef HAVE_GFC_INTEGER_16
245
    case sizeof (GFC_INTEGER_16):
246
      if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data))
247
        {
248
          /* Let's try to use the complex routines.  First, a sanity
249
             check that the sizes match; this should be optimized to
250
             a no-op.  */
251
          if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
252
            break;
253
 
254
          if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data))
255
            break;
256
 
257
          cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
258
                      which);
259
          return;
260
        }
261
      else
262
        {
263
          cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
264
                       shift, which);
265
          return;
266
        }
267
#else
268
    case sizeof (GFC_COMPLEX_8):
269
 
270
      if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data))
271
        break;
272
      else
273
        {
274
          cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
275
                      which);
276
          return;
277
        }
278
#endif
279
 
280
    default:
281
      break;
282
    }
283
 
284
 
285
  which = which - 1;
286
  sstride[0] = 0;
287
  rstride[0] = 0;
288
 
289
  extent[0] = 1;
290
  count[0] = 0;
291
  n = 0;
292
  /* Initialized for avoiding compiler warnings.  */
293
  roffset = size;
294
  soffset = size;
295
  len = 0;
296
 
297
  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
298
    {
299
      if (dim == which)
300
        {
301
          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
302
          if (roffset == 0)
303
            roffset = size;
304
          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
305
          if (soffset == 0)
306
            soffset = size;
307
          len = GFC_DESCRIPTOR_EXTENT(array,dim);
308
        }
309
      else
310
        {
311
          count[n] = 0;
312
          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
313
          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
314
          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
315
          n++;
316
        }
317
    }
318
  if (sstride[0] == 0)
319
    sstride[0] = size;
320
  if (rstride[0] == 0)
321
    rstride[0] = size;
322
 
323
  dim = GFC_DESCRIPTOR_RANK (array);
324
  rstride0 = rstride[0];
325
  sstride0 = sstride[0];
326
  rptr = ret->data;
327
  sptr = array->data;
328
 
329
  shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
330
  if (shift < 0)
331
    shift += len;
332
 
333
  while (rptr)
334
    {
335
      /* Do the shift for this dimension.  */
336
 
337
      /* If elements are contiguous, perform the operation
338
         in two block moves.  */
339
      if (soffset == size && roffset == size)
340
        {
341
          size_t len1 = shift * size;
342
          size_t len2 = (len - shift) * size;
343
          memcpy (rptr, sptr + len1, len2);
344
          memcpy (rptr + len2, sptr, len1);
345
        }
346
      else
347
        {
348
          /* Otherwise, we'll have to perform the copy one element at
349
             a time.  */
350
          char *dest = rptr;
351
          const char *src = &sptr[shift * soffset];
352
 
353
          for (n = 0; n < len - shift; n++)
354
            {
355
              memcpy (dest, src, size);
356
              dest += roffset;
357
              src += soffset;
358
            }
359
          for (src = sptr, n = 0; n < shift; n++)
360
            {
361
              memcpy (dest, src, size);
362
              dest += roffset;
363
              src += soffset;
364
            }
365
        }
366
 
367
      /* Advance to the next section.  */
368
      rptr += rstride0;
369
      sptr += sstride0;
370
      count[0]++;
371
      n = 0;
372
      while (count[n] == extent[n])
373
        {
374
          /* When we get to the end of a dimension, reset it and increment
375
             the next dimension.  */
376
          count[n] = 0;
377
          /* We could precalculate these products, but this is a less
378
             frequently used path so probably not worth it.  */
379
          rptr -= rstride[n] * extent[n];
380
          sptr -= sstride[n] * extent[n];
381
          n++;
382
          if (n >= dim - 1)
383
            {
384
              /* Break out of the loop.  */
385
              rptr = NULL;
386
              break;
387
            }
388
          else
389
            {
390
              count[n]++;
391
              rptr += rstride[n];
392
              sptr += sstride[n];
393
            }
394
        }
395
    }
396
}
397
 
398
#define DEFINE_CSHIFT(N)                                                      \
399
  extern void cshift0_##N (gfc_array_char *, const gfc_array_char *,          \
400
                           const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \
401
  export_proto(cshift0_##N);                                                  \
402
                                                                              \
403
  void                                                                        \
404
  cshift0_##N (gfc_array_char *ret, const gfc_array_char *array,              \
405
               const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim)    \
406
  {                                                                           \
407
    cshift0 (ret, array, *pshift, pdim ? *pdim : 1,                           \
408
             GFC_DESCRIPTOR_SIZE (array));                                    \
409
  }                                                                           \
410
                                                                              \
411
  extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,            \
412
                                  const gfc_array_char *,                     \
413
                                  const GFC_INTEGER_##N *,                    \
414
                                  const GFC_INTEGER_##N *, GFC_INTEGER_4);    \
415
  export_proto(cshift0_##N##_char);                                           \
416
                                                                              \
417
  void                                                                        \
418
  cshift0_##N##_char (gfc_array_char *ret,                                    \
419
                      GFC_INTEGER_4 ret_length __attribute__((unused)),       \
420
                      const gfc_array_char *array,                            \
421
                      const GFC_INTEGER_##N *pshift,                          \
422
                      const GFC_INTEGER_##N *pdim,                            \
423
                      GFC_INTEGER_4 array_length)                             \
424
  {                                                                           \
425
    cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length);            \
426
  }                                                                           \
427
                                                                              \
428
  extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,           \
429
                                   const gfc_array_char *,                    \
430
                                   const GFC_INTEGER_##N *,                   \
431
                                   const GFC_INTEGER_##N *, GFC_INTEGER_4);   \
432
  export_proto(cshift0_##N##_char4);                                          \
433
                                                                              \
434
  void                                                                        \
435
  cshift0_##N##_char4 (gfc_array_char *ret,                                   \
436
                       GFC_INTEGER_4 ret_length __attribute__((unused)),      \
437
                       const gfc_array_char *array,                           \
438
                       const GFC_INTEGER_##N *pshift,                         \
439
                       const GFC_INTEGER_##N *pdim,                           \
440
                       GFC_INTEGER_4 array_length)                            \
441
  {                                                                           \
442
    cshift0 (ret, array, *pshift, pdim ? *pdim : 1,                           \
443
             array_length * sizeof (gfc_char4_t));                            \
444
  }
445
 
446
DEFINE_CSHIFT (1);
447
DEFINE_CSHIFT (2);
448
DEFINE_CSHIFT (4);
449
DEFINE_CSHIFT (8);
450
#ifdef HAVE_GFC_INTEGER_16
451
DEFINE_CSHIFT (16);
452
#endif

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.