libgfortran/intrinsics/eoshift0.c

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