1//===-- runtime/tools.h -----------------------------------------*- C++ -*-===//
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#ifndef FORTRAN_RUNTIME_TOOLS_H_
10#define FORTRAN_RUNTIME_TOOLS_H_
11
12#include "stat.h"
13#include "terminator.h"
14#include "flang/Common/optional.h"
15#include "flang/Runtime/cpp-type.h"
16#include "flang/Runtime/descriptor.h"
17#include "flang/Runtime/freestanding-tools.h"
18#include "flang/Runtime/memory.h"
19#include <cstring>
20#include <functional>
21#include <map>
22#include <type_traits>
23
24/// \macro RT_PRETTY_FUNCTION
25/// Gets a user-friendly looking function signature for the current scope
26/// using the best available method on each platform. The exact format of the
27/// resulting string is implementation specific and non-portable, so this should
28/// only be used, for example, for logging or diagnostics.
29/// Copy of LLVM_PRETTY_FUNCTION
30#if defined(_MSC_VER)
31#define RT_PRETTY_FUNCTION __FUNCSIG__
32#elif defined(__GNUC__) || defined(__clang__)
33#define RT_PRETTY_FUNCTION __PRETTY_FUNCTION__
34#else
35#define RT_PRETTY_FUNCTION __func__
36#endif
37
38#if defined(RT_DEVICE_COMPILATION)
39// Use the pseudo lock and pseudo file unit implementations
40// for the device.
41#define RT_USE_PSEUDO_LOCK 1
42#define RT_USE_PSEUDO_FILE_UNIT 1
43#endif
44
45namespace Fortran::runtime {
46
47class Terminator;
48
49RT_API_ATTRS std::size_t TrimTrailingSpaces(const char *, std::size_t);
50
51RT_API_ATTRS OwningPtr<char> SaveDefaultCharacter(
52 const char *, std::size_t, const Terminator &);
53
54// For validating and recognizing default CHARACTER values in a
55// case-insensitive manner. Returns the zero-based index into the
56// null-terminated array of upper-case possibilities when the value is valid,
57// or -1 when it has no match.
58RT_API_ATTRS int IdentifyValue(
59 const char *value, std::size_t length, const char *possibilities[]);
60
61// Truncates or pads as necessary
62RT_API_ATTRS void ToFortranDefaultCharacter(
63 char *to, std::size_t toLength, const char *from);
64
65// Utilities for dealing with elemental LOGICAL arguments
66inline RT_API_ATTRS bool IsLogicalElementTrue(
67 const Descriptor &logical, const SubscriptValue at[]) {
68 // A LOGICAL value is false if and only if all of its bytes are zero.
69 const char *p{logical.Element<char>(at)};
70 for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) {
71 if (*p) {
72 return true;
73 }
74 }
75 return false;
76}
77inline RT_API_ATTRS bool IsLogicalScalarTrue(const Descriptor &logical) {
78 // A LOGICAL value is false if and only if all of its bytes are zero.
79 const char *p{logical.OffsetElement<char>()};
80 for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) {
81 if (*p) {
82 return true;
83 }
84 }
85 return false;
86}
87
88// Check array conformability; a scalar 'x' conforms. Crashes on error.
89RT_API_ATTRS void CheckConformability(const Descriptor &to, const Descriptor &x,
90 Terminator &, const char *funcName, const char *toName,
91 const char *fromName);
92
93// Helper to store integer value in result[at].
94template <int KIND> struct StoreIntegerAt {
95 RT_API_ATTRS void operator()(const Fortran::runtime::Descriptor &result,
96 std::size_t at, std::int64_t value) const {
97 *result.ZeroBasedIndexedElement<Fortran::runtime::CppTypeFor<
98 Fortran::common::TypeCategory::Integer, KIND>>(at) = value;
99 }
100};
101
102// Validate a KIND= argument
103RT_API_ATTRS void CheckIntegerKind(
104 Terminator &, int kind, const char *intrinsic);
105
106template <typename TO, typename FROM>
107inline RT_API_ATTRS void PutContiguousConverted(
108 TO *to, FROM *from, std::size_t count) {
109 while (count-- > 0) {
110 *to++ = *from++;
111 }
112}
113
114static inline RT_API_ATTRS std::int64_t GetInt64(
115 const char *p, std::size_t bytes, Terminator &terminator) {
116 switch (bytes) {
117 case 1:
118 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
119 case 2:
120 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p);
121 case 4:
122 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p);
123 case 8:
124 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
125 default:
126 terminator.Crash("GetInt64: no case for %zd bytes", bytes);
127 }
128}
129
130static inline RT_API_ATTRS Fortran::common::optional<std::int64_t> GetInt64Safe(
131 const char *p, std::size_t bytes, Terminator &terminator) {
132 switch (bytes) {
133 case 1:
134 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 1> *>(p);
135 case 2:
136 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 2> *>(p);
137 case 4:
138 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 4> *>(p);
139 case 8:
140 return *reinterpret_cast<const CppTypeFor<TypeCategory::Integer, 8> *>(p);
141 case 16: {
142 using Int128 = CppTypeFor<TypeCategory::Integer, 16>;
143 auto n{*reinterpret_cast<const Int128 *>(p)};
144 std::int64_t result{static_cast<std::int64_t>(n)};
145 if (static_cast<Int128>(result) == n) {
146 return result;
147 }
148 return Fortran::common::nullopt;
149 }
150 default:
151 terminator.Crash("GetInt64Safe: no case for %zd bytes", bytes);
152 }
153}
154
155template <typename INT>
156inline RT_API_ATTRS bool SetInteger(INT &x, int kind, std::int64_t value) {
157 switch (kind) {
158 case 1:
159 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x) = value;
160 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 1> &>(x);
161 case 2:
162 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x) = value;
163 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 2> &>(x);
164 case 4:
165 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x) = value;
166 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 4> &>(x);
167 case 8:
168 reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x) = value;
169 return value == reinterpret_cast<CppTypeFor<TypeCategory::Integer, 8> &>(x);
170 default:
171 return false;
172 }
173}
174
175// Maps intrinsic runtime type category and kind values to the appropriate
176// instantiation of a function object template and calls it with the supplied
177// arguments.
178template <template <TypeCategory, int> class FUNC, typename RESULT,
179 typename... A>
180inline RT_API_ATTRS RESULT ApplyType(
181 TypeCategory cat, int kind, Terminator &terminator, A &&...x) {
182 switch (cat) {
183 case TypeCategory::Integer:
184 switch (kind) {
185 case 1:
186 return FUNC<TypeCategory::Integer, 1>{}(std::forward<A>(x)...);
187 case 2:
188 return FUNC<TypeCategory::Integer, 2>{}(std::forward<A>(x)...);
189 case 4:
190 return FUNC<TypeCategory::Integer, 4>{}(std::forward<A>(x)...);
191 case 8:
192 return FUNC<TypeCategory::Integer, 8>{}(std::forward<A>(x)...);
193#if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T
194 case 16:
195 return FUNC<TypeCategory::Integer, 16>{}(std::forward<A>(x)...);
196#endif
197 default:
198 terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
199 }
200 case TypeCategory::Real:
201 switch (kind) {
202#if 0 // TODO: REAL(2 & 3)
203 case 2:
204 return FUNC<TypeCategory::Real, 2>{}(std::forward<A>(x)...);
205 case 3:
206 return FUNC<TypeCategory::Real, 3>{}(std::forward<A>(x)...);
207#endif
208 case 4:
209 return FUNC<TypeCategory::Real, 4>{}(std::forward<A>(x)...);
210 case 8:
211 return FUNC<TypeCategory::Real, 8>{}(std::forward<A>(x)...);
212 case 10:
213 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
214 return FUNC<TypeCategory::Real, 10>{}(std::forward<A>(x)...);
215 }
216 break;
217 case 16:
218 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
219 return FUNC<TypeCategory::Real, 16>{}(std::forward<A>(x)...);
220 }
221 break;
222 }
223 terminator.Crash("not yet implemented: REAL(KIND=%d)", kind);
224 case TypeCategory::Complex:
225 switch (kind) {
226#if 0 // TODO: COMPLEX(2 & 3)
227 case 2:
228 return FUNC<TypeCategory::Complex, 2>{}(std::forward<A>(x)...);
229 case 3:
230 return FUNC<TypeCategory::Complex, 3>{}(std::forward<A>(x)...);
231#endif
232 case 4:
233 return FUNC<TypeCategory::Complex, 4>{}(std::forward<A>(x)...);
234 case 8:
235 return FUNC<TypeCategory::Complex, 8>{}(std::forward<A>(x)...);
236 case 10:
237 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
238 return FUNC<TypeCategory::Complex, 10>{}(std::forward<A>(x)...);
239 }
240 break;
241 case 16:
242 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
243 return FUNC<TypeCategory::Complex, 16>{}(std::forward<A>(x)...);
244 }
245 break;
246 }
247 terminator.Crash("not yet implemented: COMPLEX(KIND=%d)", kind);
248 case TypeCategory::Character:
249 switch (kind) {
250 case 1:
251 return FUNC<TypeCategory::Character, 1>{}(std::forward<A>(x)...);
252 case 2:
253 return FUNC<TypeCategory::Character, 2>{}(std::forward<A>(x)...);
254 case 4:
255 return FUNC<TypeCategory::Character, 4>{}(std::forward<A>(x)...);
256 default:
257 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
258 }
259 case TypeCategory::Logical:
260 switch (kind) {
261 case 1:
262 return FUNC<TypeCategory::Logical, 1>{}(std::forward<A>(x)...);
263 case 2:
264 return FUNC<TypeCategory::Logical, 2>{}(std::forward<A>(x)...);
265 case 4:
266 return FUNC<TypeCategory::Logical, 4>{}(std::forward<A>(x)...);
267 case 8:
268 return FUNC<TypeCategory::Logical, 8>{}(std::forward<A>(x)...);
269 default:
270 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
271 }
272 default:
273 terminator.Crash(
274 "not yet implemented: type category(%d)", static_cast<int>(cat));
275 }
276}
277
278// Maps a runtime INTEGER kind value to the appropriate instantiation of
279// a function object template and calls it with the supplied arguments.
280template <template <int KIND> class FUNC, typename RESULT, typename... A>
281inline RT_API_ATTRS RESULT ApplyIntegerKind(
282 int kind, Terminator &terminator, A &&...x) {
283 switch (kind) {
284 case 1:
285 return FUNC<1>{}(std::forward<A>(x)...);
286 case 2:
287 return FUNC<2>{}(std::forward<A>(x)...);
288 case 4:
289 return FUNC<4>{}(std::forward<A>(x)...);
290 case 8:
291 return FUNC<8>{}(std::forward<A>(x)...);
292#if defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T
293 case 16:
294 return FUNC<16>{}(std::forward<A>(x)...);
295#endif
296 default:
297 terminator.Crash("not yet implemented: INTEGER(KIND=%d)", kind);
298 }
299}
300
301template <template <int KIND> class FUNC, typename RESULT,
302 bool NEEDSMATH = false, typename... A>
303inline RT_API_ATTRS RESULT ApplyFloatingPointKind(
304 int kind, Terminator &terminator, A &&...x) {
305 switch (kind) {
306#if 0 // TODO: REAL/COMPLEX (2 & 3)
307 case 2:
308 return FUNC<2>{}(std::forward<A>(x)...);
309 case 3:
310 return FUNC<3>{}(std::forward<A>(x)...);
311#endif
312 case 4:
313 return FUNC<4>{}(std::forward<A>(x)...);
314 case 8:
315 return FUNC<8>{}(std::forward<A>(x)...);
316 case 10:
317 if constexpr (HasCppTypeFor<TypeCategory::Real, 10>) {
318 return FUNC<10>{}(std::forward<A>(x)...);
319 }
320 break;
321 case 16:
322 if constexpr (HasCppTypeFor<TypeCategory::Real, 16>) {
323 // If FUNC implemenation relies on FP math functions,
324 // then we should not be here. The compiler should have
325 // generated a call to an entry in FortranFloat128Math
326 // library.
327 if constexpr (!NEEDSMATH) {
328 return FUNC<16>{}(std::forward<A>(x)...);
329 }
330 }
331 break;
332 }
333 terminator.Crash("not yet implemented: REAL/COMPLEX(KIND=%d)", kind);
334}
335
336template <template <int KIND> class FUNC, typename RESULT, typename... A>
337inline RT_API_ATTRS RESULT ApplyCharacterKind(
338 int kind, Terminator &terminator, A &&...x) {
339 switch (kind) {
340 case 1:
341 return FUNC<1>{}(std::forward<A>(x)...);
342 case 2:
343 return FUNC<2>{}(std::forward<A>(x)...);
344 case 4:
345 return FUNC<4>{}(std::forward<A>(x)...);
346 default:
347 terminator.Crash("not yet implemented: CHARACTER(KIND=%d)", kind);
348 }
349}
350
351template <template <int KIND> class FUNC, typename RESULT, typename... A>
352inline RT_API_ATTRS RESULT ApplyLogicalKind(
353 int kind, Terminator &terminator, A &&...x) {
354 switch (kind) {
355 case 1:
356 return FUNC<1>{}(std::forward<A>(x)...);
357 case 2:
358 return FUNC<2>{}(std::forward<A>(x)...);
359 case 4:
360 return FUNC<4>{}(std::forward<A>(x)...);
361 case 8:
362 return FUNC<8>{}(std::forward<A>(x)...);
363 default:
364 terminator.Crash("not yet implemented: LOGICAL(KIND=%d)", kind);
365 }
366}
367
368// Calculate result type of (X op Y) for *, //, DOT_PRODUCT, &c.
369Fortran::common::optional<
370 std::pair<TypeCategory, int>> inline constexpr RT_API_ATTRS
371GetResultType(TypeCategory xCat, int xKind, TypeCategory yCat, int yKind) {
372 int maxKind{std::max(xKind, yKind)};
373 switch (xCat) {
374 case TypeCategory::Integer:
375 switch (yCat) {
376 case TypeCategory::Integer:
377 return std::make_pair(TypeCategory::Integer, maxKind);
378 case TypeCategory::Real:
379 case TypeCategory::Complex:
380#if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
381 if (xKind == 16) {
382 break;
383 }
384#endif
385 return std::make_pair(yCat, yKind);
386 default:
387 break;
388 }
389 break;
390 case TypeCategory::Real:
391 switch (yCat) {
392 case TypeCategory::Integer:
393#if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
394 if (yKind == 16) {
395 break;
396 }
397#endif
398 return std::make_pair(TypeCategory::Real, xKind);
399 case TypeCategory::Real:
400 case TypeCategory::Complex:
401 return std::make_pair(yCat, maxKind);
402 default:
403 break;
404 }
405 break;
406 case TypeCategory::Complex:
407 switch (yCat) {
408 case TypeCategory::Integer:
409#if !(defined __SIZEOF_INT128__ && !AVOID_NATIVE_UINT128_T)
410 if (yKind == 16) {
411 break;
412 }
413#endif
414 return std::make_pair(TypeCategory::Complex, xKind);
415 case TypeCategory::Real:
416 case TypeCategory::Complex:
417 return std::make_pair(TypeCategory::Complex, maxKind);
418 default:
419 break;
420 }
421 break;
422 case TypeCategory::Character:
423 if (yCat == TypeCategory::Character) {
424 return std::make_pair(TypeCategory::Character, maxKind);
425 } else {
426 return Fortran::common::nullopt;
427 }
428 case TypeCategory::Logical:
429 if (yCat == TypeCategory::Logical) {
430 return std::make_pair(TypeCategory::Logical, maxKind);
431 } else {
432 return Fortran::common::nullopt;
433 }
434 default:
435 break;
436 }
437 return Fortran::common::nullopt;
438}
439
440// Accumulate floating-point results in (at least) double precision
441template <TypeCategory CAT, int KIND>
442using AccumulationType = CppTypeFor<CAT,
443 CAT == TypeCategory::Real || CAT == TypeCategory::Complex
444 ? std::max(KIND, static_cast<int>(sizeof(double)))
445 : KIND>;
446
447// memchr() for any character type
448template <typename CHAR>
449static inline RT_API_ATTRS const CHAR *FindCharacter(
450 const CHAR *data, CHAR ch, std::size_t chars) {
451 const CHAR *end{data + chars};
452 for (const CHAR *p{data}; p < end; ++p) {
453 if (*p == ch) {
454 return p;
455 }
456 }
457 return nullptr;
458}
459
460template <>
461inline RT_API_ATTRS const char *FindCharacter(
462 const char *data, char ch, std::size_t chars) {
463 return reinterpret_cast<const char *>(
464 runtime::memchr(data, static_cast<int>(ch), chars));
465}
466
467// Copy payload data from one allocated descriptor to another.
468// Assumes element counts and element sizes match, and that both
469// descriptors are allocated.
470RT_API_ATTRS void ShallowCopyDiscontiguousToDiscontiguous(
471 const Descriptor &to, const Descriptor &from);
472RT_API_ATTRS void ShallowCopyDiscontiguousToContiguous(
473 const Descriptor &to, const Descriptor &from);
474RT_API_ATTRS void ShallowCopyContiguousToDiscontiguous(
475 const Descriptor &to, const Descriptor &from);
476RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from,
477 bool toIsContiguous, bool fromIsContiguous);
478RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from);
479
480// Ensures that a character string is null-terminated, allocating a /p length +1
481// size memory for null-terminator if necessary. Returns the original or a newly
482// allocated null-terminated string (responsibility for deallocation is on the
483// caller).
484RT_API_ATTRS char *EnsureNullTerminated(
485 char *str, std::size_t length, Terminator &terminator);
486
487RT_API_ATTRS bool IsValidCharDescriptor(const Descriptor *value);
488
489RT_API_ATTRS bool IsValidIntDescriptor(const Descriptor *intVal);
490
491// Copy a null-terminated character array \p rawValue to descriptor \p value.
492// The copy starts at the given \p offset, if not present then start at 0.
493// If descriptor `errmsg` is provided, error messages will be stored to it.
494// Returns stats specified in standard.
495RT_API_ATTRS std::int32_t CopyCharsToDescriptor(const Descriptor &value,
496 const char *rawValue, std::size_t rawValueLength,
497 const Descriptor *errmsg = nullptr, std::size_t offset = 0);
498
499RT_API_ATTRS void StoreIntToDescriptor(
500 const Descriptor *length, std::int64_t value, Terminator &terminator);
501
502// Defines a utility function for copying and padding characters
503template <typename TO, typename FROM>
504RT_API_ATTRS void CopyAndPad(
505 TO *to, const FROM *from, std::size_t toChars, std::size_t fromChars) {
506 if constexpr (sizeof(TO) != sizeof(FROM)) {
507 std::size_t copyChars{std::min(a: toChars, b: fromChars)};
508 for (std::size_t j{0}; j < copyChars; ++j) {
509 to[j] = from[j];
510 }
511 for (std::size_t j{copyChars}; j < toChars; ++j) {
512 to[j] = static_cast<TO>(' ');
513 }
514 } else if (toChars <= fromChars) {
515 std::memcpy(dest: to, src: from, n: toChars * sizeof(TO));
516 } else {
517 std::memcpy(dest: to, src: from, n: std::min(a: toChars, b: fromChars) * sizeof(TO));
518 for (std::size_t j{fromChars}; j < toChars; ++j) {
519 to[j] = static_cast<TO>(' ');
520 }
521 }
522}
523
524RT_API_ATTRS void CreatePartialReductionResult(Descriptor &result,
525 const Descriptor &x, std::size_t resultElementSize, int dim, Terminator &,
526 const char *intrinsic, TypeCode);
527
528} // namespace Fortran::runtime
529#endif // FORTRAN_RUNTIME_TOOLS_H_
530

source code of flang/runtime/tools.h