Home | History | Annotate | Line # | Download | only in generated 
      1 /* Special implementation of the SPREAD intrinsic
      2    Copyright (C) 2008-2024 Free Software Foundation, Inc.
      3    Contributed by Thomas Koenig <tkoenig (at) gcc.gnu.org>, based on
      4    spread_generic.c written by Paul Brook <paul (at) nowt.org>
      5 
      6 This file is part of the GNU Fortran runtime library (libgfortran).
      7 
      8 Libgfortran is free software; you can redistribute it and/or
      9 modify it under the terms of the GNU General Public
     10 License as published by the Free Software Foundation; either
     11 version 3 of the License, or (at your option) any later version.
     12 
     13 Ligbfortran is distributed in the hope that it will be useful,
     14 but WITHOUT ANY WARRANTY; without even the implied warranty of
     15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     16 GNU General Public License for more details.
     17 
     18 Under Section 7 of GPL version 3, you are granted additional
     19 permissions described in the GCC Runtime Library Exception, version
     20 3.1, as published by the Free Software Foundation.
     21 
     22 You should have received a copy of the GNU General Public License and
     23 a copy of the GCC Runtime Library Exception along with this program;
     24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
     25 <http://www.gnu.org/licenses/>.  */
     26 
     27 #include "libgfortran.h"
     28 #include <string.h>
     29 
     30 
     31 #if defined (HAVE_GFC_REAL_8)
     32 
     33 void
     34 spread_r8 (gfc_array_r8 *ret, const gfc_array_r8 *source,
     35 		 const index_type along, const index_type pncopies)
     36 {
     37   /* r.* indicates the return array.  */
     38   index_type rstride[GFC_MAX_DIMENSIONS];
     39   index_type rstride0;
     40   index_type rdelta = 0;
     41   index_type rrank;
     42   index_type rs;
     43   GFC_REAL_8 *rptr;
     44   GFC_REAL_8 * restrict dest;
     45   /* s.* indicates the source array.  */
     46   index_type sstride[GFC_MAX_DIMENSIONS];
     47   index_type sstride0;
     48   index_type srank;
     49   const GFC_REAL_8 *sptr;
     50 
     51   index_type count[GFC_MAX_DIMENSIONS];
     52   index_type extent[GFC_MAX_DIMENSIONS];
     53   index_type n;
     54   index_type dim;
     55   index_type ncopies;
     56 
     57   srank = GFC_DESCRIPTOR_RANK(source);
     58 
     59   sstride[0] = 0; /* Avoid warnings if not initialized.  */
     60 
     61   rrank = srank + 1;
     62   if (rrank > GFC_MAX_DIMENSIONS)
     63     runtime_error ("return rank too large in spread()");
     64 
     65   if (along > rrank)
     66       runtime_error ("dim outside of rank in spread()");
     67 
     68   ncopies = pncopies;
     69 
     70   if (ret->base_addr == NULL)
     71     {
     72 
     73       size_t ub, stride;
     74 
     75       /* The front end has signalled that we need to populate the
     76 	 return array descriptor.  */
     77       ret->dtype.rank = rrank;
     78 
     79       dim = 0;
     80       rs = 1;
     81       for (n = 0; n < rrank; n++)
     82 	{
     83 	  stride = rs;
     84 	  if (n == along - 1)
     85 	    {
     86 	      ub = ncopies - 1;
     87 	      rdelta = rs;
     88 	      rs *= ncopies;
     89 	    }
     90 	  else
     91 	    {
     92 	      count[dim] = 0;
     93 	      extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
     94 	      sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
     95 	      rstride[dim] = rs;
     96 
     97 	      ub = extent[dim] - 1;
     98 	      rs *= extent[dim];
     99 	      dim++;
    100 	    }
    101 	  GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
    102 	}
    103       ret->offset = 0;
    104 
    105       /* xmallocarray allocates a single byte for zero size.  */
    106       ret->base_addr = xmallocarray (rs, sizeof(GFC_REAL_8));
    107       if (rs <= 0)
    108         return;
    109     }
    110   else
    111     {
    112       int zero_sized;
    113 
    114       zero_sized = 0;
    115 
    116       dim = 0;
    117       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
    118 	runtime_error ("rank mismatch in spread()");
    119 
    120       if (unlikely (compile_options.bounds_check))
    121 	{
    122 	  for (n = 0; n < rrank; n++)
    123 	    {
    124 	      index_type ret_extent;
    125 
    126 	      ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
    127 	      if (n == along - 1)
    128 		{
    129 		  rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
    130 
    131 		  if (ret_extent != ncopies)
    132 		    runtime_error("Incorrect extent in return value of SPREAD"
    133 				  " intrinsic in dimension %ld: is %ld,"
    134 				  " should be %ld", (long int) n+1,
    135 				  (long int) ret_extent, (long int) ncopies);
    136 		}
    137 	      else
    138 		{
    139 		  count[dim] = 0;
    140 		  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
    141 		  if (ret_extent != extent[dim])
    142 		    runtime_error("Incorrect extent in return value of SPREAD"
    143 				  " intrinsic in dimension %ld: is %ld,"
    144 				  " should be %ld", (long int) n+1,
    145 				  (long int) ret_extent,
    146 				  (long int) extent[dim]);
    147 
    148 		  if (extent[dim] <= 0)
    149 		    zero_sized = 1;
    150 		  sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
    151 		  rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
    152 		  dim++;
    153 		}
    154 	    }
    155 	}
    156       else
    157 	{
    158 	  for (n = 0; n < rrank; n++)
    159 	    {
    160 	      if (n == along - 1)
    161 		{
    162 		  rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
    163 		}
    164 	      else
    165 		{
    166 		  count[dim] = 0;
    167 		  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
    168 		  if (extent[dim] <= 0)
    169 		    zero_sized = 1;
    170 		  sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
    171 		  rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
    172 		  dim++;
    173 		}
    174 	    }
    175 	}
    176 
    177       if (zero_sized)
    178 	return;
    179 
    180       if (sstride[0] == 0)
    181 	sstride[0] = 1;
    182     }
    183   sstride0 = sstride[0];
    184   rstride0 = rstride[0];
    185   rptr = ret->base_addr;
    186   sptr = source->base_addr;
    187 
    188   while (sptr)
    189     {
    190       /* Spread this element.  */
    191       dest = rptr;
    192       for (n = 0; n < ncopies; n++)
    193         {
    194 	  *dest = *sptr;
    195           dest += rdelta;
    196         }
    197       /* Advance to the next element.  */
    198       sptr += sstride0;
    199       rptr += rstride0;
    200       count[0]++;
    201       n = 0;
    202       while (count[n] == extent[n])
    203         {
    204           /* When we get to the end of a dimension, reset it and increment
    205              the next dimension.  */
    206           count[n] = 0;
    207           /* We could precalculate these products, but this is a less
    208              frequently used path so probably not worth it.  */
    209           sptr -= sstride[n] * extent[n];
    210           rptr -= rstride[n] * extent[n];
    211           n++;
    212           if (n >= srank)
    213             {
    214               /* Break out of the loop.  */
    215               sptr = NULL;
    216               break;
    217             }
    218           else
    219             {
    220               count[n]++;
    221               sptr += sstride[n];
    222               rptr += rstride[n];
    223             }
    224         }
    225     }
    226 }
    227 
    228 /* This version of spread_internal treats the special case of a scalar
    229    source.  This is much simpler than the more general case above.  */
    230 
    231 void
    232 spread_scalar_r8 (gfc_array_r8 *ret, const GFC_REAL_8 *source,
    233 			const index_type along, const index_type ncopies)
    234 {
    235   GFC_REAL_8 * restrict dest;
    236   index_type stride;
    237 
    238   if (GFC_DESCRIPTOR_RANK (ret) != 1)
    239     runtime_error ("incorrect destination rank in spread()");
    240 
    241   if (along > 1)
    242     runtime_error ("dim outside of rank in spread()");
    243 
    244   if (ret->base_addr == NULL)
    245     {
    246       ret->base_addr = xmallocarray (ncopies, sizeof (GFC_REAL_8));
    247       ret->offset = 0;
    248       GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
    249     }
    250   else
    251     {
    252       if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
    253 			   / GFC_DESCRIPTOR_STRIDE(ret,0))
    254 	runtime_error ("dim too large in spread()");
    255     }
    256 
    257   dest = ret->base_addr;
    258   stride = GFC_DESCRIPTOR_STRIDE(ret,0);
    259 
    260   for (index_type n = 0; n < ncopies; n++)
    261     {
    262       *dest = *source;
    263       dest += stride;
    264     }
    265 }
    266 
    267 #endif
    268 
    269