1 /* Helper function for cshift functions.
2 Copyright (C) 2008-2023 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.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 #include <string.h>
28
29
30 #if defined (HAVE_GFC_COMPLEX_8)
31
32 void
33 cshift0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, ptrdiff_t shift,
34 int which)
35 {
36 /* r.* indicates the return array. */
37 index_type rstride[GFC_MAX_DIMENSIONS];
38 index_type rstride0;
39 index_type roffset;
40 GFC_COMPLEX_8 *rptr;
41
42 /* s.* indicates the source array. */
43 index_type sstride[GFC_MAX_DIMENSIONS];
44 index_type sstride0;
45 index_type soffset;
46 const GFC_COMPLEX_8 *sptr;
47
48 index_type count[GFC_MAX_DIMENSIONS];
49 index_type extent[GFC_MAX_DIMENSIONS];
50 index_type dim;
51 index_type len;
52 index_type n;
53
54 bool do_blocked;
55 index_type r_ex, a_ex;
56
57 which = which - 1;
58 sstride[0] = 0;
59 rstride[0] = 0;
60
61 extent[0] = 1;
62 count[0] = 0;
63 n = 0;
64 /* Initialized for avoiding compiler warnings. */
65 roffset = 1;
66 soffset = 1;
67 len = 0;
68
69 r_ex = 1;
70 a_ex = 1;
71
72 if (which > 0)
73 {
74 /* Test if both ret and array are contiguous. */
75 do_blocked = true;
76 dim = GFC_DESCRIPTOR_RANK (array);
77 for (n = 0; n < dim; n ++)
78 {
79 index_type rs, as;
80 rs = GFC_DESCRIPTOR_STRIDE (ret, n);
81 if (rs != r_ex)
82 {
83 do_blocked = false;
84 break;
85 }
86 as = GFC_DESCRIPTOR_STRIDE (array, n);
87 if (as != a_ex)
88 {
89 do_blocked = false;
90 break;
91 }
92 r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
93 a_ex *= GFC_DESCRIPTOR_EXTENT (array, n);
94 }
95 }
96 else
97 do_blocked = false;
98
99 n = 0;
100
101 if (do_blocked)
102 {
103 /* For contiguous arrays, use the relationship that
104
105 dimension(n1,n2,n3) :: a, b
106 b = cshift(a,sh,3)
107
108 can be dealt with as if
109
110 dimension(n1*n2*n3) :: an, bn
111 bn = cshift(a,sh*n1*n2,1)
112
113 we can used a more blocked algorithm for dim>1. */
114 sstride[0] = 1;
115 rstride[0] = 1;
116 roffset = 1;
117 soffset = 1;
118 len = GFC_DESCRIPTOR_STRIDE(array, which)
119 * GFC_DESCRIPTOR_EXTENT(array, which);
120 shift *= GFC_DESCRIPTOR_STRIDE(array, which);
121 for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++)
122 {
123 count[n] = 0;
124 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
125 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
126 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
127 n++;
128 }
129 dim = GFC_DESCRIPTOR_RANK (array) - which;
130 }
131 else
132 {
133 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
134 {
135 if (dim == which)
136 {
137 roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
138 if (roffset == 0)
139 roffset = 1;
140 soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
141 if (soffset == 0)
142 soffset = 1;
143 len = GFC_DESCRIPTOR_EXTENT(array,dim);
144 }
145 else
146 {
147 count[n] = 0;
148 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
149 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
150 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
151 n++;
152 }
153 }
154 if (sstride[0] == 0)
155 sstride[0] = 1;
156 if (rstride[0] == 0)
157 rstride[0] = 1;
158
159 dim = GFC_DESCRIPTOR_RANK (array);
160 }
161
162 rstride0 = rstride[0];
163 sstride0 = sstride[0];
164 rptr = ret->base_addr;
165 sptr = array->base_addr;
166
167 /* Avoid the costly modulo for trivially in-bound shifts. */
168 if (shift < 0 || shift >= len)
169 {
170 shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
171 if (shift < 0)
172 shift += len;
173 }
174
175 while (rptr)
176 {
177 /* Do the shift for this dimension. */
178
179 /* If elements are contiguous, perform the operation
180 in two block moves. */
181 if (soffset == 1 && roffset == 1)
182 {
183 size_t len1 = shift * sizeof (GFC_COMPLEX_8);
184 size_t len2 = (len - shift) * sizeof (GFC_COMPLEX_8);
185 memcpy (rptr, sptr + shift, len2);
186 memcpy (rptr + (len - shift), sptr, len1);
187 }
188 else
189 {
190 /* Otherwise, we will have to perform the copy one element at
191 a time. */
192 GFC_COMPLEX_8 *dest = rptr;
193 const GFC_COMPLEX_8 *src = &sptr[shift * soffset];
194
195 for (n = 0; n < len - shift; n++)
196 {
197 *dest = *src;
198 dest += roffset;
199 src += soffset;
200 }
201 for (src = sptr, n = 0; n < shift; n++)
202 {
203 *dest = *src;
204 dest += roffset;
205 src += soffset;
206 }
207 }
208
209 /* Advance to the next section. */
210 rptr += rstride0;
211 sptr += sstride0;
212 count[0]++;
213 n = 0;
214 while (count[n] == extent[n])
215 {
216 /* When we get to the end of a dimension, reset it and increment
217 the next dimension. */
218 count[n] = 0;
219 /* We could precalculate these products, but this is a less
220 frequently used path so probably not worth it. */
221 rptr -= rstride[n] * extent[n];
222 sptr -= sstride[n] * extent[n];
223 n++;
224 if (n >= dim - 1)
225 {
226 /* Break out of the loop. */
227 rptr = NULL;
228 break;
229 }
230 else
231 {
232 count[n]++;
233 rptr += rstride[n];
234 sptr += sstride[n];
235 }
236 }
237 }
238
239 return;
240 }
241
242 #endif