libgfortran/generated/product_i4.c

   1 /* Implementation of the PRODUCT 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
  28
  29 #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
  30
  31
  32 extern void product_i4 (gfc_array_i4 * const restrict,
  33         gfc_array_i4 * const restrict, const index_type * const restrict);
  34 export_proto(product_i4);
  35
  36 void
  37 product_i4 (gfc_array_i4 * const restrict retarray,
  38         gfc_array_i4 * const restrict array,
  39         const index_type * const restrict pdim)
  40 {
  41   index_type count[GFC_MAX_DIMENSIONS];
  42   index_type extent[GFC_MAX_DIMENSIONS];
  43   index_type sstride[GFC_MAX_DIMENSIONS];
  44   index_type dstride[GFC_MAX_DIMENSIONS];
  45   const GFC_INTEGER_4 * restrict base;
  46   GFC_INTEGER_4 * restrict dest;
  47   index_type rank;
  48   index_type n;
  49   index_type len;
  50   index_type delta;
  51   index_type dim;
  52   int continue_loop;
  53
  54   /* Make dim zero based to avoid confusion.  */
  55   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  56   dim = (*pdim) - 1;
  57
  58   if (unlikely (dim < 0 || dim > rank))
  59     {
  60       runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
  61                      "is %ld, should be between 1 and %ld",
  62                      (long int) dim + 1, (long int) rank + 1);
  63     }
  64
  65   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  66   if (len < 0)
  67     len = 0;
  68   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  69
  70   for (n = 0; n < dim; n++)
  71     {
  72       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  73       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  74
  75       if (extent[n] < 0)
  76         extent[n] = 0;
  77     }
  78   for (n = dim; n < rank; n++)
  79     {
  80       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
  81       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  82
  83       if (extent[n] < 0)
  84         extent[n] = 0;
  85     }
  86
  87   if (retarray->base_addr == NULL)
  88     {
  89       size_t alloc_size, str;
  90
  91       for (n = 0; n < rank; n++)
  92         {
  93           if (n == 0)
  94             str = 1;
  95           else
  96             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
  97
  98           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
  99
 100         }
 101
 102       retarray->offset = 0;
 103       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 104
 105       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 106
 107       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 108       if (alloc_size == 0)
 109         {
 110           /* Make sure we have a zero-sized array.  */
 111           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 112           return;
 113
 114         }
 115     }
 116   else
 117     {
 118       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 119         runtime_error ("rank of return array incorrect in"
 120                        " PRODUCT intrinsic: is %ld, should be %ld",
 121                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 122                        (long int) rank);
 123
 124       if (unlikely (compile_options.bounds_check))
 125         bounds_ifunction_return ((array_t *) retarray, extent,
 126                                  "return value", "PRODUCT");
 127     }
 128
 129   for (n = 0; n < rank; n++)
 130     {
 131       count[n] = 0;
 132       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 133       if (extent[n] <= 0)
 134         return;
 135     }
 136
 137   base = array->base_addr;
 138   dest = retarray->base_addr;
 139
 140   continue_loop = 1;
 141   while (continue_loop)
 142     {
 143       const GFC_INTEGER_4 * restrict src;
 144       GFC_INTEGER_4 result;
 145       src = base;
 146       {
 147
 148   result = 1;
 149         if (len <= 0)
 150           *dest = 1;
 151         else
 152           {
 153             for (n = 0; n < len; n++, src += delta)
 154               {
 155
 156   result *= *src;
 157               }
 158
 159             *dest = result;
 160           }
 161       }
 162       /* Advance to the next element.  */
 163       count[0]++;
 164       base += sstride[0];
 165       dest += dstride[0];
 166       n = 0;
 167       while (count[n] == extent[n])
 168         {
 169           /* When we get to the end of a dimension, reset it and increment
 170              the next dimension.  */
 171           count[n] = 0;
 172           /* We could precalculate these products, but this is a less
 173              frequently used path so probably not worth it.  */
 174           base -= sstride[n] * extent[n];
 175           dest -= dstride[n] * extent[n];
 176           n++;
 177           if (n >= rank)
 178             {
 179               /* Break out of the loop.  */
 180               continue_loop = 0;
 181               break;
 182             }
 183           else
 184             {
 185               count[n]++;
 186               base += sstride[n];
 187               dest += dstride[n];
 188             }
 189         }
 190     }
 191 }
 192
 193
 194 extern void mproduct_i4 (gfc_array_i4 * const restrict,
 195         gfc_array_i4 * const restrict, const index_type * const restrict,
 196         gfc_array_l1 * const restrict);
 197 export_proto(mproduct_i4);
 198
 199 void
 200 mproduct_i4 (gfc_array_i4 * const restrict retarray,
 201         gfc_array_i4 * const restrict array,
 202         const index_type * const restrict pdim,
 203         gfc_array_l1 * const restrict mask)
 204 {
 205   index_type count[GFC_MAX_DIMENSIONS];
 206   index_type extent[GFC_MAX_DIMENSIONS];
 207   index_type sstride[GFC_MAX_DIMENSIONS];
 208   index_type dstride[GFC_MAX_DIMENSIONS];
 209   index_type mstride[GFC_MAX_DIMENSIONS];
 210   GFC_INTEGER_4 * restrict dest;
 211   const GFC_INTEGER_4 * restrict base;
 212   const GFC_LOGICAL_1 * restrict mbase;
 213   index_type rank;
 214   index_type dim;
 215   index_type n;
 216   index_type len;
 217   index_type delta;
 218   index_type mdelta;
 219   int mask_kind;
 220
 221   dim = (*pdim) - 1;
 222   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 223
 224
 225   if (unlikely (dim < 0 || dim > rank))
 226     {
 227       runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
 228                      "is %ld, should be between 1 and %ld",
 229                      (long int) dim + 1, (long int) rank + 1);
 230     }
 231
 232   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 233   if (len <= 0)
 234     return;
 235
 236   mbase = mask->base_addr;
 237
 238   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 239
 240   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 241 #ifdef HAVE_GFC_LOGICAL_16
 242       || mask_kind == 16
 243 #endif
 244       )
 245     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 246   else
 247     runtime_error ("Funny sized logical array");
 248
 249   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 250   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 251
 252   for (n = 0; n < dim; n++)
 253     {
 254       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 255       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 256       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 257
 258       if (extent[n] < 0)
 259         extent[n] = 0;
 260
 261     }
 262   for (n = dim; n < rank; n++)
 263     {
 264       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 265       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 266       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 267
 268       if (extent[n] < 0)
 269         extent[n] = 0;
 270     }
 271
 272   if (retarray->base_addr == NULL)
 273     {
 274       size_t alloc_size, str;
 275
 276       for (n = 0; n < rank; n++)
 277         {
 278           if (n == 0)
 279             str = 1;
 280           else
 281             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 282
 283           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 284
 285         }
 286
 287       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 288
 289       retarray->offset = 0;
 290       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 291
 292       if (alloc_size == 0)
 293         {
 294           /* Make sure we have a zero-sized array.  */
 295           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 296           return;
 297         }
 298       else
 299         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 300
 301     }
 302   else
 303     {
 304       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 305         runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
 306
 307       if (unlikely (compile_options.bounds_check))
 308         {
 309           bounds_ifunction_return ((array_t *) retarray, extent,
 310                                    "return value", "PRODUCT");
 311           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 312                                 "MASK argument", "PRODUCT");
 313         }
 314     }
 315
 316   for (n = 0; n < rank; n++)
 317     {
 318       count[n] = 0;
 319       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 320       if (extent[n] <= 0)
 321         return;
 322     }
 323
 324   dest = retarray->base_addr;
 325   base = array->base_addr;
 326
 327   while (base)
 328     {
 329       const GFC_INTEGER_4 * restrict src;
 330       const GFC_LOGICAL_1 * restrict msrc;
 331       GFC_INTEGER_4 result;
 332       src = base;
 333       msrc = mbase;
 334       {
 335
 336   result = 1;
 337         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 338           {
 339
 340   if (*msrc)
 341     result *= *src;
 342           }
 343         *dest = result;
 344       }
 345       /* Advance to the next element.  */
 346       count[0]++;
 347       base += sstride[0];
 348       mbase += mstride[0];
 349       dest += dstride[0];
 350       n = 0;
 351       while (count[n] == extent[n])
 352         {
 353           /* When we get to the end of a dimension, reset it and increment
 354              the next dimension.  */
 355           count[n] = 0;
 356           /* We could precalculate these products, but this is a less
 357              frequently used path so probably not worth it.  */
 358           base -= sstride[n] * extent[n];
 359           mbase -= mstride[n] * extent[n];
 360           dest -= dstride[n] * extent[n];
 361           n++;
 362           if (n >= rank)
 363             {
 364               /* Break out of the loop.  */
 365               base = NULL;
 366               break;
 367             }
 368           else
 369             {
 370               count[n]++;
 371               base += sstride[n];
 372               mbase += mstride[n];
 373               dest += dstride[n];
 374             }
 375         }
 376     }
 377 }
 378
 379
 380 extern void sproduct_i4 (gfc_array_i4 * const restrict,
 381         gfc_array_i4 * const restrict, const index_type * const restrict,
 382         GFC_LOGICAL_4 *);
 383 export_proto(sproduct_i4);
 384
 385 void
 386 sproduct_i4 (gfc_array_i4 * const restrict retarray,
 387         gfc_array_i4 * const restrict array,
 388         const index_type * const restrict pdim,
 389         GFC_LOGICAL_4 * mask)
 390 {
 391   index_type count[GFC_MAX_DIMENSIONS];
 392   index_type extent[GFC_MAX_DIMENSIONS];
 393   index_type dstride[GFC_MAX_DIMENSIONS];
 394   GFC_INTEGER_4 * restrict dest;
 395   index_type rank;
 396   index_type n;
 397   index_type dim;
 398
 399
 400   if (*mask)
 401     {
 402       product_i4 (retarray, array, pdim);
 403       return;
 404     }
 405   /* Make dim zero based to avoid confusion.  */
 406   dim = (*pdim) - 1;
 407   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 408
 409   if (unlikely (dim < 0 || dim > rank))
 410     {
 411       runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
 412                      "is %ld, should be between 1 and %ld",
 413                      (long int) dim + 1, (long int) rank + 1);
 414     }
 415
 416   for (n = 0; n < dim; n++)
 417     {
 418       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 419
 420       if (extent[n] <= 0)
 421         extent[n] = 0;
 422     }
 423
 424   for (n = dim; n < rank; n++)
 425     {
 426       extent[n] =
 427         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 428
 429       if (extent[n] <= 0)
 430         extent[n] = 0;
 431     }
 432
 433   if (retarray->base_addr == NULL)
 434     {
 435       size_t alloc_size, str;
 436
 437       for (n = 0; n < rank; n++)
 438         {
 439           if (n == 0)
 440             str = 1;
 441           else
 442             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 443
 444           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 445
 446         }
 447
 448       retarray->offset = 0;
 449       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 450
 451       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 452
 453       if (alloc_size == 0)
 454         {
 455           /* Make sure we have a zero-sized array.  */
 456           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 457           return;
 458         }
 459       else
 460         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 461     }
 462   else
 463     {
 464       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 465         runtime_error ("rank of return array incorrect in"
 466                        " PRODUCT intrinsic: is %ld, should be %ld",
 467                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 468                        (long int) rank);
 469
 470       if (unlikely (compile_options.bounds_check))
 471         {
 472           for (n=0; n < rank; n++)
 473             {
 474               index_type ret_extent;
 475
 476               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 477               if (extent[n] != ret_extent)
 478                 runtime_error ("Incorrect extent in return value of"
 479                                " PRODUCT intrinsic in dimension %ld:"
 480                                " is %ld, should be %ld", (long int) n + 1,
 481                                (long int) ret_extent, (long int) extent[n]);
 482             }
 483         }
 484     }
 485
 486   for (n = 0; n < rank; n++)
 487     {
 488       count[n] = 0;
 489       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 490     }
 491
 492   dest = retarray->base_addr;
 493
 494   while(1)
 495     {
 496       *dest = 1;
 497       count[0]++;
 498       dest += dstride[0];
 499       n = 0;
 500       while (count[n] == extent[n])
 501         {
 502           /* When we get to the end of a dimension, reset it and increment
 503              the next dimension.  */
 504           count[n] = 0;
 505           /* We could precalculate these products, but this is a less
 506              frequently used path so probably not worth it.  */
 507           dest -= dstride[n] * extent[n];
 508           n++;
 509           if (n >= rank)
 510             return;
 511           else
 512             {
 513               count[n]++;
 514               dest += dstride[n];
 515             }
 516         }
 517     }
 518 }
 519
 520 #endif