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