Home | History | Annotate | Line # | Download | only in m4 
      1 `/* Implementation of the EOSHIFT intrinsic
      2    Copyright (C) 2002-2024 Free Software Foundation, Inc.
      3    Contributed by Paul Brook <paul (a] 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 include(iparm.m4)dnl
     30 
     31 `#if defined (HAVE_'atype_name`)
     32 
     33 static void
     34 eoshift1 (gfc_array_char * const restrict ret, 
     35 	const gfc_array_char * const restrict array, 
     36 	const 'atype` * const restrict h,
     37 	const char * const restrict pbound, 
     38 	const 'atype_name` * const restrict pwhich, 
     39 	const char * filler, index_type filler_len)
     40 {
     41   /* r.* indicates the return array.  */
     42   index_type rstride[GFC_MAX_DIMENSIONS];
     43   index_type rstride0;
     44   index_type roffset;
     45   char *rptr;
     46   char * restrict dest;
     47   /* s.* indicates the source array.  */
     48   index_type sstride[GFC_MAX_DIMENSIONS];
     49   index_type sstride0;
     50   index_type soffset;
     51   const char *sptr;
     52   const char *src;
     53   /* h.* indicates the shift array.  */
     54   index_type hstride[GFC_MAX_DIMENSIONS];
     55   index_type hstride0;
     56   const 'atype_name` *hptr;
     57 
     58   index_type count[GFC_MAX_DIMENSIONS];
     59   index_type extent[GFC_MAX_DIMENSIONS];
     60   index_type dim;
     61   index_type len;
     62   index_type n;
     63   index_type size;
     64   index_type arraysize;
     65   int which;
     66   'atype_name` sh;
     67   'atype_name` delta;
     68 
     69   /* The compiler cannot figure out that these are set, initialize
     70      them to avoid warnings.  */
     71   len = 0;
     72   soffset = 0;
     73   roffset = 0;
     74 
     75   size = GFC_DESCRIPTOR_SIZE(array);
     76 
     77   if (pwhich)
     78     which = *pwhich - 1;
     79   else
     80     which = 0;
     81 
     82   extent[0] = 1;
     83   count[0] = 0;
     84 
     85   arraysize = size0 ((array_t *) array);
     86   if (ret->base_addr == NULL)
     87     {
     88       ret->offset = 0;
     89       GFC_DTYPE_COPY(ret,array);
     90       for (index_type i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
     91         {
     92 	  index_type ub, str;
     93 
     94 	  ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
     95 
     96           if (i == 0)
     97             str = 1;
     98           else
     99             str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
    100 	      * GFC_DESCRIPTOR_STRIDE(ret,i-1);
    101 
    102 	  GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
    103 
    104         }
    105       /* xmallocarray allocates a single byte for zero size.  */
    106       ret->base_addr = xmallocarray (arraysize, size);
    107 
    108     }
    109   else if (unlikely (compile_options.bounds_check))
    110     {
    111       bounds_equal_extents ((array_t *) ret, (array_t *) array,
    112 				 "return value", "EOSHIFT");
    113     }
    114 
    115   if (unlikely (compile_options.bounds_check))
    116     {
    117       bounds_reduced_extents ((array_t *) h, (array_t *) array, which,
    118       			      "SHIFT argument", "EOSHIFT");
    119     }
    120 
    121   if (arraysize == 0)
    122     return;
    123 
    124   n = 0;
    125   for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
    126     {
    127       if (dim == which)
    128         {
    129           roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
    130           if (roffset == 0)
    131             roffset = size;
    132           soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
    133           if (soffset == 0)
    134             soffset = size;
    135           len = GFC_DESCRIPTOR_EXTENT(array,dim);
    136         }
    137       else
    138         {
    139           count[n] = 0;
    140           extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
    141           rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
    142           sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
    143 
    144           hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n);
    145           n++;
    146         }
    147     }
    148   if (sstride[0] == 0)
    149     sstride[0] = size;
    150   if (rstride[0] == 0)
    151     rstride[0] = size;
    152   if (hstride[0] == 0)
    153     hstride[0] = 1;
    154 
    155   dim = GFC_DESCRIPTOR_RANK (array);
    156   rstride0 = rstride[0];
    157   sstride0 = sstride[0];
    158   hstride0 = hstride[0];
    159   rptr = ret->base_addr;
    160   sptr = array->base_addr;
    161   hptr = h->base_addr;
    162 
    163   while (rptr)
    164     {
    165       /* Do the shift for this dimension.  */
    166       sh = *hptr;
    167       if (( sh >= 0 ? sh : -sh ) > len)
    168 	{
    169 	  delta = len;
    170 	  sh = len;
    171 	}
    172       else
    173 	delta = (sh >= 0) ? sh: -sh;
    174 
    175       if (sh > 0)
    176         {
    177           src = &sptr[delta * soffset];
    178           dest = rptr;
    179         }
    180       else
    181         {
    182           src = sptr;
    183           dest = &rptr[delta * roffset];
    184         }
    185 
    186       /* If the elements are contiguous, perform a single block move.  */
    187       if (soffset == size && roffset == size)
    188 	{
    189 	  size_t chunk = size * (len - delta);
    190 	  memcpy (dest, src, chunk);
    191 	  dest += chunk;
    192 	}
    193       else
    194 	{
    195 	  for (n = 0; n < len - delta; n++)
    196 	    {
    197 	      memcpy (dest, src, size);
    198 	      dest += roffset;
    199 	      src += soffset;
    200 	    }
    201 	}
    202       if (sh < 0)
    203         dest = rptr;
    204       n = delta;
    205 
    206       if (pbound)
    207 	while (n--)
    208 	  {
    209 	    memcpy (dest, pbound, size);
    210 	    dest += roffset;
    211 	  }
    212       else
    213 	while (n--)
    214 	  {
    215 	    index_type i;
    216 
    217 	    if (filler_len == 1)
    218 	      memset (dest, filler[0], size);
    219 	    else
    220 	      for (i = 0; i < size; i += filler_len)
    221 		memcpy (&dest[i], filler, filler_len);
    222 
    223 	    dest += roffset;
    224 	  }
    225 
    226       /* Advance to the next section.  */
    227       rptr += rstride0;
    228       sptr += sstride0;
    229       hptr += hstride0;
    230       count[0]++;
    231       n = 0;
    232       while (count[n] == extent[n])
    233         {
    234           /* When we get to the end of a dimension, reset it and increment
    235              the next dimension.  */
    236           count[n] = 0;
    237           /* We could precalculate these products, but this is a less
    238              frequently used path so probably not worth it.  */
    239           rptr -= rstride[n] * extent[n];
    240           sptr -= sstride[n] * extent[n];
    241 	  hptr -= hstride[n] * extent[n];
    242           n++;
    243           if (n >= dim - 1)
    244             {
    245               /* Break out of the loop.  */
    246               rptr = NULL;
    247               break;
    248             }
    249           else
    250             {
    251               count[n]++;
    252               rptr += rstride[n];
    253               sptr += sstride[n];
    254 	      hptr += hstride[n];
    255             }
    256         }
    257     }
    258 }
    259 
    260 void eoshift1_'atype_kind` (gfc_array_char * const restrict, 
    261 	const gfc_array_char * const restrict,
    262 	const 'atype` * const restrict, const char * const restrict, 
    263 	const 'atype_name` * const restrict);
    264 export_proto(eoshift1_'atype_kind`);
    265 
    266 void
    267 eoshift1_'atype_kind` (gfc_array_char * const restrict ret, 
    268 	const gfc_array_char * const restrict array,
    269 	const 'atype` * const restrict h, 
    270 	const char * const restrict pbound,
    271 	const 'atype_name` * const restrict pwhich)
    272 {
    273   eoshift1 (ret, array, h, pbound, pwhich, "\0", 1);
    274 }
    275 
    276 
    277 void eoshift1_'atype_kind`_char (gfc_array_char * const restrict, 
    278 	GFC_INTEGER_4,
    279 	const gfc_array_char * const restrict, 
    280 	const 'atype` * const restrict,
    281 	const char * const restrict, 
    282 	const 'atype_name` * const restrict,
    283 	GFC_INTEGER_4, GFC_INTEGER_4);
    284 export_proto(eoshift1_'atype_kind`_char);
    285 
    286 void
    287 eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret,
    288 	GFC_INTEGER_4 ret_length __attribute__((unused)),
    289 	const gfc_array_char * const restrict array, 
    290 	const 'atype` * const restrict h,
    291 	const char *  const restrict pbound, 
    292 	const 'atype_name` * const restrict pwhich,
    293 	GFC_INTEGER_4 array_length __attribute__((unused)),
    294 	GFC_INTEGER_4 bound_length __attribute__((unused)))
    295 {
    296   eoshift1 (ret, array, h, pbound, pwhich, " ", 1);
    297 }
    298 
    299 
    300 void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict, 
    301 	GFC_INTEGER_4,
    302 	const gfc_array_char * const restrict, 
    303 	const 'atype` * const restrict,
    304 	const char * const restrict, 
    305 	const 'atype_name` * const restrict,
    306 	GFC_INTEGER_4, GFC_INTEGER_4);
    307 export_proto(eoshift1_'atype_kind`_char4);
    308 
    309 void
    310 eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret,
    311 	GFC_INTEGER_4 ret_length __attribute__((unused)),
    312 	const gfc_array_char * const restrict array, 
    313 	const 'atype` * const restrict h,
    314 	const char *  const restrict pbound, 
    315 	const 'atype_name` * const restrict pwhich,
    316 	GFC_INTEGER_4 array_length __attribute__((unused)),
    317 	GFC_INTEGER_4 bound_length __attribute__((unused)))
    318 {
    319   static const gfc_char4_t space = (unsigned char) ''` ''`;
    320   eoshift1 (ret, array, h, pbound, pwhich,
    321 	    (const char *) &space, sizeof (gfc_char4_t));
    322 }
    323 
    324 #endif'
    325