libgfortran/m4/cshift0.m4

   1 `/* Helper function for cshift functions.
   2    Copyright (C) 2008-2018 Free Software Foundation, Inc.
   3    Contributed by Thomas Koenig <tkoenig@gcc.gnu.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 include(iparm.m4)dnl
  30
  31 `#if defined (HAVE_'rtype_name`)
  32
  33 void
  34 cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ptrdiff_t shift,
  35                      int which)
  36 {
  37   /* r.* indicates the return array.  */
  38   index_type rstride[GFC_MAX_DIMENSIONS];
  39   index_type rstride0;
  40   index_type roffset;
  41   'rtype_name` *rptr;
  42
  43   /* s.* indicates the source array.  */
  44   index_type sstride[GFC_MAX_DIMENSIONS];
  45   index_type sstride0;
  46   index_type soffset;
  47   const 'rtype_name` *sptr;
  48
  49   index_type count[GFC_MAX_DIMENSIONS];
  50   index_type extent[GFC_MAX_DIMENSIONS];
  51   index_type dim;
  52   index_type len;
  53   index_type n;
  54
  55   bool do_blocked;
  56   index_type r_ex, a_ex;
  57
  58   which = which - 1;
  59   sstride[0] = 0;
  60   rstride[0] = 0;
  61
  62   extent[0] = 1;
  63   count[0] = 0;
  64   n = 0;
  65   /* Initialized for avoiding compiler warnings.  */
  66   roffset = 1;
  67   soffset = 1;
  68   len = 0;
  69
  70   r_ex = 1;
  71   a_ex = 1;
  72
  73   if (which > 0)
  74     {
  75       /* Test if both ret and array are contiguous.  */
  76       do_blocked = true;
  77       dim = GFC_DESCRIPTOR_RANK (array);
  78       for (n = 0; n < dim; n ++)
  79         {
  80           index_type rs, as;
  81           rs = GFC_DESCRIPTOR_STRIDE (ret, n);
  82           if (rs != r_ex)
  83             {
  84               do_blocked = false;
  85               break;
  86             }
  87           as = GFC_DESCRIPTOR_STRIDE (array, n);
  88           if (as != a_ex)
  89             {
  90               do_blocked = false;
  91               break;
  92             }
  93           r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
  94           a_ex *= GFC_DESCRIPTOR_EXTENT (array, n);
  95         }
  96     }
  97   else
  98     do_blocked = false;
  99
 100   n = 0;
 101
 102   if (do_blocked)
 103     {
 104       /* For contiguous arrays, use the relationship that
 105
 106          dimension(n1,n2,n3) :: a, b
 107          b = cshift(a,sh,3)
 108
 109          can be dealt with as if
 110
 111          dimension(n1*n2*n3) :: an, bn
 112          bn = cshift(a,sh*n1*n2,1)
 113
 114          we can used a more blocked algorithm for dim>1.  */
 115       sstride[0] = 1;
 116       rstride[0] = 1;
 117       roffset = 1;
 118       soffset = 1;
 119       len = GFC_DESCRIPTOR_STRIDE(array, which)
 120         * GFC_DESCRIPTOR_EXTENT(array, which);
 121       shift *= GFC_DESCRIPTOR_STRIDE(array, which);
 122       for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 123         {
 124           count[n] = 0;
 125           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 126           rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
 127           sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
 128           n++;
 129         }
 130       dim = GFC_DESCRIPTOR_RANK (array) - which;
 131     }
 132   else
 133     {
 134       for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
 135         {
 136           if (dim == which)
 137             {
 138               roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
 139               if (roffset == 0)
 140                 roffset = 1;
 141               soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
 142               if (soffset == 0)
 143                 soffset = 1;
 144               len = GFC_DESCRIPTOR_EXTENT(array,dim);
 145             }
 146           else
 147             {
 148               count[n] = 0;
 149               extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
 150               rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
 151               sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
 152               n++;
 153             }
 154         }
 155       if (sstride[0] == 0)
 156         sstride[0] = 1;
 157       if (rstride[0] == 0)
 158         rstride[0] = 1;
 159
 160       dim = GFC_DESCRIPTOR_RANK (array);
 161     }
 162
 163   rstride0 = rstride[0];
 164   sstride0 = sstride[0];
 165   rptr = ret->base_addr;
 166   sptr = array->base_addr;
 167
 168   /* Avoid the costly modulo for trivially in-bound shifts.  */
 169   if (shift < 0 || shift >= len)
 170     {
 171       shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
 172       if (shift < 0)
 173         shift += len;
 174     }
 175
 176   while (rptr)
 177     {
 178       /* Do the shift for this dimension.  */
 179
 180       /* If elements are contiguous, perform the operation
 181          in two block moves.  */
 182       if (soffset == 1 && roffset == 1)
 183         {
 184           size_t len1 = shift * sizeof ('rtype_name`);
 185           size_t len2 = (len - shift) * sizeof ('rtype_name`);
 186           memcpy (rptr, sptr + shift, len2);
 187           memcpy (rptr + (len - shift), sptr, len1);
 188         }
 189       else
 190         {
 191           /* Otherwise, we will have to perform the copy one element at
 192              a time.  */
 193           'rtype_name` *dest = rptr;
 194           const 'rtype_name` *src = &sptr[shift * soffset];
 195
 196           for (n = 0; n < len - shift; n++)
 197             {
 198               *dest = *src;
 199               dest += roffset;
 200               src += soffset;
 201             }
 202           for (src = sptr, n = 0; n < shift; n++)
 203             {
 204               *dest = *src;
 205               dest += roffset;
 206               src += soffset;
 207             }
 208         }
 209
 210       /* Advance to the next section.  */
 211       rptr += rstride0;
 212       sptr += sstride0;
 213       count[0]++;
 214       n = 0;
 215       while (count[n] == extent[n])
 216         {
 217           /* When we get to the end of a dimension, reset it and increment
 218              the next dimension.  */
 219           count[n] = 0;
 220           /* We could precalculate these products, but this is a less
 221              frequently used path so probably not worth it.  */
 222           rptr -= rstride[n] * extent[n];
 223           sptr -= sstride[n] * extent[n];
 224           n++;
 225           if (n >= dim - 1)
 226             {
 227               /* Break out of the loop.  */
 228               rptr = NULL;
 229               break;
 230             }
 231           else
 232             {
 233               count[n]++;
 234               rptr += rstride[n];
 235               sptr += sstride[n];
 236             }
 237         }
 238     }
 239
 240   return;
 241 }
 242
 243 #endif'