//===-- lib/runtime/descriptor.cpp ------------------------------*- C++ -*-===// // // 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 // //===----------------------------------------------------------------------===// #include "flang-rt/runtime/descriptor.h" #include "ISO_Fortran_util.h" #include "memory.h" #include "flang-rt/runtime/allocator-registry.h" #include "flang-rt/runtime/derived.h" #include "flang-rt/runtime/stat.h" #include "flang-rt/runtime/terminator.h" #include "flang-rt/runtime/type-info.h" #include "flang/Common/type-kinds.h" #include "flang/Runtime/freestanding-tools.h" #include #include #include namespace Fortran::runtime { RT_OFFLOAD_API_GROUP_BEGIN RT_API_ATTRS Descriptor::Descriptor(const Descriptor &that) { *this = that; } RT_API_ATTRS Descriptor &Descriptor::operator=(const Descriptor &that) { runtime::memcpy(reinterpret_cast(this), &that, that.SizeInBytes()); return *this; } RT_API_ATTRS void Descriptor::Establish(TypeCode t, std::size_t elementBytes, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute, bool addendum, int allocatorIdx) { Terminator terminator{__FILE__, __LINE__}; int cfiStatus{ISO::VerifyEstablishParameters(&raw_, p, attribute, t.raw(), elementBytes, rank, extent, /*external=*/false)}; if (cfiStatus != CFI_SUCCESS) { terminator.Crash( "Descriptor::Establish: CFI_establish returned %d for CFI_type_t(%d)", cfiStatus, t.raw()); } ISO::EstablishDescriptor( &raw_, p, attribute, t.raw(), elementBytes, rank, extent); if (elementBytes == 0) { raw_.elem_len = 0; // Reset byte strides of the dimensions, since EstablishDescriptor() // only does that when the base address is not nullptr. for (int j{0}; j < rank; ++j) { GetDimension(j).SetByteStride(0); } } if (addendum) { SetHasAddendum(); } DescriptorAddendum *a{Addendum()}; RUNTIME_CHECK(terminator, addendum == (a != nullptr)); if (a) { new (a) DescriptorAddendum{}; } SetAllocIdx(allocatorIdx); } RT_API_ATTRS std::size_t Descriptor::BytesFor(TypeCategory category, int kind) { Terminator terminator{__FILE__, __LINE__}; int bytes{common::TypeSizeInBytes(category, kind)}; RUNTIME_CHECK(terminator, bytes > 0); return bytes; } RT_API_ATTRS void Descriptor::Establish(TypeCategory c, int kind, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute, bool addendum, int allocatorIdx) { Establish(TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute, addendum, allocatorIdx); } RT_API_ATTRS void Descriptor::Establish(int characterKind, std::size_t characters, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute, bool addendum, int allocatorIdx) { Establish(TypeCode{TypeCategory::Character, characterKind}, characterKind * characters, p, rank, extent, attribute, addendum, allocatorIdx); } RT_API_ATTRS void Descriptor::Establish(const typeInfo::DerivedType &dt, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute, int allocatorIdx) { auto elementBytes{static_cast(dt.sizeInBytes())}; ISO::EstablishDescriptor( &raw_, p, attribute, CFI_type_struct, elementBytes, rank, extent); if (elementBytes == 0) { raw_.elem_len = 0; // Reset byte strides of the dimensions, since EstablishDescriptor() // only does that when the base address is not nullptr. for (int j{0}; j < rank; ++j) { GetDimension(j).SetByteStride(0); } } SetHasAddendum(); new (Addendum()) DescriptorAddendum{&dt}; SetAllocIdx(allocatorIdx); } RT_API_ATTRS void Descriptor::UncheckedScalarEstablish( const typeInfo::DerivedType &dt, void *p) { auto elementBytes{static_cast(dt.sizeInBytes())}; ISO::EstablishDescriptor( &raw_, p, CFI_attribute_other, CFI_type_struct, elementBytes, 0, nullptr); SetHasAddendum(); new (Addendum()) DescriptorAddendum{&dt}; } RT_API_ATTRS OwningPtr Descriptor::Create(TypeCode t, std::size_t elementBytes, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute, bool addendum, const typeInfo::DerivedType *dt) { Terminator terminator{__FILE__, __LINE__}; RUNTIME_CHECK(terminator, t.IsDerived() == (dt != nullptr)); int derivedTypeLenParameters = dt ? dt->LenParameters() : 0; std::size_t bytes{SizeInBytes(rank, addendum, derivedTypeLenParameters)}; Descriptor *result{ reinterpret_cast(AllocateMemoryOrCrash(terminator, bytes))}; if (dt) { result->Establish(*dt, p, rank, extent, attribute); } else { result->Establish(t, elementBytes, p, rank, extent, attribute, addendum); } return OwningPtr{result}; } RT_API_ATTRS OwningPtr Descriptor::Create(TypeCategory c, int kind, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) { return Create( TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute); } RT_API_ATTRS OwningPtr Descriptor::Create(int characterKind, SubscriptValue characters, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) { return Create(TypeCode{TypeCategory::Character, characterKind}, characterKind * characters, p, rank, extent, attribute); } RT_API_ATTRS OwningPtr Descriptor::Create( const typeInfo::DerivedType &dt, void *p, int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) { return Create(TypeCode{TypeCategory::Derived, 0}, dt.sizeInBytes(), p, rank, extent, attribute, /*addendum=*/true, &dt); } RT_API_ATTRS std::size_t Descriptor::SizeInBytes() const { const DescriptorAddendum *addendum{Addendum()}; std::size_t bytes{ sizeof *this - sizeof(Dimension) + raw_.rank * sizeof(Dimension) + (addendum ? addendum->SizeInBytes() : 0)}; assert (bytes <= MaxDescriptorSizeInBytes(raw_.rank,addendum) && "Descriptor must fit compiler-allocated space"); return bytes; } RT_API_ATTRS std::size_t Descriptor::Elements() const { return InlineElements(); } RT_API_ATTRS int Descriptor::Allocate(std::int64_t *asyncObject) { std::size_t elementBytes{ElementBytes()}; if (static_cast(elementBytes) < 0) { // F'2023 7.4.4.2 p5: "If the character length parameter value evaluates // to a negative value, the length of character entities declared is zero." elementBytes = raw_.elem_len = 0; } std::size_t byteSize{Elements() * elementBytes}; AllocFct alloc{allocatorRegistry.GetAllocator(MapAllocIdx())}; // Zero size allocation is possible in Fortran and the resulting // descriptor must be allocated/associated. Since std::malloc(0) // result is implementation defined, always allocate at least one byte. void *p{alloc(byteSize ? byteSize : 1, asyncObject)}; if (!p) { return CFI_ERROR_MEM_ALLOCATION; } // TODO: image synchronization raw_.base_addr = p; SetByteStrides(); return 0; } RT_API_ATTRS void Descriptor::SetByteStrides() { if (int dims{rank()}) { std::size_t stride{ElementBytes()}; for (int j{0}; j < dims; ++j) { auto &dimension{GetDimension(j)}; dimension.SetByteStride(stride); stride *= dimension.Extent(); } } } RT_API_ATTRS int Descriptor::Destroy( bool finalize, bool destroyPointers, Terminator *terminator) { if (!destroyPointers && raw_.attribute == CFI_attribute_pointer) { return StatOk; } else { if (auto *addendum{Addendum()}) { if (const auto *derived{addendum->derivedType()}) { if (!derived->noDestructionNeeded()) { runtime::Destroy(*this, finalize, *derived, terminator); } } } return Deallocate(); } } RT_API_ATTRS bool Descriptor::DecrementSubscripts( SubscriptValue *subscript, const int *permutation) const { for (int j{raw_.rank - 1}; j >= 0; --j) { int k{permutation ? permutation[j] : j}; const Dimension &dim{GetDimension(k)}; if (--subscript[k] >= dim.LowerBound()) { return true; } subscript[k] = dim.UpperBound(); } return false; } RT_API_ATTRS std::size_t Descriptor::ZeroBasedElementNumber( const SubscriptValue *subscript, const int *permutation) const { std::size_t result{0}; std::size_t coefficient{1}; for (int j{0}; j < raw_.rank; ++j) { int k{permutation ? permutation[j] : j}; const Dimension &dim{GetDimension(k)}; result += coefficient * (subscript[k] - dim.LowerBound()); coefficient *= dim.Extent(); } return result; } RT_API_ATTRS bool Descriptor::EstablishPointerSection(const Descriptor &source, const SubscriptValue *lower, const SubscriptValue *upper, const SubscriptValue *stride) { *this = source; raw_.attribute = CFI_attribute_pointer; SetAllocIdx(source.GetAllocIdx()); int newRank{raw_.rank}; for (int j{0}; j < raw_.rank; ++j) { if (!stride || stride[j] == 0) { if (newRank > 0) { --newRank; } else { return false; } } } raw_.rank = newRank; if (CFI_section(&raw_, &source.raw_, lower, upper, stride) != CFI_SUCCESS) { return false; } if (const auto *sourceAddendum = source.Addendum()) { if (auto *addendum{Addendum()}) { *addendum = *sourceAddendum; } else { return false; } } return true; } RT_API_ATTRS void Descriptor::ApplyMold( const Descriptor &mold, int rank, bool isMonomorphic) { raw_.rank = rank; for (int j{0}; j < rank && j < mold.raw_.rank; ++j) { GetDimension(j) = mold.GetDimension(j); } if (!isMonomorphic) { raw_.elem_len = mold.raw_.elem_len; raw_.type = mold.raw_.type; if (auto *addendum{Addendum()}) { if (auto *moldAddendum{mold.Addendum()}) { *addendum = *moldAddendum; } else { INTERNAL_CHECK(!addendum->derivedType()); } } } } RT_API_ATTRS void Descriptor::Check() const { // TODO } static const char *GetTypeStr(ISO::CFI_type_t type, bool dumpRawType) { if (dumpRawType) { #define CASE(x) \ case (x): \ return #x; switch (type) { CASE(CFI_type_signed_char) CASE(CFI_type_short) CASE(CFI_type_int) CASE(CFI_type_long) CASE(CFI_type_long_long) CASE(CFI_type_size_t) CASE(CFI_type_int8_t) CASE(CFI_type_int16_t) CASE(CFI_type_int32_t) CASE(CFI_type_int64_t) CASE(CFI_type_int128_t) CASE(CFI_type_int_least8_t) CASE(CFI_type_int_least16_t) CASE(CFI_type_int_least32_t) CASE(CFI_type_int_least64_t) CASE(CFI_type_int_least128_t) CASE(CFI_type_int_fast8_t) CASE(CFI_type_int_fast16_t) CASE(CFI_type_int_fast32_t) CASE(CFI_type_int_fast64_t) CASE(CFI_type_int_fast128_t) CASE(CFI_type_intmax_t) CASE(CFI_type_intptr_t) CASE(CFI_type_ptrdiff_t) CASE(CFI_type_half_float) CASE(CFI_type_bfloat) CASE(CFI_type_float) CASE(CFI_type_double) CASE(CFI_type_extended_double) CASE(CFI_type_long_double) CASE(CFI_type_float128) CASE(CFI_type_half_float_Complex) CASE(CFI_type_bfloat_Complex) CASE(CFI_type_float_Complex) CASE(CFI_type_double_Complex) CASE(CFI_type_extended_double_Complex) CASE(CFI_type_long_double_Complex) CASE(CFI_type_float128_Complex) CASE(CFI_type_Bool) CASE(CFI_type_char) CASE(CFI_type_cptr) CASE(CFI_type_struct) CASE(CFI_type_char16_t) CASE(CFI_type_char32_t) CASE(CFI_type_uint8_t) CASE(CFI_type_uint16_t) CASE(CFI_type_uint32_t) CASE(CFI_type_uint64_t) CASE(CFI_type_uint128_t) default: return nullptr; } #undef CASE } TypeCode code{type}; if (!code.IsValid()) { return "invalid"; } auto categoryAndKind{code.GetCategoryAndKind()}; if (!categoryAndKind) { return nullptr; } TypeCategory tcat{categoryAndKind->first}; int kind{categoryAndKind->second}; #define CASE(cat, k) \ case (k): \ return #cat "(kind=" #k ")"; switch (tcat) { case TypeCategory::Integer: switch (kind) { CASE(INTEGER, 1) CASE(INTEGER, 2) CASE(INTEGER, 4) CASE(INTEGER, 8) CASE(INTEGER, 16) } break; case TypeCategory::Unsigned: switch (kind) { CASE(UNSIGNED, 1) CASE(UNSIGNED, 2) CASE(UNSIGNED, 4) CASE(UNSIGNED, 8) CASE(UNSIGNED, 16) } break; case TypeCategory::Real: switch (kind) { CASE(REAL, 2) CASE(REAL, 3) CASE(REAL, 4) CASE(REAL, 8) CASE(REAL, 10) CASE(REAL, 16) } break; case TypeCategory::Complex: switch (kind) { CASE(COMPLEX, 2) CASE(COMPLEX, 3) CASE(COMPLEX, 4) CASE(COMPLEX, 8) CASE(COMPLEX, 10) CASE(COMPLEX, 16) } break; case TypeCategory::Character: switch (kind) { CASE(CHARACTER, 1) CASE(CHARACTER, 2) CASE(CHARACTER, 4) } break; case TypeCategory::Logical: switch (kind) { CASE(LOGICAL, 1) CASE(LOGICAL, 2) CASE(LOGICAL, 4) CASE(LOGICAL, 8) } break; case TypeCategory::Derived: return "DERIVED"; } #undef CASE return nullptr; } void Descriptor::Dump(FILE *f, bool dumpRawType) const { std::fprintf(f, "Descriptor @ %p:\n", reinterpret_cast(this)); std::fprintf(f, " base_addr %p\n", raw_.base_addr); std::fprintf(f, " elem_len %zd\n", ElementBytes()); std::fprintf(f, " version %d\n", static_cast(raw_.version)); std::fprintf(f, " rank %d%s\n", rank(), rank() ? "" : " (scalar)"); int ty{static_cast(raw_.type)}; if (const char *tyStr{GetTypeStr(raw_.type, dumpRawType)}) { std::fprintf(f, " type %d \"%s\"\n", ty, tyStr); } else { std::fprintf(f, " type %d\n", ty); } int attr{static_cast(raw_.attribute)}; if (IsPointer()) { std::fprintf(f, " attribute %d (pointer) \n", attr); } else if (IsAllocatable()) { std::fprintf(f, " attribute %d (allocatable)\n", attr); } else { std::fprintf(f, " attribute %d\n", attr); } std::fprintf(f, " extra %d\n", static_cast(raw_.extra)); std::fprintf(f, " addendum %d\n", static_cast(HasAddendum())); std::fprintf(f, " alloc_idx %d\n", static_cast(GetAllocIdx())); for (int j{0}; j < raw_.rank; ++j) { std::fprintf(f, " dim[%d] lower_bound %jd\n", j, static_cast(raw_.dim[j].lower_bound)); std::fprintf(f, " extent %jd\n", static_cast(raw_.dim[j].extent)); std::fprintf(f, " sm %jd\n", static_cast(raw_.dim[j].sm)); } if (const DescriptorAddendum * addendum{Addendum()}) { addendum->Dump(f); } } RT_API_ATTRS DescriptorAddendum &DescriptorAddendum::operator=( const DescriptorAddendum &that) { derivedType_ = that.derivedType_; auto lenParms{that.LenParameters()}; for (std::size_t j{0}; j < lenParms; ++j) { len_[j] = that.len_[j]; } return *this; } RT_API_ATTRS std::size_t DescriptorAddendum::SizeInBytes() const { return SizeInBytes(LenParameters()); } RT_API_ATTRS std::size_t DescriptorAddendum::LenParameters() const { const auto *type{derivedType()}; return type ? type->LenParameters() : 0; } void DescriptorAddendum::Dump(FILE *f) const { std::fprintf( f, " derivedType @ %p\n", reinterpret_cast(derivedType())); std::size_t lenParms{LenParameters()}; for (std::size_t j{0}; j < lenParms; ++j) { std::fprintf(f, " len[%zd] %jd\n", j, static_cast(len_[j])); } } RT_OFFLOAD_API_GROUP_END } // namespace Fortran::runtime