1`/* Helper function for cshift functions. 2 Copyright (C) 2008-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see 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 29include(iparm.m4)dnl 30 31`#if defined (HAVE_'rtype_name`) 32 33void 34cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ptrdiff_t shift, 35 int which) 36{ 37 /* r.* indicates the return array. */ 38 index_type rstride[GFC_MAX_DIMENSIONS]; 39 index_type rstride0; 40 index_type roffset; 41 'rtype_name` *rptr; 42 43 /* s.* indicates the source array. */ 44 index_type sstride[GFC_MAX_DIMENSIONS]; 45 index_type sstride0; 46 index_type soffset; 47 const 'rtype_name` *sptr; 48 49 index_type count[GFC_MAX_DIMENSIONS]; 50 index_type extent[GFC_MAX_DIMENSIONS]; 51 index_type dim; 52 index_type len; 53 index_type n; 54 55 bool do_blocked; 56 index_type r_ex, a_ex; 57 58 which = which - 1; 59 sstride[0] = 0; 60 rstride[0] = 0; 61 62 extent[0] = 1; 63 count[0] = 0; 64 n = 0; 65 /* Initialized for avoiding compiler warnings. */ 66 roffset = 1; 67 soffset = 1; 68 len = 0; 69 70 r_ex = 1; 71 a_ex = 1; 72 73 if (which > 0) 74 { 75 /* Test if both ret and array are contiguous. */ 76 do_blocked = true; 77 dim = GFC_DESCRIPTOR_RANK (array); 78 for (n = 0; n < dim; n ++) 79 { 80 index_type rs, as; 81 rs = GFC_DESCRIPTOR_STRIDE (ret, n); 82 if (rs != r_ex) 83 { 84 do_blocked = false; 85 break; 86 } 87 as = GFC_DESCRIPTOR_STRIDE (array, n); 88 if (as != a_ex) 89 { 90 do_blocked = false; 91 break; 92 } 93 r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n); 94 a_ex *= GFC_DESCRIPTOR_EXTENT (array, n); 95 } 96 } 97 else 98 do_blocked = false; 99 100 n = 0; 101 102 if (do_blocked) 103 { 104 /* For contiguous arrays, use the relationship that 105 106 dimension(n1,n2,n3) :: a, b 107 b = cshift(a,sh,3) 108 109 can be dealt with as if 110 111 dimension(n1*n2*n3) :: an, bn 112 bn = cshift(a,sh*n1*n2,1) 113 114 we can used a more blocked algorithm for dim>1. */ 115 sstride[0] = 1; 116 rstride[0] = 1; 117 roffset = 1; 118 soffset = 1; 119 len = GFC_DESCRIPTOR_STRIDE(array, which) 120 * GFC_DESCRIPTOR_EXTENT(array, which); 121 shift *= GFC_DESCRIPTOR_STRIDE(array, which); 122 for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++) 123 { 124 count[n] = 0; 125 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 126 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 127 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 128 n++; 129 } 130 dim = GFC_DESCRIPTOR_RANK (array) - which; 131 } 132 else 133 { 134 for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) 135 { 136 if (dim == which) 137 { 138 roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); 139 if (roffset == 0) 140 roffset = 1; 141 soffset = GFC_DESCRIPTOR_STRIDE(array,dim); 142 if (soffset == 0) 143 soffset = 1; 144 len = GFC_DESCRIPTOR_EXTENT(array,dim); 145 } 146 else 147 { 148 count[n] = 0; 149 extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); 150 rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); 151 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); 152 n++; 153 } 154 } 155 if (sstride[0] == 0) 156 sstride[0] = 1; 157 if (rstride[0] == 0) 158 rstride[0] = 1; 159 160 dim = GFC_DESCRIPTOR_RANK (array); 161 } 162 163 rstride0 = rstride[0]; 164 sstride0 = sstride[0]; 165 rptr = ret->base_addr; 166 sptr = array->base_addr; 167 168 /* Avoid the costly modulo for trivially in-bound shifts. */ 169 if (shift < 0 || shift >= len) 170 { 171 shift = len == 0 ? 0 : shift % (ptrdiff_t)len; 172 if (shift < 0) 173 shift += len; 174 } 175 176 while (rptr) 177 { 178 /* Do the shift for this dimension. */ 179 180 /* If elements are contiguous, perform the operation 181 in two block moves. */ 182 if (soffset == 1 && roffset == 1) 183 { 184 size_t len1 = shift * sizeof ('rtype_name`); 185 size_t len2 = (len - shift) * sizeof ('rtype_name`); 186 memcpy (rptr, sptr + shift, len2); 187 memcpy (rptr + (len - shift), sptr, len1); 188 } 189 else 190 { 191 /* Otherwise, we will have to perform the copy one element at 192 a time. */ 193 'rtype_name` *dest = rptr; 194 const 'rtype_name` *src = &sptr[shift * soffset]; 195 196 for (n = 0; n < len - shift; n++) 197 { 198 *dest = *src; 199 dest += roffset; 200 src += soffset; 201 } 202 for (src = sptr, n = 0; n < shift; n++) 203 { 204 *dest = *src; 205 dest += roffset; 206 src += soffset; 207 } 208 } 209 210 /* Advance to the next section. */ 211 rptr += rstride0; 212 sptr += sstride0; 213 count[0]++; 214 n = 0; 215 while (count[n] == extent[n]) 216 { 217 /* When we get to the end of a dimension, reset it and increment 218 the next dimension. */ 219 count[n] = 0; 220 /* We could precalculate these products, but this is a less 221 frequently used path so probably not worth it. */ 222 rptr -= rstride[n] * extent[n]; 223 sptr -= sstride[n] * extent[n]; 224 n++; 225 if (n >= dim - 1) 226 { 227 /* Break out of the loop. */ 228 rptr = NULL; 229 break; 230 } 231 else 232 { 233 count[n]++; 234 rptr += rstride[n]; 235 sptr += sstride[n]; 236 } 237 } 238 } 239 240 return; 241} 242 243#endif' 244