libgfortran/m4/ifunction.m4

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