libgfortran/intrinsics/eoshift0.c

   1 /* Generic implementation of the EOSHIFT intrinsic
   2    Copyright (C) 2002-2024 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 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
  30 static void
  31 eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
  32           index_type shift, const char * pbound, int which, index_type size,
  33           const char *filler, index_type filler_len)
  34 {
  35   /* r.* indicates the return array.  */
  36   index_type rstride[GFC_MAX_DIMENSIONS];
  37   index_type rstride0;
  38   index_type roffset;
  39   char * restrict rptr;
  40   char *dest;
  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   const char *src;
  47
  48   index_type count[GFC_MAX_DIMENSIONS];
  49   index_type extent[GFC_MAX_DIMENSIONS];
  50   index_type dim;
  51   index_type len;
  52   index_type n;
  53   index_type arraysize;
  54   bool do_blocked;
  55
  56   /* The compiler cannot figure out that these are set, initialize
  57      them to avoid warnings.  */
  58   len = 0;
  59   soffset = 0;
  60   roffset = 0;
  61
  62   arraysize = size0 ((array_t *) array);
  63
  64   if (ret->base_addr == NULL)
  65     {
  66       int i;
  67
  68       ret->offset = 0;
  69       GFC_DTYPE_COPY(ret,array);
  70       for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
  71         {
  72           index_type ub, str;
  73
  74           ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
  75
  76           if (i == 0)
  77             str = 1;
  78           else
  79             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
  80               * GFC_DESCRIPTOR_STRIDE(ret,i-1);
  81
  82           GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
  83
  84         }
  85
  86       /* xmallocarray allocates a single byte for zero size.  */
  87       ret->base_addr = xmallocarray (arraysize, size);
  88     }
  89   else if (unlikely (compile_options.bounds_check))
  90     {
  91       bounds_equal_extents ((array_t *) ret, (array_t *) array,
  92                                  "return value", "EOSHIFT");
  93     }
  94
  95   if (arraysize == 0)
  96     return;
  97
  98   which = which - 1;
  99
 100   extent[0] = 1;
 101   count[0] = 0;
 102   sstride[0] = -1;
 103   rstride[0] = -1;
 104
 105   if (which > 0)
 106     {
 107       /* Test if both ret and array are contiguous.  */
 108       index_type r_ex, a_ex;
 109       r_ex = 1;
 110       a_ex = 1;
 111       do_blocked = true;
 112       dim = GFC_DESCRIPTOR_RANK (array);
 113       for (n = 0; n < dim; n ++)
 114         {
 115           index_type rs, as;
 116           rs = GFC_DESCRIPTOR_STRIDE (ret, n);
 117           if (rs != r_ex)
 118             {
 119               do_blocked = false;
 120               break;
 121             }
 122           as = GFC_DESCRIPTOR_STRIDE (array, n);
 123           if (as != a_ex)
 124             {
 125               do_blocked = false;
 126               break;
 127             }
 128           r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
 129           a_ex *= GFC_DESCRIPTOR_EXTENT (array, n);
 130         }
 131     }
 132   else
 133     do_blocked = false;
 134
 135   n = 0;
 136
 137   if (do_blocked)
 138     {
 139       /* For contiguous arrays, use the relationship that
 140
 141          dimension(n1,n2,n3) :: a, b
 142          b = eoshift(a,sh,3)
 143
 144          can be dealt with as if
 145
 146          dimension(n1*n2*n3) :: an, bn
 147          bn = eoshift(a,sh*n1*n2,1)
 148
 149          so a block move can be used for dim>1.  */
 150       len = GFC_DESCRIPTOR_STRIDE(array, which)
 151         * GFC_DESCRIPTOR_EXTENT(array, which);
 152       shift *= GFC_DESCRIPTOR_STRIDE(array, which);
 153       roffset = size;
 154       soffset = size;
 155       for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 156         {
 157           count[n] = 0;
 158           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 159           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 160           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 161           n++;
 162         }
 163       count[n] = 0;
 164       dim = GFC_DESCRIPTOR_RANK (array) - which;
 165     }
 166   else
 167     {
 168       for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 169         {
 170           if (dim == which)
 171             {
 172               roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 173               if (roffset == 0)
 174                 roffset = size;
 175               soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 176               if (soffset == 0)
 177                 soffset = size;
 178               len = GFC_DESCRIPTOR_EXTENT(array,dim);
 179             }
 180           else
 181             {
 182               count[n] = 0;
 183               extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 184               rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
 185               sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
 186               n++;
 187             }
 188         }
 189       dim = GFC_DESCRIPTOR_RANK (array);
 190     }
 191
 192   if ((shift >= 0 ? shift : -shift) > len)
 193     {
 194       shift = len;
 195       len = 0;
 196     }
 197   else
 198     {
 199       if (shift > 0)
 200         len = len - shift;
 201       else
 202         len = len + shift;
 203     }
 204
 205   rstride0 = rstride[0];
 206   sstride0 = sstride[0];
 207   rptr = ret->base_addr;
 208   sptr = array->base_addr;
 209
 210   while (rptr)
 211     {
 212       /* Do the shift for this dimension.  */
 213       if (shift > 0)
 214         {
 215           src = &sptr[shift * soffset];
 216           dest = rptr;
 217         }
 218       else
 219         {
 220           src = sptr;
 221           dest = &rptr[-shift * roffset];
 222         }
 223       /* If the elements are contiguous, perform a single block move.  */
 224
 225       if (soffset == size && roffset == size)
 226         {
 227           size_t chunk = size * len;
 228           memcpy (dest, src, chunk);
 229           dest += chunk;
 230         }
 231       else
 232         {
 233           for (n = 0; n < len; n++)
 234             {
 235               memcpy (dest, src, size);
 236               dest += roffset;
 237               src += soffset;
 238             }
 239         }
 240       if (shift >= 0)
 241         {
 242           n = shift;
 243         }
 244       else
 245         {
 246           dest = rptr;
 247           n = -shift;
 248         }
 249
 250       if (pbound)
 251         while (n--)
 252           {
 253             memcpy (dest, pbound, size);
 254             dest += roffset;
 255           }
 256       else
 257         while (n--)
 258           {
 259             index_type i;
 260
 261             if (filler_len == 1)
 262               memset (dest, filler[0], size);
 263             else
 264               for (i = 0; i < size ; i += filler_len)
 265                 memcpy (&dest[i], filler, filler_len);
 266
 267             dest += roffset;
 268           }
 269
 270       /* Advance to the next section.  */
 271       rptr += rstride0;
 272       sptr += sstride0;
 273       count[0]++;
 274       n = 0;
 275       while (count[n] == extent[n])
 276         {
 277           /* When we get to the end of a dimension, reset it and increment
 278              the next dimension.  */
 279           count[n] = 0;
 280           /* We could precalculate these products, but this is a less
 281              frequently used path so probably not worth it.  */
 282           rptr -= rstride[n] * extent[n];
 283           sptr -= sstride[n] * extent[n];
 284           n++;
 285           if (n >= dim - 1)
 286             {
 287               /* Break out of the loop.  */
 288               rptr = NULL;
 289               break;
 290             }
 291           else
 292             {
 293               count[n]++;
 294               rptr += rstride[n];
 295               sptr += sstride[n];
 296             }
 297         }
 298     }
 299 }
 300
 301
 302 #define DEFINE_EOSHIFT(N)                                                     \
 303   extern void eoshift0_##N (gfc_array_char *, const gfc_array_char *,         \
 304                             const GFC_INTEGER_##N *, const char *,            \
 305                             const GFC_INTEGER_##N *);                         \
 306   export_proto(eoshift0_##N);                                                 \
 307                                                                               \
 308   void                                                                        \
 309   eoshift0_##N (gfc_array_char *ret, const gfc_array_char *array,             \
 310                 const GFC_INTEGER_##N *pshift, const char *pbound,            \
 311                 const GFC_INTEGER_##N *pdim)                                  \
 312   {                                                                           \
 313     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 314               GFC_DESCRIPTOR_SIZE (array), "\0", 1);                          \
 315   }                                                                           \
 316                                                                               \
 317   extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4,           \
 318                                    const gfc_array_char *,                    \
 319                                    const GFC_INTEGER_##N *, const char *,     \
 320                                    const GFC_INTEGER_##N *, GFC_INTEGER_4,    \
 321                                    GFC_INTEGER_4);                            \
 322   export_proto(eoshift0_##N##_char);                                          \
 323                                                                               \
 324   void                                                                        \
 325   eoshift0_##N##_char (gfc_array_char *ret,                                   \
 326                        GFC_INTEGER_4 ret_length __attribute__((unused)),      \
 327                        const gfc_array_char *array,                           \
 328                        const GFC_INTEGER_##N *pshift,                         \
 329                        const char *pbound,                                    \
 330                        const GFC_INTEGER_##N *pdim,                           \
 331                        GFC_INTEGER_4 array_length,                            \
 332                        GFC_INTEGER_4 bound_length __attribute__((unused)))    \
 333   {                                                                           \
 334     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 335               array_length, " ", 1);                                          \
 336   }                                                                           \
 337                                                                               \
 338   extern void eoshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4,          \
 339                                     const gfc_array_char *,                   \
 340                                     const GFC_INTEGER_##N *, const char *,    \
 341                                     const GFC_INTEGER_##N *, GFC_INTEGER_4,   \
 342                                     GFC_INTEGER_4);                           \
 343   export_proto(eoshift0_##N##_char4);                                         \
 344                                                                               \
 345   void                                                                        \
 346   eoshift0_##N##_char4 (gfc_array_char *ret,                                  \
 347                         GFC_INTEGER_4 ret_length __attribute__((unused)),     \
 348                         const gfc_array_char *array,                          \
 349                         const GFC_INTEGER_##N *pshift,                        \
 350                         const char *pbound,                                   \
 351                         const GFC_INTEGER_##N *pdim,                          \
 352                         GFC_INTEGER_4 array_length,                           \
 353                         GFC_INTEGER_4 bound_length __attribute__((unused)))   \
 354   {                                                                           \
 355     static const gfc_char4_t space = (unsigned char) ' ';                     \
 356     eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1,                  \
 357               array_length * sizeof (gfc_char4_t), (const char *) &space,     \
 358               sizeof (gfc_char4_t));                                          \
 359   }
 360
 361 DEFINE_EOSHIFT (1);
 362 DEFINE_EOSHIFT (2);
 363 DEFINE_EOSHIFT (4);
 364 DEFINE_EOSHIFT (8);
 365 #ifdef HAVE_GFC_INTEGER_16
 366 DEFINE_EOSHIFT (16);
 367 #endif