libgfortran/intrinsics/cshift0.c

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