Index: flang/runtime/CMakeLists.txt =================================================================== --- flang/runtime/CMakeLists.txt +++ flang/runtime/CMakeLists.txt @@ -62,6 +62,7 @@ numeric.cpp random.cpp reduction.cpp + pointer.cpp product.cpp stat.cpp stop.cpp Index: flang/runtime/allocatable.h =================================================================== --- flang/runtime/allocatable.h +++ flang/runtime/allocatable.h @@ -10,14 +10,12 @@ // to manipulate and query allocatable variables, dummy arguments, & components. #ifndef FORTRAN_RUNTIME_ALLOCATABLE_H_ #define FORTRAN_RUNTIME_ALLOCATABLE_H_ + #include "descriptor.h" #include "entry-names.h" -namespace Fortran::runtime::typeInfo { -class DerivedType; -} - namespace Fortran::runtime { + extern "C" { // Initializes the descriptor for an allocatable of intrinsic or derived type. @@ -55,7 +53,7 @@ void RTNAME(AllocatableSetBounds)( Descriptor &, int zeroBasedDim, SubscriptValue lower, SubscriptValue upper); -// The upper bound is ignored for the last codimension. +// The upper cobound is ignored for the last codimension. void RTNAME(AllocatableSetCoBounds)(Descriptor &, int zeroBasedCoDim, SubscriptValue lower, SubscriptValue upper = 0); Index: flang/runtime/allocatable.cpp =================================================================== --- flang/runtime/allocatable.cpp +++ flang/runtime/allocatable.cpp @@ -53,6 +53,20 @@ // The byte strides are computed when the object is allocated. } +void RTNAME(AllocatableSetDerivedLength)( + Descriptor &descriptor, int which, SubscriptValue x) { + DescriptorAddendum *addendum{descriptor.Addendum()}; + INTERNAL_CHECK(addendum != nullptr); + addendum->SetLenParameterValue(which, x); +} + +void RTNAME(AllocatableApplyMold)( + Descriptor &descriptor, const Descriptor &mold) { + descriptor = mold; + descriptor.set_base_addr(nullptr); + descriptor.raw().attribute = CFI_attribute_allocatable; +} + int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, const Descriptor *errMsg, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; @@ -63,6 +77,7 @@ return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat); } return ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat); + // TODO: default component initialization } int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, @@ -76,5 +91,7 @@ } return ReturnError(terminator, descriptor.Deallocate(), errMsg, hasStat); } + +// TODO: AllocatableCheckLengthParameter, AllocatableAllocateSource } } // namespace Fortran::runtime Index: flang/runtime/descriptor.h =================================================================== --- flang/runtime/descriptor.h +++ flang/runtime/descriptor.h @@ -83,16 +83,8 @@ // array is determined by derivedType_->LenParameters(). class DescriptorAddendum { public: - enum Flags { - StaticDescriptor = 0x001, - ImplicitAllocatable = 0x002, // compiler-created allocatable - DoNotFinalize = 0x004, // compiler temporary - Target = 0x008, // TARGET attribute - }; - - explicit DescriptorAddendum( - const typeInfo::DerivedType *dt = nullptr, std::uint64_t flags = 0) - : derivedType_{dt}, flags_{flags} {} + explicit DescriptorAddendum(const typeInfo::DerivedType *dt = nullptr) + : derivedType_{dt} {} DescriptorAddendum &operator=(const DescriptorAddendum &); const typeInfo::DerivedType *derivedType() const { return derivedType_; } @@ -100,8 +92,6 @@ derivedType_ = dt; return *this; } - std::uint64_t &flags() { return flags_; } - const std::uint64_t &flags() const { return flags_; } std::size_t LenParameters() const; @@ -123,7 +113,6 @@ private: const typeInfo::DerivedType *derivedType_; - std::uint64_t flags_{0}; typeInfo::TypeParameterValue len_[1]; // must be the last component // The LEN type parameter values can also include captured values of // specification expressions that were used for bounds and for LEN type @@ -145,12 +134,6 @@ // Create() static member functions otherwise to dynamically allocate a // descriptor. - Descriptor() { - // Minimal initialization to prevent the destructor from running amuck - // later if the descriptor is never established. - raw_.base_addr = nullptr; - raw_.f18Addendum = false; - } Descriptor(const Descriptor &); ~Descriptor(); Descriptor &operator=(const Descriptor &); @@ -359,8 +342,6 @@ static constexpr std::size_t byteSize{ Descriptor::SizeInBytes(maxRank, hasAddendum, maxLengthTypeParameters)}; - StaticDescriptor() { new (storage_) Descriptor{}; } - ~StaticDescriptor() { descriptor().~Descriptor(); } Descriptor &descriptor() { return *reinterpret_cast(storage_); } @@ -382,7 +363,7 @@ } private: - char storage_[byteSize]; + char storage_[byteSize]{}; }; } // namespace Fortran::runtime #endif // FORTRAN_RUNTIME_DESCRIPTOR_H_ Index: flang/runtime/descriptor.cpp =================================================================== --- flang/runtime/descriptor.cpp +++ flang/runtime/descriptor.cpp @@ -160,9 +160,6 @@ void Descriptor::Destroy(bool finalize) const { if (const DescriptorAddendum * addendum{Addendum()}) { if (const typeInfo::DerivedType * dt{addendum->derivedType()}) { - if (addendum->flags() & DescriptorAddendum::DoNotFinalize) { - finalize = false; - } runtime::Destroy(*this, finalize, *dt); } } @@ -278,7 +275,6 @@ DescriptorAddendum &DescriptorAddendum::operator=( const DescriptorAddendum &that) { derivedType_ = that.derivedType_; - flags_ = that.flags_; auto lenParms{that.LenParameters()}; for (std::size_t j{0}; j < lenParms; ++j) { len_[j] = that.len_[j]; @@ -297,8 +293,10 @@ void DescriptorAddendum::Dump(FILE *f) const { std::fprintf( - f, " derivedType @ %p\n", reinterpret_cast(derivedType_)); - std::fprintf(f, " flags 0x%jx\n", static_cast(flags_)); - // TODO: LEN parameter values + 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])); + } } } // namespace Fortran::runtime Index: flang/runtime/misc-intrinsic.cpp =================================================================== --- flang/runtime/misc-intrinsic.cpp +++ flang/runtime/misc-intrinsic.cpp @@ -41,9 +41,6 @@ } if (const DescriptorAddendum * addendum{mold.Addendum()}) { *result.Addendum() = *addendum; - auto &flags{result.Addendum()->flags()}; - flags &= ~DescriptorAddendum::StaticDescriptor; - flags |= DescriptorAddendum::DoNotFinalize; } if (int stat{result.Allocate()}) { Terminator{sourceFile, line}.Crash( Index: flang/runtime/pointer.h =================================================================== --- /dev/null +++ flang/runtime/pointer.h @@ -0,0 +1,112 @@ +//===-- runtime/pointer.h ---------------------------------------*- 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 +// +//===----------------------------------------------------------------------===// + +// Defines APIs for Fortran runtime library support of code generated +// to manipulate and query data pointers. + +#ifndef FORTRAN_RUNTIME_POINTER_H_ +#define FORTRAN_RUNTIME_POINTER_H_ + +#include "descriptor.h" +#include "entry-names.h" + +namespace Fortran::runtime { +extern "C" { + +// Data pointer initialization for NULLIFY(), "p=>NULL()`, & for ALLOCATE(). + +// Initializes a pointer to a disassociated state for NULLIFY() or "p=>NULL()". +void RTNAME(PointerNullifyIntrinsic)( + Descriptor &, TypeCategory, int kind, int rank = 0, int corank = 0); +void RTNAME(PointerNullifyCharacter)(Descriptor &, SubscriptValue length = 0, + int kind = 1, int rank = 0, int corank = 0); +void RTNAME(PointerNullifyDerived)( + Descriptor &, const typeInfo::DerivedType &, int rank = 0, int corank = 0); + +// Explicitly sets the bounds of an initialized disassociated pointer. +// The upper cobound is ignored for the last codimension. +void RTNAME(PointerSetBounds)( + Descriptor &, int zeroBasedDim, SubscriptValue lower, SubscriptValue upper); +void RTNAME(PointerSetCoBounds)(Descriptor &, int zeroBasedCoDim, + SubscriptValue lower, SubscriptValue upper = 0); + +// Length type parameters are indexed in declaration order; i.e., 0 is the +// first length type parameter in the deepest base type. (Not for use +// with CHARACTER; see above.) +void RTNAME(PointerSetDerivedLength)(Descriptor &, int which, SubscriptValue); + +// For MOLD= allocation: acquires information from another descriptor +// to initialize a null data pointer. +void RTNAME(PointerApplyMold)(Descriptor &, const Descriptor &mold); + +// Data pointer association for "p=>TARGET" + +// Associates a scalar pointer with a simple scalar target. +void RTNAME(PointerAssociateScalar)(Descriptor &, void *); + +// Associates a pointer with a target of the same rank, possibly with new lower +// bounds, which are passed in a vector whose length must equal the rank. +void RTNAME(PointerAssociate)(Descriptor &, const Descriptor &target); +void RTNAME(PointerAssociateLowerBounds)( + Descriptor &, const Descriptor &target, const Descriptor &lowerBounds); + +// Associates a pointer with a target with bounds remapping. The target must be +// simply contiguous &/or of rank 1. The bounds constitute a [2,newRank] +// integer array whose columns are [lower bound, upper bound] on each dimension. +void RTNAME(PointerAssociateRemapping)(Descriptor &, const Descriptor &target, + const Descriptor &bounds, const char *sourceFile = nullptr, + int sourceLine = 0); + +// Data pointer allocation and deallocation + +// When an explicit type-spec appears in an ALLOCATE statement for an +// pointer with an explicit (non-deferred) length type paramater for +// a derived type or CHARACTER value, the explicit value has to match +// the length type parameter's value. This API checks that requirement. +// Returns 0 for success, or the STAT= value on failure with hasStat==true. +int RTNAME(PointerCheckLengthParameter)(Descriptor &, + int which /* 0 for CHARACTER length */, SubscriptValue other, + bool hasStat = false, const Descriptor *errMsg = nullptr, + const char *sourceFile = nullptr, int sourceLine = 0); + +// Allocates a data pointer. Its descriptor must have been initialized +// and its bounds and length type parameters set. It need not be disassociated. +// On failure, if hasStat is true, returns a nonzero error code for +// STAT= and (if present) fills in errMsg; if hasStat is false, the +// image is terminated. On success, leaves errMsg alone and returns zero. +// Successfully allocated memory is initialized if the pointer has a +// derived type, and is always initialized by PointerAllocateSource(). +// Performs all necessary coarray synchronization and validation actions. +int RTNAME(PointerAllocate)(Descriptor &, bool hasStat = false, + const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, + int sourceLine = 0); +int RTNAME(PointerAllocateSource)(Descriptor &, const Descriptor &source, + bool hasStat = false, const Descriptor *errMsg = nullptr, + const char *sourceFile = nullptr, int sourceLine = 0); + +// Deallocates a data pointer, which must have been allocated by +// PointerAllocate(), possibly copied with PointerAssociate(). +// Finalizes elements &/or components as needed. The pointer is left +// in an initialized disassociated state suitable for reallocation +// with the same bounds, cobounds, and length type parameters. +int RTNAME(PointerDeallocate)(Descriptor &, bool hasStat = false, + const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr, + int sourceLine = 0); + +// Association inquiries for ASSOCIATED() + +// True when the pointer is not disassociated. +bool RTNAME(PointerIsAssociated)(const Descriptor &); + +// True when the pointer is associated with a specific target. +bool RTNAME(PointerIsAssociatedWith)( + const Descriptor &, const Descriptor &target); + +} // extern "C" +} // namespace Fortran::runtime +#endif // FORTRAN_RUNTIME_POINTER_H_ Index: flang/runtime/pointer.cpp =================================================================== --- /dev/null +++ flang/runtime/pointer.cpp @@ -0,0 +1,160 @@ +//===-- runtime/pointer.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 +// +//===----------------------------------------------------------------------===// + +#include "pointer.h" +#include "stat.h" +#include "terminator.h" +#include "tools.h" + +namespace Fortran::runtime { +extern "C" { + +void RTNAME(PointerNullifyIntrinsic)(Descriptor &pointer, TypeCategory category, + int kind, int rank, int corank) { + INTERNAL_CHECK(corank == 0); + pointer.Establish(TypeCode{category, kind}, + Descriptor::BytesFor(category, kind), nullptr, rank, nullptr, + CFI_attribute_pointer); +} + +void RTNAME(PointerNullifyCharacter)(Descriptor &pointer, SubscriptValue length, + int kind, int rank, int corank) { + INTERNAL_CHECK(corank == 0); + pointer.Establish( + kind, length, nullptr, rank, nullptr, CFI_attribute_pointer); +} + +void RTNAME(PointerNullifyDerived)(Descriptor &pointer, + const typeInfo::DerivedType &derivedType, int rank, int corank) { + INTERNAL_CHECK(corank == 0); + pointer.Establish(derivedType, nullptr, rank, nullptr, CFI_attribute_pointer); +} + +void RTNAME(PointerSetBounds)(Descriptor &pointer, int zeroBasedDim, + SubscriptValue lower, SubscriptValue upper) { + INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < pointer.rank()); + pointer.GetDimension(zeroBasedDim).SetBounds(lower, upper); + // The byte strides are computed when the pointer is allocated. +} + +// TODO: PointerSetCoBounds + +void RTNAME(PointerSetDerivedLength)( + Descriptor &pointer, int which, SubscriptValue x) { + DescriptorAddendum *addendum{pointer.Addendum()}; + INTERNAL_CHECK(addendum != nullptr); + addendum->SetLenParameterValue(which, x); +} + +void RTNAME(PointerApplyMold)(Descriptor &pointer, const Descriptor &mold) { + pointer = mold; + pointer.set_base_addr(nullptr); + pointer.raw().attribute = CFI_attribute_pointer; +} + +void RTNAME(PointerAssociateScalar)(Descriptor &pointer, void *target) { + pointer.set_base_addr(target); +} + +void RTNAME(PointerAssociate)(Descriptor &pointer, const Descriptor &target) { + pointer = target; + pointer.raw().attribute = CFI_attribute_pointer; +} + +void RTNAME(PointerAssociateLowerBounds)(Descriptor &pointer, + const Descriptor &target, const Descriptor &lowerBounds) { + pointer = target; + pointer.raw().attribute = CFI_attribute_pointer; + int rank{pointer.rank()}; + Terminator terminator{__FILE__, __LINE__}; + std::size_t boundElementBytes{lowerBounds.ElementBytes()}; + for (int j{0}; j < rank; ++j) { + pointer.GetDimension(j).SetLowerBound( + GetInt64(lowerBounds.ZeroBasedIndexedElement(j), + boundElementBytes, terminator)); + } +} + +void RTNAME(PointerAssociateRemapping)(Descriptor &pointer, + const Descriptor &target, const Descriptor &bounds, const char *sourceFile, + int sourceLine) { + pointer = target; + pointer.raw().attribute = CFI_attribute_pointer; + int rank{pointer.rank()}; + Terminator terminator{sourceFile, sourceLine}; + SubscriptValue byteStride{/*captured from first dimension*/}; + std::size_t boundElementBytes{bounds.ElementBytes()}; + for (int j{0}; j < rank; ++j) { + auto &dim{pointer.GetDimension(j)}; + dim.SetBounds(GetInt64(bounds.ZeroBasedIndexedElement(2 * j), + boundElementBytes, terminator), + GetInt64(bounds.ZeroBasedIndexedElement(2 * j + 1), + boundElementBytes, terminator)); + if (j == 0) { + byteStride = dim.ByteStride(); + } else { + dim.SetByteStride(byteStride); + byteStride *= dim.Extent(); + } + } + if (pointer.Elements() > target.Elements()) { + terminator.Crash("PointerAssociateRemapping: too many elements in remapped " + "pointer (%zd > %zd)", + pointer.Elements(), target.Elements()); + } +} + +int RTNAME(PointerAllocate)(Descriptor &pointer, bool hasStat, + const Descriptor *errMsg, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + if (!pointer.IsPointer()) { + return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); + } + return ReturnError(terminator, pointer.Allocate(), errMsg, hasStat); + // TODO: default component initialization +} + +int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat, + const Descriptor *errMsg, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + if (!pointer.IsPointer()) { + return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); + } + if (!pointer.IsAllocated()) { + return ReturnError(terminator, StatBaseNull, errMsg, hasStat); + } + return ReturnError(terminator, pointer.Deallocate(), errMsg, hasStat); +} + +bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) { + return pointer.raw().base_addr != nullptr; +} + +bool RTNAME(PointerIsAssociatedWith)( + const Descriptor &pointer, const Descriptor &target) { + int rank{pointer.rank()}; + if (pointer.raw().base_addr != target.raw().base_addr || + pointer.ElementBytes() != target.ElementBytes() || + rank != target.rank()) { + return false; + } + for (int j{0}; j < rank; ++j) { + const Dimension &pDim{pointer.GetDimension(j)}; + const Dimension &tDim{target.GetDimension(j)}; + if (pDim.Extent() != tDim.Extent() || + pDim.ByteStride() != tDim.ByteStride()) { + return false; + } + } + return true; +} + +// TODO: PointerCheckLengthParameter, PointerAllocateSource + +} // extern "C" +} // namespace Fortran::runtime Index: flang/test/Semantics/offsets01.f90 =================================================================== --- flang/test/Semantics/offsets01.f90 +++ flang/test/Semantics/offsets01.f90 @@ -47,8 +47,8 @@ integer, len :: l2 real :: b(l1, l2) end type - type(t1(n)) :: x1 !CHECK: x1 size=48 offset= - type(t2(n,n)) :: x2 !CHECK: x2 size=56 offset= + type(t1(n)) :: x1 !CHECK: x1 size=40 offset= + type(t2(n,n)) :: x2 !CHECK: x2 size=48 offset= !CHECK: a size=48 offset=0: !CHECK: b size=72 offset=0: end