diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt --- a/flang/runtime/CMakeLists.txt +++ b/flang/runtime/CMakeLists.txt @@ -42,7 +42,9 @@ edit-input.cpp edit-output.cpp environment.cpp + extrema.cpp file.cpp + findloc.cpp format.cpp internal-unit.cpp iostat.cpp @@ -55,8 +57,10 @@ numeric.cpp random.cpp reduction.cpp + product.cpp stat.cpp stop.cpp + sum.cpp terminator.cpp tools.cpp transformational.cpp diff --git a/flang/runtime/extrema.cpp b/flang/runtime/extrema.cpp new file mode 100644 --- /dev/null +++ b/flang/runtime/extrema.cpp @@ -0,0 +1,592 @@ +//===-- runtime/extrema.cpp -----------------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Implements MAXLOC, MINLOC, MAXVAL, & MINVAL for all required operand types +// and shapes and (for MAXLOC & MINLOC) result integer kinds. + +#include "character.h" +#include "reduction-templates.h" +#include "reduction.h" +#include "flang/Common/long-double.h" +#include + +namespace Fortran::runtime { +// MAXLOC & MINLOC + +template struct NumericCompare { + using Type = T; + explicit NumericCompare(std::size_t /*elemLen; ignored*/) {} + bool operator()(const T &value, const T &previous) const { + if (value == previous) { + return BACK; + } else if constexpr (IS_MAX) { + return value > previous; + } else { + return value < previous; + } + } +}; + +template class CharacterCompare { +public: + using Type = T; + explicit CharacterCompare(std::size_t elemLen) + : chars_{elemLen / sizeof(T)} {} + bool operator()(const T &value, const T &previous) const { + int cmp{CharacterScalarCompare(&value, &previous, chars_, chars_)}; + if (cmp == 0) { + return BACK; + } else if constexpr (IS_MAX) { + return cmp > 0; + } else { + return cmp < 0; + } + } + +private: + std::size_t chars_; +}; + +template class ExtremumLocAccumulator { +public: + using Type = typename COMPARE::Type; + ExtremumLocAccumulator(const Descriptor &array, std::size_t chars = 0) + : array_{array}, argRank_{array.rank()}, compare_{array.ElementBytes()} { + Reinitialize(); + } + void Reinitialize() { + // per standard: result indices are all zero if no data + for (int j{0}; j < argRank_; ++j) { + extremumLoc_[j] = 0; + } + previous_ = nullptr; + } + int argRank() const { return argRank_; } + template void GetResult(A *p, int zeroBasedDim = -1) { + if (zeroBasedDim >= 0) { + *p = extremumLoc_[zeroBasedDim] - + array_.GetDimension(zeroBasedDim).LowerBound() + 1; + } else { + for (int j{0}; j < argRank_; ++j) { + p[j] = extremumLoc_[j] - array_.GetDimension(j).LowerBound() + 1; + } + } + } + template bool AccumulateAt(const SubscriptValue at[]) { + const auto &value{*array_.Element(at)}; + if (!previous_ || compare_(value, *previous_)) { + previous_ = &value; + for (int j{0}; j < argRank_; ++j) { + extremumLoc_[j] = at[j]; + } + } + return true; + } + +private: + const Descriptor &array_; + int argRank_; + SubscriptValue extremumLoc_[maxRank]; + const Type *previous_{nullptr}; + COMPARE compare_; +}; + +template +static void LocationHelper(const char *intrinsic, Descriptor &result, + const Descriptor &x, int kind, const Descriptor *mask, + Terminator &terminator) { + ACCUMULATOR accumulator{x}; + DoTotalReduction(x, 0, mask, accumulator, intrinsic, terminator); + ApplyIntegerKind::template Functor, void>( + kind, terminator, accumulator, result); +} + +template class COMPARE> +inline void DoMaxOrMinLoc(const char *intrinsic, Descriptor &result, + const Descriptor &x, int kind, const char *source, int line, + const Descriptor *mask, bool back) { + using CppType = CppTypeFor; + Terminator terminator{source, line}; + if (back) { + LocationHelper>, + CppType>(intrinsic, result, x, kind, mask, terminator); + } else { + LocationHelper>, + CppType>(intrinsic, result, x, kind, mask, terminator); + } +} + +template struct TypedMaxOrMinLocHelper { + template struct Functor { + void operator()(const char *intrinsic, Descriptor &result, + const Descriptor &x, int kind, const char *source, int line, + const Descriptor *mask, bool back) const { + DoMaxOrMinLoc( + intrinsic, result, x, kind, source, line, mask, back); + } + }; +}; + +template +inline void TypedMaxOrMinLoc(const char *intrinsic, Descriptor &result, + const Descriptor &x, int kind, const char *source, int line, + const Descriptor *mask, bool back) { + int rank{x.rank()}; + SubscriptValue extent[1]{rank}; + result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent, + CFI_attribute_allocatable); + result.GetDimension(0).SetBounds(1, extent[0]); + Terminator terminator{source, line}; + if (int stat{result.Allocate()}) { + terminator.Crash( + "%s: could not allocate memory for result; STAT=%d", intrinsic, stat); + } + CheckIntegerKind(terminator, kind, intrinsic); + auto catKind{x.type().GetCategoryAndKind()}; + RUNTIME_CHECK(terminator, catKind.has_value()); + switch (catKind->first) { + case TypeCategory::Integer: + ApplyIntegerKind< + TypedMaxOrMinLocHelper::template Functor, + void>(catKind->second, terminator, intrinsic, result, x, kind, source, + line, mask, back); + break; + case TypeCategory::Real: + ApplyFloatingPointKind< + TypedMaxOrMinLocHelper::template Functor, + void>(catKind->second, terminator, intrinsic, result, x, kind, source, + line, mask, back); + break; + case TypeCategory::Character: + ApplyCharacterKind::template Functor, + void>(catKind->second, terminator, intrinsic, result, x, kind, source, + line, mask, back); + break; + default: + terminator.Crash( + "%s: Bad data type code (%d) for array", intrinsic, x.type().raw()); + } +} + +extern "C" { +void RTNAME(Maxloc)(Descriptor &result, const Descriptor &x, int kind, + const char *source, int line, const Descriptor *mask, bool back) { + TypedMaxOrMinLoc("MAXLOC", result, x, kind, source, line, mask, back); +} +void RTNAME(Minloc)(Descriptor &result, const Descriptor &x, int kind, + const char *source, int line, const Descriptor *mask, bool back) { + TypedMaxOrMinLoc("MINLOC", result, x, kind, source, line, mask, back); +} +} // extern "C" + +// MAXLOC/MINLOC with DIM= + +template class COMPARE, bool BACK> +static void DoPartialMaxOrMinLocDirection(const char *intrinsic, + Descriptor &result, const Descriptor &x, int kind, int dim, + const Descriptor *mask, Terminator &terminator) { + using CppType = CppTypeFor; + using Accumulator = ExtremumLocAccumulator>; + Accumulator accumulator{x}; + ApplyIntegerKind::template Functor, void>( + kind, terminator, result, x, dim, mask, terminator, intrinsic, + accumulator); +} + +template class COMPARE> +inline void DoPartialMaxOrMinLoc(const char *intrinsic, Descriptor &result, + const Descriptor &x, int kind, int dim, const Descriptor *mask, bool back, + Terminator &terminator) { + if (back) { + DoPartialMaxOrMinLocDirection( + intrinsic, result, x, kind, dim, mask, terminator); + } else { + DoPartialMaxOrMinLocDirection( + intrinsic, result, x, kind, dim, mask, terminator); + } +} + +template class COMPARE> +struct DoPartialMaxOrMinLocHelper { + template struct Functor { + void operator()(const char *intrinsic, Descriptor &result, + const Descriptor &x, int kind, int dim, const Descriptor *mask, + bool back, Terminator &terminator) const { + DoPartialMaxOrMinLoc( + intrinsic, result, x, kind, dim, mask, back, terminator); + } + }; +}; + +template +inline void TypedPartialMaxOrMinLoc(const char *intrinsic, Descriptor &result, + const Descriptor &x, int kind, int dim, const char *source, int line, + const Descriptor *mask, bool back) { + Terminator terminator{source, line}; + CheckIntegerKind(terminator, kind, intrinsic); + auto catKind{x.type().GetCategoryAndKind()}; + RUNTIME_CHECK(terminator, catKind.has_value()); + switch (catKind->first) { + case TypeCategory::Integer: + ApplyIntegerKind::template Functor, + void>(catKind->second, terminator, intrinsic, result, x, kind, dim, + mask, back, terminator); + break; + case TypeCategory::Real: + ApplyFloatingPointKind::template Functor, + void>(catKind->second, terminator, intrinsic, result, x, kind, dim, + mask, back, terminator); + break; + case TypeCategory::Character: + ApplyCharacterKind::template Functor, + void>(catKind->second, terminator, intrinsic, result, x, kind, dim, + mask, back, terminator); + break; + default: + terminator.Crash( + "%s: Bad data type code (%d) for array", intrinsic, x.type().raw()); + } +} + +extern "C" { +void RTNAME(MaxlocDim)(Descriptor &result, const Descriptor &x, int kind, + int dim, const char *source, int line, const Descriptor *mask, bool back) { + TypedPartialMaxOrMinLoc( + "MAXLOC", result, x, kind, dim, source, line, mask, back); +} +void RTNAME(MinlocDim)(Descriptor &result, const Descriptor &x, int kind, + int dim, const char *source, int line, const Descriptor *mask, bool back) { + TypedPartialMaxOrMinLoc( + "MINLOC", result, x, kind, dim, source, line, mask, back); +} +} // extern "C" + +// MAXVAL and MINVAL + +template struct MaxOrMinIdentity { + using Type = CppTypeFor; + static constexpr Type Value() { + return IS_MAXVAL ? std::numeric_limits::lowest() + : std::numeric_limits::max(); + } +}; + +// std::numeric_limits<> may not know int128_t +template +struct MaxOrMinIdentity { + using Type = CppTypeFor; + static constexpr Type Value() { + return IS_MAXVAL ? Type{1} << 127 : ~Type{0} >> 1; + } +}; + +template +class NumericExtremumAccumulator { +public: + using Type = CppTypeFor; + explicit NumericExtremumAccumulator(const Descriptor &array) + : array_{array} {} + void Reinitialize() { + extremum_ = MaxOrMinIdentity::Value(); + } + template void GetResult(A *p, int /*zeroBasedDim*/ = -1) const { + *p = extremum_; + } + bool Accumulate(Type x) { + if constexpr (IS_MAXVAL) { + if (x > extremum_) { + extremum_ = x; + } + } else if (x < extremum_) { + extremum_ = x; + } + return true; + } + template bool AccumulateAt(const SubscriptValue at[]) { + return Accumulate(*array_.Element(at)); + } + +private: + const Descriptor &array_; + Type extremum_{MaxOrMinIdentity::Value()}; +}; + +template +inline CppTypeFor TotalNumericMaxOrMin(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask, + const char *intrinsic) { + return GetTotalReduction(x, source, line, dim, mask, + NumericExtremumAccumulator{x}, intrinsic); +} + +template class ACCUMULATOR> +static void DoMaxOrMin(Descriptor &result, const Descriptor &x, int dim, + const Descriptor *mask, const char *intrinsic, Terminator &terminator) { + using Type = CppTypeFor; + if (dim == 0 || x.rank() == 1) { + // Total reduction + result.Establish(x.type(), x.ElementBytes(), nullptr, 0, nullptr, + CFI_attribute_allocatable); + if (int stat{result.Allocate()}) { + terminator.Crash( + "%s: could not allocate memory for result; STAT=%d", intrinsic, stat); + } + ACCUMULATOR accumulator{x}; + DoTotalReduction(x, dim, mask, accumulator, intrinsic, terminator); + accumulator.GetResult(result.OffsetElement()); + } else { + // Partial reduction + using Accumulator = ACCUMULATOR; + Accumulator accumulator{x}; + PartialReduction( + result, x, dim, mask, terminator, intrinsic, accumulator); + } +} + +template struct MaxOrMinHelper { + template struct Functor { + void operator()(Descriptor &result, const Descriptor &x, int dim, + const Descriptor *mask, const char *intrinsic, + Terminator &terminator) const { + DoMaxOrMin( + result, x, dim, mask, intrinsic, terminator); + } + }; +}; + +template +inline void NumericMaxOrMin(Descriptor &result, const Descriptor &x, int dim, + const char *source, int line, const Descriptor *mask, + const char *intrinsic) { + Terminator terminator{source, line}; + auto type{x.type().GetCategoryAndKind()}; + RUNTIME_CHECK(terminator, type); + switch (type->first) { + case TypeCategory::Integer: + ApplyIntegerKind< + MaxOrMinHelper::template Functor, + void>( + type->second, terminator, result, x, dim, mask, intrinsic, terminator); + break; + case TypeCategory::Real: + ApplyFloatingPointKind< + MaxOrMinHelper::template Functor, void>( + type->second, terminator, result, x, dim, mask, intrinsic, terminator); + break; + default: + terminator.Crash("%s: bad type code %d", intrinsic, x.type().raw()); + } +} + +template +class CharacterExtremumAccumulator { +public: + using Type = CppTypeFor; + explicit CharacterExtremumAccumulator(const Descriptor &array) + : array_{array}, charLen_{array_.ElementBytes() / KIND} {} + void Reinitialize() { extremum_ = nullptr; } + template void GetResult(A *p, int /*zeroBasedDim*/ = -1) const { + static_assert(std::is_same_v); + if (extremum_) { + std::memcpy(p, extremum_, charLen_); + } else { + // empty array: result is all zero-valued characters + std::memset(p, 0, charLen_); + } + } + bool Accumulate(const Type *x) { + if (!extremum_) { + extremum_ = x; + } else { + int cmp{CharacterScalarCompare(x, extremum_, charLen_, charLen_)}; + if (IS_MAXVAL == (cmp > 0)) { + extremum_ = x; + } + } + return true; + } + template bool AccumulateAt(const SubscriptValue at[]) { + return Accumulate(array_.Element(at)); + } + +private: + const Descriptor &array_; + std::size_t charLen_; + const Type *extremum_{nullptr}; +}; + +template struct CharacterMaxOrMinHelper { + template struct Functor { + void operator()(Descriptor &result, const Descriptor &x, int dim, + const Descriptor *mask, const char *intrinsic, + Terminator &terminator) const { + DoMaxOrMin( + result, x, dim, mask, intrinsic, terminator); + } + }; +}; + +template +inline void CharacterMaxOrMin(Descriptor &result, const Descriptor &x, int dim, + const char *source, int line, const Descriptor *mask, + const char *intrinsic) { + Terminator terminator{source, line}; + auto type{x.type().GetCategoryAndKind()}; + RUNTIME_CHECK(terminator, type && type->first == TypeCategory::Character); + ApplyCharacterKind::template Functor, + void>( + type->second, terminator, result, x, dim, mask, intrinsic, terminator); +} + +extern "C" { +CppTypeFor RTNAME(MaxvalInteger1)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +CppTypeFor RTNAME(MaxvalInteger2)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +CppTypeFor RTNAME(MaxvalInteger4)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +CppTypeFor RTNAME(MaxvalInteger8)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +#ifdef __SIZEOF_INT128__ +CppTypeFor RTNAME(MaxvalInteger16)( + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +#endif + +// TODO: REAL(2 & 3) +CppTypeFor RTNAME(MaxvalReal4)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +CppTypeFor RTNAME(MaxvalReal8)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +#if LONG_DOUBLE == 80 +CppTypeFor RTNAME(MaxvalReal10)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +#elif LONG_DOUBLE == 128 +CppTypeFor RTNAME(MaxvalReal16)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MAXVAL"); +} +#endif + +void RTNAME(MaxvalCharacter)(Descriptor &result, const Descriptor &x, + const char *source, int line, const Descriptor *mask) { + CharacterMaxOrMin(result, x, 0, source, line, mask, "MAXVAL"); +} + +CppTypeFor RTNAME(MinvalInteger1)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +CppTypeFor RTNAME(MinvalInteger2)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +CppTypeFor RTNAME(MinvalInteger4)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +CppTypeFor RTNAME(MinvalInteger8)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +#ifdef __SIZEOF_INT128__ +CppTypeFor RTNAME(MinvalInteger16)( + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +#endif + +// TODO: REAL(2 & 3) +CppTypeFor RTNAME(MinvalReal4)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +CppTypeFor RTNAME(MinvalReal8)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +#if LONG_DOUBLE == 80 +CppTypeFor RTNAME(MinvalReal10)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +#elif LONG_DOUBLE == 128 +CppTypeFor RTNAME(MinvalReal16)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return TotalNumericMaxOrMin( + x, source, line, dim, mask, "MINVAL"); +} +#endif + +void RTNAME(MinvalCharacter)(Descriptor &result, const Descriptor &x, + const char *source, int line, const Descriptor *mask) { + CharacterMaxOrMin(result, x, 0, source, line, mask, "MINVAL"); +} + +void RTNAME(MaxvalDim)(Descriptor &result, const Descriptor &x, int dim, + const char *source, int line, const Descriptor *mask) { + if (x.type().IsCharacter()) { + CharacterMaxOrMin(result, x, dim, source, line, mask, "MAXVAL"); + } else { + NumericMaxOrMin(result, x, dim, source, line, mask, "MAXVAL"); + } +} +void RTNAME(MinvalDim)(Descriptor &result, const Descriptor &x, int dim, + const char *source, int line, const Descriptor *mask) { + if (x.type().IsCharacter()) { + CharacterMaxOrMin(result, x, dim, source, line, mask, "MINVAL"); + } else { + NumericMaxOrMin(result, x, dim, source, line, mask, "MINVAL"); + } +} +} // extern "C" +} // namespace Fortran::runtime diff --git a/flang/runtime/findloc.cpp b/flang/runtime/findloc.cpp new file mode 100644 --- /dev/null +++ b/flang/runtime/findloc.cpp @@ -0,0 +1,342 @@ +//===-- runtime/findloc.cpp -----------------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Implements FINDLOC for all required operand types and shapes and result +// integer kinds. + +#include "character.h" +#include "reduction-templates.h" +#include "reduction.h" +#include "flang/Common/long-double.h" +#include +#include + +namespace Fortran::runtime { + +template +struct Equality { + using Type1 = CppTypeFor; + using Type2 = CppTypeFor; + bool operator()(const Descriptor &array, const SubscriptValue at[], + const Descriptor &target) const { + return *array.Element(at) == *target.OffsetElement(); + } +}; + +template +struct Equality { + using Type1 = CppTypeFor; + using Type2 = CppTypeFor; + bool operator()(const Descriptor &array, const SubscriptValue at[], + const Descriptor &target) const { + const Type1 &xz{*array.Element(at)}; + const Type2 &tz{*target.OffsetElement()}; + return xz.real() == tz.real() && xz.imag() == tz.imag(); + } +}; + +template +struct Equality { + using Type1 = CppTypeFor; + using Type2 = CppTypeFor; + bool operator()(const Descriptor &array, const SubscriptValue at[], + const Descriptor &target) const { + const Type1 &z{*array.Element(at)}; + return z.imag() == 0 && z.real() == *target.OffsetElement(); + } +}; + +template +struct Equality { + using Type1 = CppTypeFor; + using Type2 = CppTypeFor; + bool operator()(const Descriptor &array, const SubscriptValue at[], + const Descriptor &target) const { + const Type2 &z{*target.OffsetElement()}; + return *array.Element(at) == z.real() && z.imag() == 0; + } +}; + +template struct CharacterEquality { + using Type = CppTypeFor; + bool operator()(const Descriptor &array, const SubscriptValue at[], + const Descriptor &target) const { + return CharacterScalarCompare(array.Element(at), + target.OffsetElement(), + array.ElementBytes() / static_cast(KIND), + target.ElementBytes() / static_cast(KIND)) == 0; + } +}; + +struct LogicalEquivalence { + bool operator()(const Descriptor &array, const SubscriptValue at[], + const Descriptor &target) const { + return IsLogicalElementTrue(array, at) == + IsLogicalElementTrue(target, at /*ignored*/); + } +}; + +template class LocationAccumulator { +public: + LocationAccumulator( + const Descriptor &array, const Descriptor &target, bool back) + : array_{array}, target_{target}, back_{back} { + Reinitialize(); + } + void Reinitialize() { + // per standard: result indices are all zero if no data + for (int j{0}; j < rank_; ++j) { + location_[j] = 0; + } + } + template void GetResult(A *p, int zeroBasedDim = -1) { + if (zeroBasedDim >= 0) { + *p = location_[zeroBasedDim] - + array_.GetDimension(zeroBasedDim).LowerBound() + 1; + } else { + for (int j{0}; j < rank_; ++j) { + p[j] = location_[j] - array_.GetDimension(j).LowerBound() + 1; + } + } + } + template bool AccumulateAt(const SubscriptValue at[]) { + if (equality_(array_, at, target_)) { + for (int j{0}; j < rank_; ++j) { + location_[j] = at[j]; + } + return back_; + } else { + return true; + } + } + +private: + const Descriptor &array_; + const Descriptor &target_; + const bool back_{false}; + const int rank_{array_.rank()}; + SubscriptValue location_[maxRank]; + const EQUALITY equality_{}; +}; + +template +struct TotalNumericFindlocHelper { + template struct Functor { + void operator()(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, int dim, const Descriptor *mask, + bool back, Terminator &terminator) const { + using Eq = Equality; + using Accumulator = LocationAccumulator; + Accumulator accumulator{x, target, back}; + DoTotalReduction(x, dim, mask, accumulator, "FINDLOC", terminator); + ApplyIntegerKind::template Functor, + void>(kind, terminator, accumulator, result); + } + }; +}; + +template + class HELPER> +struct NumericFindlocHelper { + template struct Functor { + void operator()(TypeCategory targetCat, int targetKind, Descriptor &result, + const Descriptor &x, const Descriptor &target, int kind, int dim, + const Descriptor *mask, bool back, Terminator &terminator) const { + switch (targetCat) { + case TypeCategory::Integer: + ApplyIntegerKind< + HELPER::template Functor, void>( + targetKind, terminator, result, x, target, kind, dim, mask, back, + terminator); + break; + case TypeCategory::Real: + ApplyFloatingPointKind< + HELPER::template Functor, void>( + targetKind, terminator, result, x, target, kind, dim, mask, back, + terminator); + break; + case TypeCategory::Complex: + ApplyFloatingPointKind< + HELPER::template Functor, void>( + targetKind, terminator, result, x, target, kind, dim, mask, back, + terminator); + break; + default: + terminator.Crash( + "FINDLOC: bad target category %d for array category %d", + static_cast(targetCat), static_cast(CAT)); + } + } + }; +}; + +template struct CharacterFindlocHelper { + void operator()(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, const Descriptor *mask, bool back, + Terminator &terminator) { + using Accumulator = LocationAccumulator>; + Accumulator accumulator{x, target, back}; + DoTotalReduction(x, 0, mask, accumulator, "FINDLOC", terminator); + ApplyIntegerKind::template Functor, void>( + kind, terminator, accumulator, result); + } +}; + +static void LogicalFindlocHelper(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, const Descriptor *mask, bool back, + Terminator &terminator) { + using Accumulator = LocationAccumulator; + Accumulator accumulator{x, target, back}; + DoTotalReduction(x, 0, mask, accumulator, "FINDLOC", terminator); + ApplyIntegerKind::template Functor, void>( + kind, terminator, accumulator, result); +} + +extern "C" { +void RTNAME(Findloc)(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, const char *source, int line, + const Descriptor *mask, bool back) { + int rank{x.rank()}; + SubscriptValue extent[1]{rank}; + result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent, + CFI_attribute_allocatable); + result.GetDimension(0).SetBounds(1, extent[0]); + Terminator terminator{source, line}; + if (int stat{result.Allocate()}) { + terminator.Crash( + "FINDLOC: could not allocate memory for result; STAT=%d", stat); + } + CheckIntegerKind(terminator, kind, "FINDLOC"); + auto xType{x.type().GetCategoryAndKind()}; + auto targetType{target.type().GetCategoryAndKind()}; + RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value()); + switch (xType->first) { + case TypeCategory::Integer: + ApplyIntegerKind::template Functor, + void>(xType->second, terminator, targetType->first, targetType->second, + result, x, target, kind, 0, mask, back, terminator); + break; + case TypeCategory::Real: + ApplyFloatingPointKind::template Functor, + void>(xType->second, terminator, targetType->first, targetType->second, + result, x, target, kind, 0, mask, back, terminator); + break; + case TypeCategory::Complex: + ApplyFloatingPointKind::template Functor, + void>(xType->second, terminator, targetType->first, targetType->second, + result, x, target, kind, 0, mask, back, terminator); + break; + case TypeCategory::Character: + RUNTIME_CHECK(terminator, + targetType->first == TypeCategory::Character && + targetType->second == xType->second); + ApplyCharacterKind(xType->second, terminator, + result, x, target, kind, mask, back, terminator); + break; + case TypeCategory::Logical: + RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical); + LogicalFindlocHelper(result, x, target, kind, mask, back, terminator); + break; + default: + terminator.Crash( + "FINDLOC: Bad data type code (%d) for array", x.type().raw()); + } +} +} // extern "C" + +// FINDLOC with DIM= + +template +struct PartialNumericFindlocHelper { + template struct Functor { + void operator()(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, int dim, const Descriptor *mask, + bool back, Terminator &terminator) const { + using Eq = Equality; + using Accumulator = LocationAccumulator; + Accumulator accumulator{x, target, back}; + ApplyIntegerKind::template Functor, + void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC", + accumulator); + } + }; +}; + +template struct PartialCharacterFindlocHelper { + void operator()(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, int dim, const Descriptor *mask, + bool back, Terminator &terminator) { + using Accumulator = LocationAccumulator>; + Accumulator accumulator{x, target, back}; + ApplyIntegerKind::template Functor, + void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC", + accumulator); + } +}; + +static void PartialLogicalFindlocHelper(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, int dim, const Descriptor *mask, + bool back, Terminator &terminator) { + using Accumulator = LocationAccumulator; + Accumulator accumulator{x, target, back}; + ApplyIntegerKind::template Functor, void>( + kind, terminator, result, x, dim, mask, terminator, "FINDLOC", + accumulator); +} + +extern "C" { +void RTNAME(FindlocDim)(Descriptor &result, const Descriptor &x, + const Descriptor &target, int kind, int dim, const char *source, int line, + const Descriptor *mask, bool back) { + Terminator terminator{source, line}; + CheckIntegerKind(terminator, kind, "FINDLOC"); + auto xType{x.type().GetCategoryAndKind()}; + auto targetType{target.type().GetCategoryAndKind()}; + RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value()); + switch (xType->first) { + case TypeCategory::Integer: + ApplyIntegerKind::template Functor, + void>(xType->second, terminator, targetType->first, targetType->second, + result, x, target, kind, dim, mask, back, terminator); + break; + case TypeCategory::Real: + ApplyFloatingPointKind::template Functor, + void>(xType->second, terminator, targetType->first, targetType->second, + result, x, target, kind, dim, mask, back, terminator); + break; + case TypeCategory::Complex: + ApplyFloatingPointKind::template Functor, + void>(xType->second, terminator, targetType->first, targetType->second, + result, x, target, kind, dim, mask, back, terminator); + break; + case TypeCategory::Character: + RUNTIME_CHECK(terminator, + targetType->first == TypeCategory::Character && + targetType->second == xType->second); + ApplyCharacterKind(xType->second, + terminator, result, x, target, kind, dim, mask, back, terminator); + break; + case TypeCategory::Logical: + RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical); + PartialLogicalFindlocHelper( + result, x, target, kind, dim, mask, back, terminator); + break; + default: + terminator.Crash( + "FINDLOC: Bad data type code (%d) for array", x.type().raw()); + } +} +} // extern "C" +} // namespace Fortran::runtime diff --git a/flang/runtime/product.cpp b/flang/runtime/product.cpp new file mode 100644 --- /dev/null +++ b/flang/runtime/product.cpp @@ -0,0 +1,163 @@ +//===-- runtime/product.cpp -----------------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Implements PRODUCT for all required operand types and shapes. + +#include "reduction-templates.h" +#include "reduction.h" +#include "flang/Common/long-double.h" +#include +#include + +namespace Fortran::runtime { +template class NonComplexProductAccumulator { +public: + explicit NonComplexProductAccumulator(const Descriptor &array) + : array_{array} {} + void Reinitialize() { product_ = 1; } + template void GetResult(A *p, int /*zeroBasedDim*/ = -1) const { + *p = static_cast(product_); + } + template bool AccumulateAt(const SubscriptValue at[]) { + product_ *= *array_.Element(at); + return product_ != 0; + } + +private: + const Descriptor &array_; + INTERMEDIATE product_{1}; +}; + +template class ComplexProductAccumulator { +public: + explicit ComplexProductAccumulator(const Descriptor &array) : array_{array} {} + void Reinitialize() { product_ = std::complex{1, 0}; } + template void GetResult(A *p, int /*zeroBasedDim*/ = -1) const { + using ResultPart = typename A::value_type; + *p = {static_cast(product_.real()), + static_cast(product_.imag())}; + } + template bool AccumulateAt(const SubscriptValue at[]) { + product_ *= *array_.Element(at); + return true; + } + +private: + const Descriptor &array_; + std::complex product_{1, 0}; +}; + +extern "C" { +CppTypeFor RTNAME(ProductInteger1)( + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +CppTypeFor RTNAME(ProductInteger2)( + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +CppTypeFor RTNAME(ProductInteger4)( + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +CppTypeFor RTNAME(ProductInteger8)( + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +#ifdef __SIZEOF_INT128__ +CppTypeFor RTNAME(ProductInteger16)( + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, + mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +#endif + +// TODO: real/complex(2 & 3) +CppTypeFor RTNAME(ProductReal4)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +CppTypeFor RTNAME(ProductReal8)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +#if LONG_DOUBLE == 80 +CppTypeFor RTNAME(ProductReal10)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +#elif LONG_DOUBLE == 128 +CppTypeFor RTNAME(ProductReal16)(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask) { + return GetTotalReduction(x, source, line, dim, mask, + NonComplexProductAccumulator>{x}, + "PRODUCT"); +} +#endif + +void RTNAME(CppProductComplex4)(CppTypeFor &result, + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + result = GetTotalReduction(x, source, line, dim, + mask, ComplexProductAccumulator>{x}, + "PRODUCT"); +} +void RTNAME(CppProductComplex8)(CppTypeFor &result, + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + result = GetTotalReduction(x, source, line, dim, + mask, ComplexProductAccumulator>{x}, + "PRODUCT"); +} +#if LONG_DOUBLE == 80 +void RTNAME(CppProductComplex10)(CppTypeFor &result, + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + result = GetTotalReduction(x, source, line, dim, + mask, ComplexProductAccumulator>{x}, + "PRODUCT"); +} +#elif LONG_DOUBLE == 128 +void RTNAME(CppProductComplex16)(CppTypeFor &result, + const Descriptor &x, const char *source, int line, int dim, + const Descriptor *mask) { + result = GetTotalReduction(x, source, line, dim, + mask, ComplexProductAccumulator>{x}, + "PRODUCT"); +} +#endif + +void RTNAME(ProductDim)(Descriptor &result, const Descriptor &x, int dim, + const char *source, int line, const Descriptor *mask) { + TypedPartialNumericReduction( + result, x, dim, source, line, mask, "PRODUCT"); +} +} // extern "C" +} // namespace Fortran::runtime diff --git a/flang/runtime/reduction-templates.h b/flang/runtime/reduction-templates.h new file mode 100644 --- /dev/null +++ b/flang/runtime/reduction-templates.h @@ -0,0 +1,323 @@ +//===-- runtime/reduction-templates.h -------------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +// Generic function templates used by various reduction transformation +// intrinsic functions (SUM, PRODUCT, &c.) +// +// * Partial reductions (i.e., those with DIM= arguments that are not +// required to be 1 by the rank of the argument) return arrays that +// are dynamically allocated in a caller-supplied descriptor. +// * Total reductions (i.e., no DIM= argument) with FINDLOC, MAXLOC, & MINLOC +// return integer vectors of some kind, not scalars; a caller-supplied +// descriptor is used +// * Character-valued reductions (MAXVAL & MINVAL) return arbitrary +// length results, dynamically allocated in a caller-supplied descriptor + +#ifndef FORTRAN_RUNTIME_REDUCTION_TEMPLATES_H_ +#define FORTRAN_RUNTIME_REDUCTION_TEMPLATES_H_ + +#include "cpp-type.h" +#include "descriptor.h" +#include "terminator.h" +#include "tools.h" + +namespace Fortran::runtime { + +// Reductions are implemented with *accumulators*, which are instances of +// classes that incrementally build up the result (or an element thereof) during +// a traversal of the unmasked elements of an array. Each accumulator class +// supports a constructor (which captures a reference to the array), an +// AccumulateAt() member function that applies supplied subscripts to the +// array and does something with a scalar element, and a GetResult() +// member function that copies a final result into its destination. + +// Total reduction of the array argument to a scalar (or to a vector in the +// cases of FINDLOC, MAXLOC, & MINLOC). These are the cases without DIM= or +// cases where the argument has rank 1 and DIM=, if present, must be 1. +template +inline void DoTotalReduction(const Descriptor &x, int dim, + const Descriptor *mask, ACCUMULATOR &accumulator, const char *intrinsic, + Terminator &terminator) { + if (dim < 0 || dim > 1) { + terminator.Crash( + "%s: bad DIM=%d for argument with rank %d", intrinsic, dim, x.rank()); + } + SubscriptValue xAt[maxRank]; + x.GetLowerBounds(xAt); + if (mask) { + CheckConformability(x, *mask, terminator, intrinsic, "ARRAY", "MASK"); + SubscriptValue maskAt[maxRank]; + mask->GetLowerBounds(maskAt); + if (mask->rank() > 0) { + for (auto elements{x.Elements()}; elements--; + x.IncrementSubscripts(xAt), mask->IncrementSubscripts(maskAt)) { + if (IsLogicalElementTrue(*mask, maskAt)) { + accumulator.template AccumulateAt(xAt); + } + } + return; + } else if (!IsLogicalElementTrue(*mask, maskAt)) { + // scalar MASK=.FALSE.: return identity value + return; + } + } + // No MASK=, or scalar MASK=.TRUE. + for (auto elements{x.Elements()}; elements--; x.IncrementSubscripts(xAt)) { + if (!accumulator.template AccumulateAt(xAt)) { + break; // cut short, result is known + } + } +} + +template +inline CppTypeFor GetTotalReduction(const Descriptor &x, + const char *source, int line, int dim, const Descriptor *mask, + ACCUMULATOR &&accumulator, const char *intrinsic) { + Terminator terminator{source, line}; + RUNTIME_CHECK(terminator, TypeCode(CAT, KIND) == x.type()); + using CppType = CppTypeFor; + DoTotalReduction(x, dim, mask, accumulator, intrinsic, terminator); + CppType result; +#ifdef _MSC_VER // work around MSVC spurious error + accumulator.GetResult(&result); +#else + accumulator.template GetResult(&result); +#endif + return result; +} + +// For reductions on a dimension, e.g. SUM(array,DIM=2) where the shape +// of the array is [2,3,5], the shape of the result is [2,5] and +// result(j,k) = SUM(array(j,:,k)), possibly modified if the array has +// lower bounds other than one. This utility subroutine creates an +// array of subscripts [j,_,k] for result subscripts [j,k] so that the +// elemets of array(j,:,k) can be reduced. +inline void GetExpandedSubscripts(SubscriptValue at[], + const Descriptor &descriptor, int zeroBasedDim, + const SubscriptValue from[]) { + descriptor.GetLowerBounds(at); + int rank{descriptor.rank()}; + int j{0}; + for (; j < zeroBasedDim; ++j) { + at[j] += from[j] - 1 /*lower bound*/; + } + for (++j; j < rank; ++j) { + at[j] += from[j - 1] - 1; + } +} + +template +inline void ReduceDimToScalar(const Descriptor &x, int zeroBasedDim, + SubscriptValue subscripts[], TYPE *result, ACCUMULATOR &accumulator) { + SubscriptValue xAt[maxRank]; + GetExpandedSubscripts(xAt, x, zeroBasedDim, subscripts); + const auto &dim{x.GetDimension(zeroBasedDim)}; + SubscriptValue at{dim.LowerBound()}; + for (auto n{dim.Extent()}; n-- > 0; ++at) { + xAt[zeroBasedDim] = at; + if (!accumulator.template AccumulateAt(xAt)) { + break; + } + } +#ifdef _MSC_VER // work around MSVC spurious error + accumulator.GetResult(result, zeroBasedDim); +#else + accumulator.template GetResult(result, zeroBasedDim); +#endif +} + +template +inline void ReduceDimMaskToScalar(const Descriptor &x, int zeroBasedDim, + SubscriptValue subscripts[], const Descriptor &mask, TYPE *result, + ACCUMULATOR &accumulator) { + SubscriptValue xAt[maxRank], maskAt[maxRank]; + GetExpandedSubscripts(xAt, x, zeroBasedDim, subscripts); + GetExpandedSubscripts(maskAt, mask, zeroBasedDim, subscripts); + const auto &xDim{x.GetDimension(zeroBasedDim)}; + SubscriptValue xPos{xDim.LowerBound()}; + const auto &maskDim{mask.GetDimension(zeroBasedDim)}; + SubscriptValue maskPos{maskDim.LowerBound()}; + for (auto n{x.GetDimension(zeroBasedDim).Extent()}; n-- > 0; + ++xPos, ++maskPos) { + maskAt[zeroBasedDim] = maskPos; + if (IsLogicalElementTrue(mask, maskAt)) { + xAt[zeroBasedDim] = xPos; + if (!accumulator.template AccumulateAt(xAt)) { + break; + } + } + } +#ifdef _MSC_VER // work around MSVC spurious error + accumulator.GetResult(result, zeroBasedDim); +#else + accumulator.template GetResult(result, zeroBasedDim); +#endif +} + +// Utility: establishes & allocates the result array for a partial +// reduction (i.e., one with DIM=). +static void CreatePartialReductionResult(Descriptor &result, + const Descriptor &x, int dim, Terminator &terminator, const char *intrinsic, + TypeCode typeCode) { + int xRank{x.rank()}; + if (dim < 1 || dim > xRank) { + terminator.Crash("%s: bad DIM=%d for rank %d", intrinsic, dim, xRank); + } + int zeroBasedDim{dim - 1}; + SubscriptValue resultExtent[maxRank]; + for (int j{0}; j < zeroBasedDim; ++j) { + resultExtent[j] = x.GetDimension(j).Extent(); + } + for (int j{zeroBasedDim + 1}; j < xRank; ++j) { + resultExtent[j - 1] = x.GetDimension(j).Extent(); + } + result.Establish(typeCode, x.ElementBytes(), nullptr, xRank - 1, resultExtent, + CFI_attribute_allocatable); + for (int j{0}; j + 1 < xRank; ++j) { + result.GetDimension(j).SetBounds(1, resultExtent[j]); + } + if (int stat{result.Allocate()}) { + terminator.Crash( + "%s: could not allocate memory for result; STAT=%d", intrinsic, stat); + } +} + +// Partial reductions with DIM= + +template +inline void PartialReduction(Descriptor &result, const Descriptor &x, int dim, + const Descriptor *mask, Terminator &terminator, const char *intrinsic, + ACCUMULATOR &accumulator) { + CreatePartialReductionResult( + result, x, dim, terminator, intrinsic, TypeCode{CAT, KIND}); + SubscriptValue at[maxRank]; + result.GetLowerBounds(at); + INTERNAL_CHECK(at[0] == 1); + using CppType = CppTypeFor; + if (mask) { + CheckConformability(x, *mask, terminator, intrinsic, "ARRAY", "MASK"); + SubscriptValue maskAt[maxRank]; // contents unused + if (mask->rank() > 0) { + for (auto n{result.Elements()}; n-- > 0; result.IncrementSubscripts(at)) { + accumulator.Reinitialize(); + ReduceDimMaskToScalar( + x, dim - 1, at, *mask, result.Element(at), accumulator); + } + return; + } else if (!IsLogicalElementTrue(*mask, maskAt)) { + // scalar MASK=.FALSE. + accumulator.Reinitialize(); + for (auto n{result.Elements()}; n-- > 0; result.IncrementSubscripts(at)) { + accumulator.GetResult(result.Element(at)); + } + return; + } + } + // No MASK= or scalar MASK=.TRUE. + for (auto n{result.Elements()}; n-- > 0; result.IncrementSubscripts(at)) { + accumulator.Reinitialize(); + ReduceDimToScalar( + x, dim - 1, at, result.Element(at), accumulator); + } +} + +template