PR rtl-optimization/57003
[official-gcc.git] / libgfortran / generated / product_r4.c
blob18dfdde96723018d395d524fd3d275344f1c489a
1 /* Implementation of the PRODUCT intrinsic
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
27 #include <stdlib.h>
28 #include <assert.h>
31 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4)
34 extern void product_r4 (gfc_array_r4 * const restrict,
35 gfc_array_r4 * const restrict, const index_type * const restrict);
36 export_proto(product_r4);
38 void
39 product_r4 (gfc_array_r4 * const restrict retarray,
40 gfc_array_r4 * const restrict array,
41 const index_type * const restrict pdim)
43 index_type count[GFC_MAX_DIMENSIONS];
44 index_type extent[GFC_MAX_DIMENSIONS];
45 index_type sstride[GFC_MAX_DIMENSIONS];
46 index_type dstride[GFC_MAX_DIMENSIONS];
47 const GFC_REAL_4 * restrict base;
48 GFC_REAL_4 * restrict dest;
49 index_type rank;
50 index_type n;
51 index_type len;
52 index_type delta;
53 index_type dim;
54 int continue_loop;
56 /* Make dim zero based to avoid confusion. */
57 dim = (*pdim) - 1;
58 rank = GFC_DESCRIPTOR_RANK (array) - 1;
60 len = GFC_DESCRIPTOR_EXTENT(array,dim);
61 if (len < 0)
62 len = 0;
63 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
65 for (n = 0; n < dim; n++)
67 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
68 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
70 if (extent[n] < 0)
71 extent[n] = 0;
73 for (n = dim; n < rank; n++)
75 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
76 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
78 if (extent[n] < 0)
79 extent[n] = 0;
82 if (retarray->base_addr == NULL)
84 size_t alloc_size, str;
86 for (n = 0; n < rank; n++)
88 if (n == 0)
89 str = 1;
90 else
91 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
93 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
97 retarray->offset = 0;
98 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
100 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
102 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_4));
103 if (alloc_size == 0)
105 /* Make sure we have a zero-sized array. */
106 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
107 return;
111 else
113 if (rank != GFC_DESCRIPTOR_RANK (retarray))
114 runtime_error ("rank of return array incorrect in"
115 " PRODUCT intrinsic: is %ld, should be %ld",
116 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
117 (long int) rank);
119 if (unlikely (compile_options.bounds_check))
120 bounds_ifunction_return ((array_t *) retarray, extent,
121 "return value", "PRODUCT");
124 for (n = 0; n < rank; n++)
126 count[n] = 0;
127 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
128 if (extent[n] <= 0)
129 return;
132 base = array->base_addr;
133 dest = retarray->base_addr;
135 continue_loop = 1;
136 while (continue_loop)
138 const GFC_REAL_4 * restrict src;
139 GFC_REAL_4 result;
140 src = base;
143 result = 1;
144 if (len <= 0)
145 *dest = 1;
146 else
148 for (n = 0; n < len; n++, src += delta)
151 result *= *src;
154 *dest = result;
157 /* Advance to the next element. */
158 count[0]++;
159 base += sstride[0];
160 dest += dstride[0];
161 n = 0;
162 while (count[n] == extent[n])
164 /* When we get to the end of a dimension, reset it and increment
165 the next dimension. */
166 count[n] = 0;
167 /* We could precalculate these products, but this is a less
168 frequently used path so probably not worth it. */
169 base -= sstride[n] * extent[n];
170 dest -= dstride[n] * extent[n];
171 n++;
172 if (n == rank)
174 /* Break out of the look. */
175 continue_loop = 0;
176 break;
178 else
180 count[n]++;
181 base += sstride[n];
182 dest += dstride[n];
189 extern void mproduct_r4 (gfc_array_r4 * const restrict,
190 gfc_array_r4 * const restrict, const index_type * const restrict,
191 gfc_array_l1 * const restrict);
192 export_proto(mproduct_r4);
194 void
195 mproduct_r4 (gfc_array_r4 * const restrict retarray,
196 gfc_array_r4 * const restrict array,
197 const index_type * const restrict pdim,
198 gfc_array_l1 * const restrict mask)
200 index_type count[GFC_MAX_DIMENSIONS];
201 index_type extent[GFC_MAX_DIMENSIONS];
202 index_type sstride[GFC_MAX_DIMENSIONS];
203 index_type dstride[GFC_MAX_DIMENSIONS];
204 index_type mstride[GFC_MAX_DIMENSIONS];
205 GFC_REAL_4 * restrict dest;
206 const GFC_REAL_4 * restrict base;
207 const GFC_LOGICAL_1 * restrict mbase;
208 int rank;
209 int dim;
210 index_type n;
211 index_type len;
212 index_type delta;
213 index_type mdelta;
214 int mask_kind;
216 dim = (*pdim) - 1;
217 rank = GFC_DESCRIPTOR_RANK (array) - 1;
219 len = GFC_DESCRIPTOR_EXTENT(array,dim);
220 if (len <= 0)
221 return;
223 mbase = mask->base_addr;
225 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
227 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
228 #ifdef HAVE_GFC_LOGICAL_16
229 || mask_kind == 16
230 #endif
232 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
233 else
234 runtime_error ("Funny sized logical array");
236 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
237 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
239 for (n = 0; n < dim; n++)
241 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
242 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
243 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
245 if (extent[n] < 0)
246 extent[n] = 0;
249 for (n = dim; n < rank; n++)
251 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
252 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
253 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
255 if (extent[n] < 0)
256 extent[n] = 0;
259 if (retarray->base_addr == NULL)
261 size_t alloc_size, str;
263 for (n = 0; n < rank; n++)
265 if (n == 0)
266 str = 1;
267 else
268 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
270 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
274 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
276 retarray->offset = 0;
277 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
279 if (alloc_size == 0)
281 /* Make sure we have a zero-sized array. */
282 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
283 return;
285 else
286 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_4));
289 else
291 if (rank != GFC_DESCRIPTOR_RANK (retarray))
292 runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
294 if (unlikely (compile_options.bounds_check))
296 bounds_ifunction_return ((array_t *) retarray, extent,
297 "return value", "PRODUCT");
298 bounds_equal_extents ((array_t *) mask, (array_t *) array,
299 "MASK argument", "PRODUCT");
303 for (n = 0; n < rank; n++)
305 count[n] = 0;
306 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
307 if (extent[n] <= 0)
308 return;
311 dest = retarray->base_addr;
312 base = array->base_addr;
314 while (base)
316 const GFC_REAL_4 * restrict src;
317 const GFC_LOGICAL_1 * restrict msrc;
318 GFC_REAL_4 result;
319 src = base;
320 msrc = mbase;
323 result = 1;
324 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
327 if (*msrc)
328 result *= *src;
330 *dest = result;
332 /* Advance to the next element. */
333 count[0]++;
334 base += sstride[0];
335 mbase += mstride[0];
336 dest += dstride[0];
337 n = 0;
338 while (count[n] == extent[n])
340 /* When we get to the end of a dimension, reset it and increment
341 the next dimension. */
342 count[n] = 0;
343 /* We could precalculate these products, but this is a less
344 frequently used path so probably not worth it. */
345 base -= sstride[n] * extent[n];
346 mbase -= mstride[n] * extent[n];
347 dest -= dstride[n] * extent[n];
348 n++;
349 if (n == rank)
351 /* Break out of the look. */
352 base = NULL;
353 break;
355 else
357 count[n]++;
358 base += sstride[n];
359 mbase += mstride[n];
360 dest += dstride[n];
367 extern void sproduct_r4 (gfc_array_r4 * const restrict,
368 gfc_array_r4 * const restrict, const index_type * const restrict,
369 GFC_LOGICAL_4 *);
370 export_proto(sproduct_r4);
372 void
373 sproduct_r4 (gfc_array_r4 * const restrict retarray,
374 gfc_array_r4 * const restrict array,
375 const index_type * const restrict pdim,
376 GFC_LOGICAL_4 * mask)
378 index_type count[GFC_MAX_DIMENSIONS];
379 index_type extent[GFC_MAX_DIMENSIONS];
380 index_type dstride[GFC_MAX_DIMENSIONS];
381 GFC_REAL_4 * restrict dest;
382 index_type rank;
383 index_type n;
384 index_type dim;
387 if (*mask)
389 product_r4 (retarray, array, pdim);
390 return;
392 /* Make dim zero based to avoid confusion. */
393 dim = (*pdim) - 1;
394 rank = GFC_DESCRIPTOR_RANK (array) - 1;
396 for (n = 0; n < dim; n++)
398 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
400 if (extent[n] <= 0)
401 extent[n] = 0;
404 for (n = dim; n < rank; n++)
406 extent[n] =
407 GFC_DESCRIPTOR_EXTENT(array,n + 1);
409 if (extent[n] <= 0)
410 extent[n] = 0;
413 if (retarray->base_addr == NULL)
415 size_t alloc_size, str;
417 for (n = 0; n < rank; n++)
419 if (n == 0)
420 str = 1;
421 else
422 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
424 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
428 retarray->offset = 0;
429 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
431 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
433 if (alloc_size == 0)
435 /* Make sure we have a zero-sized array. */
436 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
437 return;
439 else
440 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_4));
442 else
444 if (rank != GFC_DESCRIPTOR_RANK (retarray))
445 runtime_error ("rank of return array incorrect in"
446 " PRODUCT intrinsic: is %ld, should be %ld",
447 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
448 (long int) rank);
450 if (unlikely (compile_options.bounds_check))
452 for (n=0; n < rank; n++)
454 index_type ret_extent;
456 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
457 if (extent[n] != ret_extent)
458 runtime_error ("Incorrect extent in return value of"
459 " PRODUCT intrinsic in dimension %ld:"
460 " is %ld, should be %ld", (long int) n + 1,
461 (long int) ret_extent, (long int) extent[n]);
466 for (n = 0; n < rank; n++)
468 count[n] = 0;
469 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
472 dest = retarray->base_addr;
474 while(1)
476 *dest = 1;
477 count[0]++;
478 dest += dstride[0];
479 n = 0;
480 while (count[n] == extent[n])
482 /* When we get to the end of a dimension, reset it and increment
483 the next dimension. */
484 count[n] = 0;
485 /* We could precalculate these products, but this is a less
486 frequently used path so probably not worth it. */
487 dest -= dstride[n] * extent[n];
488 n++;
489 if (n == rank)
490 return;
491 else
493 count[n]++;
494 dest += dstride[n];
500 #endif