llvm-project
353 строки · 13.9 Кб
1//===-- runtime/findloc.cpp -----------------------------------------------===//
2//
3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4// See https://llvm.org/LICENSE.txt for license information.
5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6//
7//===----------------------------------------------------------------------===//
8
9// Implements FINDLOC for all required operand types and shapes and result
10// integer kinds.
11
12#include "reduction-templates.h"
13#include "flang/Runtime/character.h"
14#include "flang/Runtime/reduction.h"
15#include <cinttypes>
16#include <complex>
17
18namespace Fortran::runtime {
19
20template <TypeCategory CAT1, int KIND1, TypeCategory CAT2, int KIND2>
21struct Equality {
22using Type1 = CppTypeFor<CAT1, KIND1>;
23using Type2 = CppTypeFor<CAT2, KIND2>;
24RT_API_ATTRS bool operator()(const Descriptor &array,
25const SubscriptValue at[], const Descriptor &target) const {
26return *array.Element<Type1>(at) == *target.OffsetElement<Type2>();
27}
28};
29
30template <int KIND1, int KIND2>
31struct Equality<TypeCategory::Complex, KIND1, TypeCategory::Complex, KIND2> {
32using Type1 = CppTypeFor<TypeCategory::Complex, KIND1>;
33using Type2 = CppTypeFor<TypeCategory::Complex, KIND2>;
34RT_API_ATTRS bool operator()(const Descriptor &array,
35const SubscriptValue at[], const Descriptor &target) const {
36const Type1 &xz{*array.Element<Type1>(at)};
37const Type2 &tz{*target.OffsetElement<Type2>()};
38return xz.real() == tz.real() && xz.imag() == tz.imag();
39}
40};
41
42template <int KIND1, TypeCategory CAT2, int KIND2>
43struct Equality<TypeCategory::Complex, KIND1, CAT2, KIND2> {
44using Type1 = CppTypeFor<TypeCategory::Complex, KIND1>;
45using Type2 = CppTypeFor<CAT2, KIND2>;
46RT_API_ATTRS bool operator()(const Descriptor &array,
47const SubscriptValue at[], const Descriptor &target) const {
48const Type1 &z{*array.Element<Type1>(at)};
49return z.imag() == 0 && z.real() == *target.OffsetElement<Type2>();
50}
51};
52
53template <TypeCategory CAT1, int KIND1, int KIND2>
54struct Equality<CAT1, KIND1, TypeCategory::Complex, KIND2> {
55using Type1 = CppTypeFor<CAT1, KIND1>;
56using Type2 = CppTypeFor<TypeCategory::Complex, KIND2>;
57RT_API_ATTRS bool operator()(const Descriptor &array,
58const SubscriptValue at[], const Descriptor &target) const {
59const Type2 &z{*target.OffsetElement<Type2>()};
60return *array.Element<Type1>(at) == z.real() && z.imag() == 0;
61}
62};
63
64template <int KIND> struct CharacterEquality {
65using Type = CppTypeFor<TypeCategory::Character, KIND>;
66RT_API_ATTRS bool operator()(const Descriptor &array,
67const SubscriptValue at[], const Descriptor &target) const {
68return CharacterScalarCompare<Type>(array.Element<Type>(at),
69target.OffsetElement<Type>(),
70array.ElementBytes() / static_cast<unsigned>(KIND),
71target.ElementBytes() / static_cast<unsigned>(KIND)) == 0;
72}
73};
74
75struct LogicalEquivalence {
76RT_API_ATTRS bool operator()(const Descriptor &array,
77const SubscriptValue at[], const Descriptor &target) const {
78return IsLogicalElementTrue(array, at) ==
79IsLogicalElementTrue(target, at /*ignored*/);
80}
81};
82
83template <typename EQUALITY> class LocationAccumulator {
84public:
85RT_API_ATTRS LocationAccumulator(
86const Descriptor &array, const Descriptor &target, bool back)
87: array_{array}, target_{target}, back_{back} {}
88RT_API_ATTRS void Reinitialize() { gotAnything_ = false; }
89template <typename A>
90RT_API_ATTRS void GetResult(A *p, int zeroBasedDim = -1) {
91if (zeroBasedDim >= 0) {
92*p = gotAnything_ ? location_[zeroBasedDim] -
93array_.GetDimension(zeroBasedDim).LowerBound() + 1
94: 0;
95} else if (gotAnything_) {
96for (int j{0}; j < rank_; ++j) {
97p[j] = location_[j] - array_.GetDimension(j).LowerBound() + 1;
98}
99} else {
100// no unmasked hits? result is all zeroes
101for (int j{0}; j < rank_; ++j) {
102p[j] = 0;
103}
104}
105}
106template <typename IGNORED>
107RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {
108if (equality_(array_, at, target_)) {
109gotAnything_ = true;
110for (int j{0}; j < rank_; ++j) {
111location_[j] = at[j];
112}
113return back_;
114} else {
115return true;
116}
117}
118
119private:
120const Descriptor &array_;
121const Descriptor &target_;
122const bool back_{false};
123const int rank_{array_.rank()};
124bool gotAnything_{false};
125SubscriptValue location_[maxRank];
126const EQUALITY equality_{};
127};
128
129template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT>
130struct TotalNumericFindlocHelper {
131template <int TARGET_KIND> struct Functor {
132RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
133const Descriptor &target, int kind, int dim, const Descriptor *mask,
134bool back, Terminator &terminator) const {
135using Eq = Equality<XCAT, XKIND, TARGET_CAT, TARGET_KIND>;
136using Accumulator = LocationAccumulator<Eq>;
137Accumulator accumulator{x, target, back};
138DoTotalReduction<void>(x, dim, mask, accumulator, "FINDLOC", terminator);
139ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor,
140void>(kind, terminator, accumulator, result);
141}
142};
143};
144
145template <TypeCategory CAT,
146template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT>
147class HELPER>
148struct NumericFindlocHelper {
149template <int KIND> struct Functor {
150RT_API_ATTRS void operator()(TypeCategory targetCat, int targetKind,
151Descriptor &result, const Descriptor &x, const Descriptor &target,
152int kind, int dim, const Descriptor *mask, bool back,
153Terminator &terminator) const {
154switch (targetCat) {
155case TypeCategory::Integer:
156ApplyIntegerKind<
157HELPER<CAT, KIND, TypeCategory::Integer>::template Functor, void>(
158targetKind, terminator, result, x, target, kind, dim, mask, back,
159terminator);
160break;
161case TypeCategory::Real:
162ApplyFloatingPointKind<
163HELPER<CAT, KIND, TypeCategory::Real>::template Functor, void>(
164targetKind, terminator, result, x, target, kind, dim, mask, back,
165terminator);
166break;
167case TypeCategory::Complex:
168ApplyFloatingPointKind<
169HELPER<CAT, KIND, TypeCategory::Complex>::template Functor, void>(
170targetKind, terminator, result, x, target, kind, dim, mask, back,
171terminator);
172break;
173default:
174terminator.Crash(
175"FINDLOC: bad target category %d for array category %d",
176static_cast<int>(targetCat), static_cast<int>(CAT));
177}
178}
179};
180};
181
182template <int KIND> struct CharacterFindlocHelper {
183RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
184const Descriptor &target, int kind, const Descriptor *mask, bool back,
185Terminator &terminator) {
186using Accumulator = LocationAccumulator<CharacterEquality<KIND>>;
187Accumulator accumulator{x, target, back};
188DoTotalReduction<void>(x, 0, mask, accumulator, "FINDLOC", terminator);
189ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, void>(
190kind, terminator, accumulator, result);
191}
192};
193
194static RT_API_ATTRS void LogicalFindlocHelper(Descriptor &result,
195const Descriptor &x, const Descriptor &target, int kind,
196const Descriptor *mask, bool back, Terminator &terminator) {
197using Accumulator = LocationAccumulator<LogicalEquivalence>;
198Accumulator accumulator{x, target, back};
199DoTotalReduction<void>(x, 0, mask, accumulator, "FINDLOC", terminator);
200ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, void>(
201kind, terminator, accumulator, result);
202}
203
204extern "C" {
205RT_EXT_API_GROUP_BEGIN
206
207void RTDEF(Findloc)(Descriptor &result, const Descriptor &x,
208const Descriptor &target, int kind, const char *source, int line,
209const Descriptor *mask, bool back) {
210int rank{x.rank()};
211SubscriptValue extent[1]{rank};
212result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent,
213CFI_attribute_allocatable);
214result.GetDimension(0).SetBounds(1, extent[0]);
215Terminator terminator{source, line};
216if (int stat{result.Allocate()}) {
217terminator.Crash(
218"FINDLOC: could not allocate memory for result; STAT=%d", stat);
219}
220CheckIntegerKind(terminator, kind, "FINDLOC");
221auto xType{x.type().GetCategoryAndKind()};
222auto targetType{target.type().GetCategoryAndKind()};
223RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value());
224switch (xType->first) {
225case TypeCategory::Integer:
226ApplyIntegerKind<NumericFindlocHelper<TypeCategory::Integer,
227TotalNumericFindlocHelper>::template Functor,
228void>(xType->second, terminator, targetType->first, targetType->second,
229result, x, target, kind, 0, mask, back, terminator);
230break;
231case TypeCategory::Real:
232ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Real,
233TotalNumericFindlocHelper>::template Functor,
234void>(xType->second, terminator, targetType->first, targetType->second,
235result, x, target, kind, 0, mask, back, terminator);
236break;
237case TypeCategory::Complex:
238ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Complex,
239TotalNumericFindlocHelper>::template Functor,
240void>(xType->second, terminator, targetType->first, targetType->second,
241result, x, target, kind, 0, mask, back, terminator);
242break;
243case TypeCategory::Character:
244RUNTIME_CHECK(terminator,
245targetType->first == TypeCategory::Character &&
246targetType->second == xType->second);
247ApplyCharacterKind<CharacterFindlocHelper, void>(xType->second, terminator,
248result, x, target, kind, mask, back, terminator);
249break;
250case TypeCategory::Logical:
251RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical);
252LogicalFindlocHelper(result, x, target, kind, mask, back, terminator);
253break;
254default:
255terminator.Crash(
256"FINDLOC: bad data type code (%d) for array", x.type().raw());
257}
258}
259
260RT_EXT_API_GROUP_END
261} // extern "C"
262
263// FINDLOC with DIM=
264
265template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT>
266struct PartialNumericFindlocHelper {
267template <int TARGET_KIND> struct Functor {
268RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
269const Descriptor &target, int kind, int dim, const Descriptor *mask,
270bool back, Terminator &terminator) const {
271using Eq = Equality<XCAT, XKIND, TARGET_CAT, TARGET_KIND>;
272using Accumulator = LocationAccumulator<Eq>;
273Accumulator accumulator{x, target, back};
274ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor,
275void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC",
276accumulator);
277}
278};
279};
280
281template <int KIND> struct PartialCharacterFindlocHelper {
282RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
283const Descriptor &target, int kind, int dim, const Descriptor *mask,
284bool back, Terminator &terminator) {
285using Accumulator = LocationAccumulator<CharacterEquality<KIND>>;
286Accumulator accumulator{x, target, back};
287ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor,
288void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC",
289accumulator);
290}
291};
292
293static RT_API_ATTRS void PartialLogicalFindlocHelper(Descriptor &result,
294const Descriptor &x, const Descriptor &target, int kind, int dim,
295const Descriptor *mask, bool back, Terminator &terminator) {
296using Accumulator = LocationAccumulator<LogicalEquivalence>;
297Accumulator accumulator{x, target, back};
298ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, void>(
299kind, terminator, result, x, dim, mask, terminator, "FINDLOC",
300accumulator);
301}
302
303extern "C" {
304RT_EXT_API_GROUP_BEGIN
305
306void RTDEF(FindlocDim)(Descriptor &result, const Descriptor &x,
307const Descriptor &target, int kind, int dim, const char *source, int line,
308const Descriptor *mask, bool back) {
309Terminator terminator{source, line};
310CheckIntegerKind(terminator, kind, "FINDLOC");
311auto xType{x.type().GetCategoryAndKind()};
312auto targetType{target.type().GetCategoryAndKind()};
313RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value());
314switch (xType->first) {
315case TypeCategory::Integer:
316ApplyIntegerKind<NumericFindlocHelper<TypeCategory::Integer,
317PartialNumericFindlocHelper>::template Functor,
318void>(xType->second, terminator, targetType->first, targetType->second,
319result, x, target, kind, dim, mask, back, terminator);
320break;
321case TypeCategory::Real:
322ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Real,
323PartialNumericFindlocHelper>::template Functor,
324void>(xType->second, terminator, targetType->first, targetType->second,
325result, x, target, kind, dim, mask, back, terminator);
326break;
327case TypeCategory::Complex:
328ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Complex,
329PartialNumericFindlocHelper>::template Functor,
330void>(xType->second, terminator, targetType->first, targetType->second,
331result, x, target, kind, dim, mask, back, terminator);
332break;
333case TypeCategory::Character:
334RUNTIME_CHECK(terminator,
335targetType->first == TypeCategory::Character &&
336targetType->second == xType->second);
337ApplyCharacterKind<PartialCharacterFindlocHelper, void>(xType->second,
338terminator, result, x, target, kind, dim, mask, back, terminator);
339break;
340case TypeCategory::Logical:
341RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical);
342PartialLogicalFindlocHelper(
343result, x, target, kind, dim, mask, back, terminator);
344break;
345default:
346terminator.Crash(
347"FINDLOC: bad data type code (%d) for array", x.type().raw());
348}
349}
350
351RT_EXT_API_GROUP_END
352} // extern "C"
353} // namespace Fortran::runtime
354