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'back_arg`);
  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'back_arg`)
  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 #ifdef HAVE_BACK_ARG
  45   assert(back == 0);
  46 #endif
  47
  48   /* Make dim zero based to avoid confusion.  */
  49   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  50   dim = (*pdim) - 1;
  51
  52   if (unlikely (dim < 0 || dim > rank))
  53     {
  54       runtime_error ("Dim argument incorrect in u_name intrinsic: "
  55                      "is %ld, should be between 1 and %ld",
  56                      (long int) dim + 1, (long int) rank + 1);
  57     }
  58
  59   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  60   if (len < 0)
  61     len = 0;
  62   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  63
  64   for (n = 0; n < dim; n++)
  65     {
  66       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  67       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  68
  69       if (extent[n] < 0)
  70         extent[n] = 0;
  71     }
  72   for (n = dim; n < rank; n++)
  73     {
  74       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
  75       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  76
  77       if (extent[n] < 0)
  78         extent[n] = 0;
  79     }
  80
  81   if (retarray->base_addr == NULL)
  82     {
  83       size_t alloc_size, str;
  84
  85       for (n = 0; n < rank; n++)
  86         {
  87           if (n == 0)
  88             str = 1;
  89           else
  90             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
  91
  92           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
  93
  94         }
  95
  96       retarray->offset = 0;
  97       GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
  98
  99       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 100
 101       retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 102       if (alloc_size == 0)
 103         {
 104           /* Make sure we have a zero-sized array.  */
 105           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 106           return;
 107
 108         }
 109     }
 110   else
 111     {
 112       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 113         runtime_error ("rank of return array incorrect in"
 114                        " u_name intrinsic: is %ld, should be %ld",
 115                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 116                        (long int) rank);
 117
 118       if (unlikely (compile_options.bounds_check))
 119         bounds_ifunction_return ((array_t *) retarray, extent,
 120                                  "return value", "u_name");
 121     }
 122
 123   for (n = 0; n < rank; n++)
 124     {
 125       count[n] = 0;
 126       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 127       if (extent[n] <= 0)
 128         return;
 129     }
 130
 131   base = array->base_addr;
 132   dest = retarray->base_addr;
 133
 134   continue_loop = 1;
 135   while (continue_loop)
 136     {
 137       const atype_name * restrict src;
 138       rtype_name result;
 139       src = base;
 140       {
 141 ')dnl
 142 define(START_ARRAY_BLOCK,
 143 `       if (len <= 0)
 144           *dest = '$1`;
 145         else
 146           {
 147             for (n = 0; n < len; n++, src += delta)
 148               {
 149 ')dnl
 150 define(FINISH_ARRAY_FUNCTION,
 151 `             }
 152             '$1`
 153             *dest = result;
 154           }
 155       }
 156       /* Advance to the next element.  */
 157       count[0]++;
 158       base += sstride[0];
 159       dest += dstride[0];
 160       n = 0;
 161       while (count[n] == extent[n])
 162         {
 163           /* When we get to the end of a dimension, reset it and increment
 164              the next dimension.  */
 165           count[n] = 0;
 166           /* We could precalculate these products, but this is a less
 167              frequently used path so probably not worth it.  */
 168           base -= sstride[n] * extent[n];
 169           dest -= dstride[n] * extent[n];
 170           n++;
 171           if (n >= rank)
 172             {
 173               /* Break out of the loop.  */
 174               continue_loop = 0;
 175               break;
 176             }
 177           else
 178             {
 179               count[n]++;
 180               base += sstride[n];
 181               dest += dstride[n];
 182             }
 183         }
 184     }
 185 }')dnl
 186 define(START_MASKED_ARRAY_FUNCTION,
 187 `
 188 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
 189         'atype` * const restrict, const 'index_type` * const restrict,
 190         gfc_array_l1 * const restrict'back_arg`);
 191 export_proto(m'name`'rtype_qual`_'atype_code`);
 192
 193 void
 194 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
 195         'atype` * const restrict array,
 196         const index_type * const restrict pdim,
 197         gfc_array_l1 * const restrict mask'back_arg`)
 198 {
 199   index_type count[GFC_MAX_DIMENSIONS];
 200   index_type extent[GFC_MAX_DIMENSIONS];
 201   index_type sstride[GFC_MAX_DIMENSIONS];
 202   index_type dstride[GFC_MAX_DIMENSIONS];
 203   index_type mstride[GFC_MAX_DIMENSIONS];
 204   'rtype_name * restrict dest;
 205   const atype_name * restrict base;
 206   const GFC_LOGICAL_1 * restrict mbase;
 207   index_type rank;
 208   index_type dim;
 209   index_type n;
 210   index_type len;
 211   index_type delta;
 212   index_type mdelta;
 213   int mask_kind;
 214
 215 #ifdef HAVE_BACK_ARG
 216   assert (back == 0);
 217 #endif
 218   dim = (*pdim) - 1;
 219   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 220
 221
 222   if (unlikely (dim < 0 || dim > rank))
 223     {
 224       runtime_error ("Dim argument incorrect in u_name intrinsic: "
 225                      "is %ld, should be between 1 and %ld",
 226                      (long int) dim + 1, (long int) rank + 1);
 227     }
 228
 229   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 230   if (len <= 0)
 231     return;
 232
 233   mbase = mask->base_addr;
 234
 235   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 236
 237   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 238 #ifdef HAVE_GFC_LOGICAL_16
 239       || mask_kind == 16
 240 #endif
 241       )
 242     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 243   else
 244     runtime_error ("Funny sized logical array");
 245
 246   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 247   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 248
 249   for (n = 0; n < dim; n++)
 250     {
 251       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 252       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 253       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 254
 255       if (extent[n] < 0)
 256         extent[n] = 0;
 257
 258     }
 259   for (n = dim; n < rank; n++)
 260     {
 261       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 262       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 263       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 264
 265       if (extent[n] < 0)
 266         extent[n] = 0;
 267     }
 268
 269   if (retarray->base_addr == NULL)
 270     {
 271       size_t alloc_size, str;
 272
 273       for (n = 0; n < rank; n++)
 274         {
 275           if (n == 0)
 276             str = 1;
 277           else
 278             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 279
 280           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 281
 282         }
 283
 284       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 285
 286       retarray->offset = 0;
 287       GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
 288
 289       if (alloc_size == 0)
 290         {
 291           /* Make sure we have a zero-sized array.  */
 292           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 293           return;
 294         }
 295       else
 296         retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 297
 298     }
 299   else
 300     {
 301       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 302         runtime_error ("rank of return array incorrect in u_name intrinsic");
 303
 304       if (unlikely (compile_options.bounds_check))
 305         {
 306           bounds_ifunction_return ((array_t *) retarray, extent,
 307                                    "return value", "u_name");
 308           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 309                                 "MASK argument", "u_name");
 310         }
 311     }
 312
 313   for (n = 0; n < rank; n++)
 314     {
 315       count[n] = 0;
 316       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 317       if (extent[n] <= 0)
 318         return;
 319     }
 320
 321   dest = retarray->base_addr;
 322   base = array->base_addr;
 323
 324   while (base)
 325     {
 326       const atype_name * restrict src;
 327       const GFC_LOGICAL_1 * restrict msrc;
 328       rtype_name result;
 329       src = base;
 330       msrc = mbase;
 331       {
 332 ')dnl
 333 define(START_MASKED_ARRAY_BLOCK,
 334 `       for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 335           {
 336 ')dnl
 337 define(FINISH_MASKED_ARRAY_FUNCTION,
 338 `         }
 339         *dest = result;
 340       }
 341       /* Advance to the next element.  */
 342       count[0]++;
 343       base += sstride[0];
 344       mbase += mstride[0];
 345       dest += dstride[0];
 346       n = 0;
 347       while (count[n] == extent[n])
 348         {
 349           /* When we get to the end of a dimension, reset it and increment
 350              the next dimension.  */
 351           count[n] = 0;
 352           /* We could precalculate these products, but this is a less
 353              frequently used path so probably not worth it.  */
 354           base -= sstride[n] * extent[n];
 355           mbase -= mstride[n] * extent[n];
 356           dest -= dstride[n] * extent[n];
 357           n++;
 358           if (n >= rank)
 359             {
 360               /* Break out of the loop.  */
 361               base = NULL;
 362               break;
 363             }
 364           else
 365             {
 366               count[n]++;
 367               base += sstride[n];
 368               mbase += mstride[n];
 369               dest += dstride[n];
 370             }
 371         }
 372     }
 373 }')dnl
 374 define(SCALAR_ARRAY_FUNCTION,
 375 `
 376 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
 377         'atype` * const restrict, const index_type * const restrict,
 378         GFC_LOGICAL_4 *'back_arg`);
 379 export_proto(s'name`'rtype_qual`_'atype_code);
 380
 381 void
 382 `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
 383         'atype` * const restrict array,
 384         const index_type * const restrict pdim,
 385         GFC_LOGICAL_4 * mask'back_arg`)
 386 {
 387   index_type count[GFC_MAX_DIMENSIONS];
 388   index_type extent[GFC_MAX_DIMENSIONS];
 389   index_type dstride[GFC_MAX_DIMENSIONS];
 390   'rtype_name * restrict dest;
 391   index_type rank;
 392   index_type n;
 393   index_type dim;
 394
 395
 396   if (*mask)
 397     {
 398 #ifdef HAVE_BACK_ARG
 399       name`'rtype_qual`_'atype_code (retarray, array, pdim, back);
 400 #else
 401       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 402 #endif
 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 u_name 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       GFC_DTYPE_COPY_SETRANK(retarray,array,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 (rtype_name));
 461     }
 462   else
 463     {
 464       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 465         runtime_error ("rank of return array incorrect in"
 466                        " u_name 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                                " u_name 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 }')dnl
 519 define(ARRAY_FUNCTION,
 520 `START_ARRAY_FUNCTION
 521 $2
 522 START_ARRAY_BLOCK($1)
 523 $3
 524 FINISH_ARRAY_FUNCTION($4)')dnl
 525 define(MASKED_ARRAY_FUNCTION,
 526 `START_MASKED_ARRAY_FUNCTION
 527 $2
 528 START_MASKED_ARRAY_BLOCK
 529 $3
 530 FINISH_MASKED_ARRAY_FUNCTION')dnl