150276Speter/* Implementation of the IALL intrinsic 298503Speter Copyright (C) 2010-2022 Free Software Foundation, Inc. 350276Speter Contributed by Tobias Burnus <burnus@net-b.de> 450276Speter 550276SpeterThis file is part of the GNU Fortran runtime library (libgfortran). 650276Speter 750276SpeterLibgfortran is free software; you can redistribute it and/or 850276Spetermodify it under the terms of the GNU General Public 950276SpeterLicense as published by the Free Software Foundation; either 1050276Speterversion 3 of the License, or (at your option) any later version. 1150276Speter 1250276SpeterLibgfortran is distributed in the hope that it will be useful, 1350276Speterbut WITHOUT ANY WARRANTY; without even the implied warranty of 1450276SpeterMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1550276SpeterGNU General Public License for more details. 1650276Speter 1750276SpeterUnder Section 7 of GPL version 3, you are granted additional 1850276Speterpermissions described in the GCC Runtime Library Exception, version 1950276Speter3.1, as published by the Free Software Foundation. 2050276Speter 2150276SpeterYou should have received a copy of the GNU General Public License and 2250276Spetera copy of the GCC Runtime Library Exception along with this program; 2350276Spetersee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 2450276Speter<http://www.gnu.org/licenses/>. */ 2550276Speter 2650276Speter#include "libgfortran.h" 2750276Speter 2850276Speter 2950276Speter#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) 3050276Speter 3150276Speter 3250276Speterextern void iall_i4 (gfc_array_i4 * const restrict, 3350276Speter gfc_array_i4 * const restrict, const index_type * const restrict); 3450276Speterexport_proto(iall_i4); 3562449Speter 3650276Spetervoid 3798503Speteriall_i4 (gfc_array_i4 * const restrict retarray, 3850276Speter gfc_array_i4 * const restrict array, 3966963Speter const index_type * const restrict pdim) 4050276Speter{ 4150276Speter index_type count[GFC_MAX_DIMENSIONS]; 4250276Speter index_type extent[GFC_MAX_DIMENSIONS]; 4350276Speter index_type sstride[GFC_MAX_DIMENSIONS]; 4462449Speter index_type dstride[GFC_MAX_DIMENSIONS]; 4550276Speter const GFC_INTEGER_4 * restrict base; 4650276Speter GFC_INTEGER_4 * restrict dest; 4750276Speter index_type rank; 4850276Speter index_type n; 4950276Speter index_type len; 5050276Speter index_type delta; 5150276Speter index_type dim; 5250276Speter int continue_loop; 5350276Speter 5450276Speter /* Make dim zero based to avoid confusion. */ 5550276Speter rank = GFC_DESCRIPTOR_RANK (array) - 1; 5650276Speter dim = (*pdim) - 1; 5750276Speter 5850276Speter if (unlikely (dim < 0 || dim > rank)) 5950276Speter { 6050276Speter runtime_error ("Dim argument incorrect in IALL intrinsic: " 6162449Speter "is %ld, should be between 1 and %ld", 6262449Speter (long int) dim + 1, (long int) rank + 1); 6362449Speter } 6462449Speter 6550276Speter len = GFC_DESCRIPTOR_EXTENT(array,dim); 6662449Speter if (len < 0) 6762449Speter len = 0; 6850276Speter delta = GFC_DESCRIPTOR_STRIDE(array,dim); 6962449Speter 7050276Speter for (n = 0; n < dim; n++) 7162449Speter { 7262449Speter sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 7362449Speter extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 7462449Speter 7562449Speter if (extent[n] < 0) 7662449Speter extent[n] = 0; 7762449Speter } 7862449Speter for (n = dim; n < rank; n++) 7962449Speter { 8062449Speter sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 8162449Speter extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 8250276Speter 8350276Speter if (extent[n] < 0) 8476726Speter extent[n] = 0; 8598503Speter } 8650276Speter 8750276Speter if (retarray->base_addr == NULL) 8862449Speter { 8950276Speter size_t alloc_size, str; 9050276Speter 9162449Speter for (n = 0; n < rank; n++) 9250276Speter { 9362449Speter if (n == 0) 9462449Speter str = 1; 9562449Speter else 9662449Speter str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 9762449Speter 9862449Speter GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 9962449Speter 10062449Speter } 10162449Speter 10262449Speter retarray->offset = 0; 10362449Speter retarray->dtype.rank = rank; 10462449Speter 10550276Speter alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 10662449Speter 10750276Speter retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); 10862449Speter if (alloc_size == 0) 10962449Speter { 11050276Speter /* Make sure we have a zero-sized array. */ 11162449Speter GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 11250276Speter return; 11362449Speter 11462449Speter } 11562449Speter } 11650276Speter else 11762449Speter { 11850276Speter if (rank != GFC_DESCRIPTOR_RANK (retarray)) 11962449Speter runtime_error ("rank of return array incorrect in" 12062449Speter " IALL intrinsic: is %ld, should be %ld", 12162449Speter (long int) (GFC_DESCRIPTOR_RANK (retarray)), 12262449Speter (long int) rank); 12350276Speter 12462449Speter if (unlikely (compile_options.bounds_check)) 12550276Speter bounds_ifunction_return ((array_t *) retarray, extent, 12662449Speter "return value", "IALL"); 12762449Speter } 12862449Speter 12962449Speter for (n = 0; n < rank; n++) 13062449Speter { 13162449Speter count[n] = 0; 13262449Speter dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 13362449Speter if (extent[n] <= 0) 13462449Speter return; 13562449Speter } 13650276Speter 13750276Speter base = array->base_addr; 13850276Speter dest = retarray->base_addr; 13950276Speter 14076726Speter continue_loop = 1; 14176726Speter while (continue_loop) 14276726Speter { 14376726Speter const GFC_INTEGER_4 * restrict src; 14476726Speter GFC_INTEGER_4 result; 14550276Speter src = base; 14698503Speter { 14798503Speter 14850276Speter result = (GFC_INTEGER_4) -1; 14998503Speter if (len <= 0) 15098503Speter *dest = 0; 15150276Speter else 15298503Speter { 15398503Speter#if ! defined HAVE_BACK_ARG 15450276Speter for (n = 0; n < len; n++, src += delta) 15550276Speter { 15666963Speter#endif 15766963Speter 15876726Speter result &= *src; 15966963Speter } 16066963Speter 16166963Speter *dest = result; 16266963Speter } 16366963Speter } 16466963Speter /* Advance to the next element. */ 16566963Speter count[0]++; 16666963Speter base += sstride[0]; 16766963Speter dest += dstride[0]; 16850276Speter n = 0; 16966963Speter while (count[n] == extent[n]) 17066963Speter { 17166963Speter /* When we get to the end of a dimension, reset it and increment 17266963Speter the next dimension. */ 17350276Speter count[n] = 0; 17466963Speter /* We could precalculate these products, but this is a less 17566963Speter frequently used path so probably not worth it. */ 17666963Speter base -= sstride[n] * extent[n]; 17766963Speter dest -= dstride[n] * extent[n]; 17876726Speter n++; 17998503Speter if (n >= rank) 18066963Speter { 18166963Speter /* Break out of the loop. */ 18266963Speter continue_loop = 0; 18366963Speter break; 18466963Speter } 18566963Speter else 18666963Speter { 18766963Speter count[n]++; 18866963Speter base += sstride[n]; 18966963Speter dest += dstride[n]; 19066963Speter } 19150276Speter } 19250276Speter } 19350276Speter} 19498503Speter 19598503Speter 19650276Speterextern void miall_i4 (gfc_array_i4 * const restrict, 19750276Speter gfc_array_i4 * const restrict, const index_type * const restrict, 19850276Speter gfc_array_l1 * const restrict); 19950276Speterexport_proto(miall_i4); 20050276Speter 20150276Spetervoid 20250276Spetermiall_i4 (gfc_array_i4 * const restrict retarray, 20350276Speter gfc_array_i4 * const restrict array, 20450276Speter const index_type * const restrict pdim, 20550276Speter gfc_array_l1 * const restrict mask) 20650276Speter{ 20750276Speter index_type count[GFC_MAX_DIMENSIONS]; 20850276Speter index_type extent[GFC_MAX_DIMENSIONS]; 20950276Speter index_type sstride[GFC_MAX_DIMENSIONS]; 21050276Speter index_type dstride[GFC_MAX_DIMENSIONS]; 21150276Speter index_type mstride[GFC_MAX_DIMENSIONS]; 21250276Speter GFC_INTEGER_4 * restrict dest; 21350276Speter const GFC_INTEGER_4 * restrict base; 21450276Speter const GFC_LOGICAL_1 * restrict mbase; 21562449Speter index_type rank; 21650276Speter index_type dim; 21762449Speter index_type n; 21862449Speter index_type len; 21962449Speter index_type delta; 22062449Speter index_type mdelta; 22162449Speter int mask_kind; 22262449Speter 22362449Speter if (mask == NULL) 22462449Speter { 22562449Speter#ifdef HAVE_BACK_ARG 22662449Speter iall_i4 (retarray, array, pdim, back); 22762449Speter#else 22850276Speter iall_i4 (retarray, array, pdim); 22950276Speter#endif 23050276Speter return; 23150276Speter } 23276726Speter 23350276Speter dim = (*pdim) - 1; 23498503Speter rank = GFC_DESCRIPTOR_RANK (array) - 1; 23598503Speter 23650276Speter 23750276Speter if (unlikely (dim < 0 || dim > rank)) 23862449Speter { 23950276Speter runtime_error ("Dim argument incorrect in IALL intrinsic: " 24098503Speter "is %ld, should be between 1 and %ld", 24198503Speter (long int) dim + 1, (long int) rank + 1); 24298503Speter } 24398503Speter 24498503Speter len = GFC_DESCRIPTOR_EXTENT(array,dim); 24598503Speter if (len <= 0) 24650276Speter return; 24797049Speter 24850276Speter mbase = mask->base_addr; 249 250 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 251 252 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 253#ifdef HAVE_GFC_LOGICAL_16 254 || mask_kind == 16 255#endif 256 ) 257 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 258 else 259 runtime_error ("Funny sized logical array"); 260 261 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 262 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); 263 264 for (n = 0; n < dim; n++) 265 { 266 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 267 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 268 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 269 270 if (extent[n] < 0) 271 extent[n] = 0; 272 273 } 274 for (n = dim; n < rank; n++) 275 { 276 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); 277 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); 278 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 279 280 if (extent[n] < 0) 281 extent[n] = 0; 282 } 283 284 if (retarray->base_addr == NULL) 285 { 286 size_t alloc_size, str; 287 288 for (n = 0; n < rank; n++) 289 { 290 if (n == 0) 291 str = 1; 292 else 293 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 294 295 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 296 297 } 298 299 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 300 301 retarray->offset = 0; 302 retarray->dtype.rank = rank; 303 304 if (alloc_size == 0) 305 { 306 /* Make sure we have a zero-sized array. */ 307 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 308 return; 309 } 310 else 311 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); 312 313 } 314 else 315 { 316 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 317 runtime_error ("rank of return array incorrect in IALL intrinsic"); 318 319 if (unlikely (compile_options.bounds_check)) 320 { 321 bounds_ifunction_return ((array_t *) retarray, extent, 322 "return value", "IALL"); 323 bounds_equal_extents ((array_t *) mask, (array_t *) array, 324 "MASK argument", "IALL"); 325 } 326 } 327 328 for (n = 0; n < rank; n++) 329 { 330 count[n] = 0; 331 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 332 if (extent[n] <= 0) 333 return; 334 } 335 336 dest = retarray->base_addr; 337 base = array->base_addr; 338 339 while (base) 340 { 341 const GFC_INTEGER_4 * restrict src; 342 const GFC_LOGICAL_1 * restrict msrc; 343 GFC_INTEGER_4 result; 344 src = base; 345 msrc = mbase; 346 { 347 348 result = (GFC_INTEGER_4) -1; 349 for (n = 0; n < len; n++, src += delta, msrc += mdelta) 350 { 351 352 if (*msrc) 353 result &= *src; 354 } 355 *dest = result; 356 } 357 /* Advance to the next element. */ 358 count[0]++; 359 base += sstride[0]; 360 mbase += mstride[0]; 361 dest += dstride[0]; 362 n = 0; 363 while (count[n] == extent[n]) 364 { 365 /* When we get to the end of a dimension, reset it and increment 366 the next dimension. */ 367 count[n] = 0; 368 /* We could precalculate these products, but this is a less 369 frequently used path so probably not worth it. */ 370 base -= sstride[n] * extent[n]; 371 mbase -= mstride[n] * extent[n]; 372 dest -= dstride[n] * extent[n]; 373 n++; 374 if (n >= rank) 375 { 376 /* Break out of the loop. */ 377 base = NULL; 378 break; 379 } 380 else 381 { 382 count[n]++; 383 base += sstride[n]; 384 mbase += mstride[n]; 385 dest += dstride[n]; 386 } 387 } 388 } 389} 390 391 392extern void siall_i4 (gfc_array_i4 * const restrict, 393 gfc_array_i4 * const restrict, const index_type * const restrict, 394 GFC_LOGICAL_4 *); 395export_proto(siall_i4); 396 397void 398siall_i4 (gfc_array_i4 * const restrict retarray, 399 gfc_array_i4 * const restrict array, 400 const index_type * const restrict pdim, 401 GFC_LOGICAL_4 * mask) 402{ 403 index_type count[GFC_MAX_DIMENSIONS]; 404 index_type extent[GFC_MAX_DIMENSIONS]; 405 index_type dstride[GFC_MAX_DIMENSIONS]; 406 GFC_INTEGER_4 * restrict dest; 407 index_type rank; 408 index_type n; 409 index_type dim; 410 411 412 if (mask == NULL || *mask) 413 { 414#ifdef HAVE_BACK_ARG 415 iall_i4 (retarray, array, pdim, back); 416#else 417 iall_i4 (retarray, array, pdim); 418#endif 419 return; 420 } 421 /* Make dim zero based to avoid confusion. */ 422 dim = (*pdim) - 1; 423 rank = GFC_DESCRIPTOR_RANK (array) - 1; 424 425 if (unlikely (dim < 0 || dim > rank)) 426 { 427 runtime_error ("Dim argument incorrect in IALL intrinsic: " 428 "is %ld, should be between 1 and %ld", 429 (long int) dim + 1, (long int) rank + 1); 430 } 431 432 for (n = 0; n < dim; n++) 433 { 434 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 435 436 if (extent[n] <= 0) 437 extent[n] = 0; 438 } 439 440 for (n = dim; n < rank; n++) 441 { 442 extent[n] = 443 GFC_DESCRIPTOR_EXTENT(array,n + 1); 444 445 if (extent[n] <= 0) 446 extent[n] = 0; 447 } 448 449 if (retarray->base_addr == NULL) 450 { 451 size_t alloc_size, str; 452 453 for (n = 0; n < rank; n++) 454 { 455 if (n == 0) 456 str = 1; 457 else 458 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 459 460 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 461 462 } 463 464 retarray->offset = 0; 465 retarray->dtype.rank = rank; 466 467 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 468 469 if (alloc_size == 0) 470 { 471 /* Make sure we have a zero-sized array. */ 472 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 473 return; 474 } 475 else 476 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); 477 } 478 else 479 { 480 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 481 runtime_error ("rank of return array incorrect in" 482 " IALL intrinsic: is %ld, should be %ld", 483 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 484 (long int) rank); 485 486 if (unlikely (compile_options.bounds_check)) 487 { 488 for (n=0; n < rank; n++) 489 { 490 index_type ret_extent; 491 492 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); 493 if (extent[n] != ret_extent) 494 runtime_error ("Incorrect extent in return value of" 495 " IALL intrinsic in dimension %ld:" 496 " is %ld, should be %ld", (long int) n + 1, 497 (long int) ret_extent, (long int) extent[n]); 498 } 499 } 500 } 501 502 for (n = 0; n < rank; n++) 503 { 504 count[n] = 0; 505 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 506 } 507 508 dest = retarray->base_addr; 509 510 while(1) 511 { 512 *dest = 0; 513 count[0]++; 514 dest += dstride[0]; 515 n = 0; 516 while (count[n] == extent[n]) 517 { 518 /* When we get to the end of a dimension, reset it and increment 519 the next dimension. */ 520 count[n] = 0; 521 /* We could precalculate these products, but this is a less 522 frequently used path so probably not worth it. */ 523 dest -= dstride[n] * extent[n]; 524 n++; 525 if (n >= rank) 526 return; 527 else 528 { 529 count[n]++; 530 dest += dstride[n]; 531 } 532 } 533 } 534} 535 536#endif 537