diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt --- a/flang/runtime/CMakeLists.txt +++ b/flang/runtime/CMakeLists.txt @@ -50,6 +50,7 @@ io-stmt.cpp main.cpp memory.cpp + stat.cpp stop.cpp terminator.cpp tools.cpp diff --git a/flang/runtime/ISO_Fortran_binding.cpp b/flang/runtime/ISO_Fortran_binding.cpp --- a/flang/runtime/ISO_Fortran_binding.cpp +++ b/flang/runtime/ISO_Fortran_binding.cpp @@ -78,7 +78,7 @@ byteSize *= extent; } void *p{std::malloc(byteSize)}; - if (!p) { + if (!p && byteSize) { return CFI_ERROR_MEM_ALLOCATION; } descriptor->base_addr = p; diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -7,39 +7,74 @@ //===----------------------------------------------------------------------===// #include "allocatable.h" +#include "stat.h" #include "terminator.h" namespace Fortran::runtime { extern "C" { -void RTNAME(AllocatableInitIntrinsic)( - Descriptor &, TypeCategory, int /*kind*/, int /*rank*/, int /*corank*/) { - // TODO +void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor, + TypeCategory category, int kind, int rank, int corank) { + INTERNAL_CHECK(corank == 0); + descriptor.Establish(TypeCode{category, kind}, + Descriptor::BytesFor(category, kind), nullptr, rank, nullptr, + CFI_attribute_allocatable); } -void RTNAME(AllocatableInitCharacter)(Descriptor &, SubscriptValue /*length*/, - int /*kind*/, int /*rank*/, int /*corank*/) { - // TODO +void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor, + SubscriptValue length, int kind, int rank, int corank) { + INTERNAL_CHECK(corank == 0); + descriptor.Establish( + kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable); } -void RTNAME(AllocatableInitDerived)( - Descriptor &, const DerivedType &, int /*rank*/, int /*corank*/) { - // TODO +void RTNAME(AllocatableInitDerived)(Descriptor &descriptor, + const DerivedType &derivedType, int rank, int corank) { + INTERNAL_CHECK(corank == 0); + descriptor.Establish( + derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable); } -void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {} +void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) { + INTERNAL_CHECK(!"AllocatableAssign is not yet implemented"); +} int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/, bool /*hasStat*/, Descriptor * /*errMsg*/, const char * /*sourceFile*/, int /*sourceLine*/) { - // TODO - return 0; + INTERNAL_CHECK(!"MoveAlloc is not yet implemented"); + return StatOk; +} + +void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim, + SubscriptValue lower, SubscriptValue upper) { + INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank()); + descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper); + // The byte strides are computed when the object is allocated. +} + +int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, + Descriptor *errMsg, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + if (!descriptor.IsAllocatable()) { + return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); + } + if (descriptor.IsAllocated()) { + return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat); + } + return ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat); } -int RTNAME(AllocatableDeallocate)(Descriptor &, bool /*hasStat*/, - Descriptor * /*errMsg*/, const char * /*sourceFile*/, int /*sourceLine*/) { - // TODO - return 0; +int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, + Descriptor *errMsg, const char *sourceFile, int sourceLine) { + Terminator terminator{sourceFile, sourceLine}; + if (!descriptor.IsAllocatable()) { + return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); + } + if (!descriptor.IsAllocated()) { + return ReturnError(terminator, StatBaseNull, errMsg, hasStat); + } + return ReturnError(terminator, descriptor.Deallocate(), errMsg, hasStat); } } } // namespace Fortran::runtime diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h --- a/flang/runtime/descriptor.h +++ b/flang/runtime/descriptor.h @@ -44,6 +44,16 @@ SubscriptValue UpperBound() const { return LowerBound() + Extent() - 1; } SubscriptValue ByteStride() const { return raw_.sm; } + Dimension &SetBounds(SubscriptValue lower, SubscriptValue upper) { + raw_.lower_bound = lower; + raw_.extent = upper >= lower ? upper - lower + 1 : 0; + return *this; + } + Dimension &SetByteStride(SubscriptValue bytes) { + raw_.sm = bytes; + return *this; + } + private: ISO::CFI_dim_t raw_; }; @@ -271,6 +281,7 @@ std::size_t Elements() const; // TODO: SOURCE= and MOLD= + int Allocate(); int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]); int Deallocate(bool finalize = true); void Destroy(char *data, bool finalize = true) const; diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp --- a/flang/runtime/descriptor.cpp +++ b/flang/runtime/descriptor.cpp @@ -109,6 +109,26 @@ return elements; } +int Descriptor::Allocate() { + std::size_t byteSize{Elements() * ElementBytes()}; + void *p{std::malloc(byteSize)}; + if (!p && byteSize) { + return CFI_ERROR_MEM_ALLOCATION; + } + // TODO: image synchronization + // TODO: derived type initialization + raw_.base_addr = p; + 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(); + } + } + return 0; +} + int Descriptor::Allocate(const SubscriptValue lb[], const SubscriptValue ub[]) { int result{ISO::CFI_allocate(&raw_, lb, ub, ElementBytes())}; if (result == CFI_SUCCESS) { diff --git a/flang/runtime/magic-numbers.h b/flang/runtime/magic-numbers.h --- a/flang/runtime/magic-numbers.h +++ b/flang/runtime/magic-numbers.h @@ -19,6 +19,10 @@ 16.10.2, and 16.10.2.33) Codes from , e.g. ENOENT, are assumed to be positive and are used "raw" as IOSTAT values. + +CFI_ERROR_xxx and CFI_INVALID_xxx macros from ISO_Fortran_binding.h +have small positive values. The FORTRAN_RUNTIME_STAT_xxx macros here +start at 100 so as to never conflict with those codes. #endif #ifndef FORTRAN_RUNTIME_MAGIC_NUMBERS_H_ #define FORTRAN_RUNTIME_MAGIC_NUMBERS_H_ @@ -28,10 +32,10 @@ #define FORTRAN_RUNTIME_IOSTAT_FLUSH (-3) #define FORTRAN_RUNTIME_IOSTAT_INQUIRE_INTERNAL_UNIT 256 -#define FORTRAN_RUNTIME_STAT_FAILED_IMAGE 10 -#define FORTRAN_RUNTIME_STAT_LOCKED 11 -#define FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE 12 -#define FORTRAN_RUNTIME_STAT_STOPPED_IMAGE 13 -#define FORTRAN_RUNTIME_STAT_UNLOCKED 14 -#define FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE 15 +#define FORTRAN_RUNTIME_STAT_FAILED_IMAGE 101 +#define FORTRAN_RUNTIME_STAT_LOCKED 102 +#define FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE 103 +#define FORTRAN_RUNTIME_STAT_STOPPED_IMAGE 104 +#define FORTRAN_RUNTIME_STAT_UNLOCKED 105 +#define FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE 106 #endif diff --git a/flang/runtime/stat.h b/flang/runtime/stat.h new file mode 100644 --- /dev/null +++ b/flang/runtime/stat.h @@ -0,0 +1,54 @@ +//===-- runtime/stat.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 the values returned by the runtime for STAT= specifiers +// on executable statements. + +#ifndef FORTRAN_RUNTIME_STAT_H_ +#define FORTRAN_RUNTIME_STAT_H_ +#include "magic-numbers.h" +#include "flang/ISO_Fortran_binding.h" +namespace Fortran::runtime { + +class Descriptor; +class Terminator; + +// The value of STAT= is zero when no error condition has arisen. + +enum Stat { + StatOk = 0, // required to be zero by Fortran + + // Interoperable STAT= codes + StatBaseNull = CFI_ERROR_BASE_ADDR_NULL, + StatBaseNotNull = CFI_ERROR_BASE_ADDR_NOT_NULL, + StatInvalidElemLen = CFI_INVALID_ELEM_LEN, + StatInvalidRank = CFI_INVALID_RANK, + StatInvalidType = CFI_INVALID_TYPE, + StatInvalidAttribute = CFI_INVALID_ATTRIBUTE, + StatInvalidExtent = CFI_INVALID_EXTENT, + StatInvalidDescriptor = CFI_INVALID_DESCRIPTOR, + StatMemAllocation = CFI_ERROR_MEM_ALLOCATION, + StatOutOfBounds = CFI_ERROR_OUT_OF_BOUNDS, + + // Standard STAT= values + StatFailedImage = FORTRAN_RUNTIME_STAT_FAILED_IMAGE, + StatLocked = FORTRAN_RUNTIME_STAT_LOCKED, + StatLockedOtherImage = FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE, + StatStoppedImage = FORTRAN_RUNTIME_STAT_STOPPED_IMAGE, + StatUnlocked = FORTRAN_RUNTIME_STAT_UNLOCKED, + StatUnlockedFailedImage = FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE, + + // Additional "processor-defined" STAT= values +}; + +const char *StatErrorString(int); +int ToErrmsg(Descriptor *errmsg, int stat); // returns stat +int ReturnError( + Terminator &, int stat, Descriptor *errmsg = nullptr, bool hasStat = false); +} // namespace Fortran::runtime +#endif // FORTRAN_RUNTIME_STAT_H diff --git a/flang/runtime/stat.cpp b/flang/runtime/stat.cpp new file mode 100644 --- /dev/null +++ b/flang/runtime/stat.cpp @@ -0,0 +1,88 @@ +//===-- runtime/stat.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 "stat.h" +#include "descriptor.h" +#include "terminator.h" + +namespace Fortran::runtime { +const char *StatErrorString(int stat) { + switch (stat) { + case StatOk: + return "No error"; + + case StatBaseNull: + return "Base address is null"; + case StatBaseNotNull: + return "Base address is not null"; + case StatInvalidElemLen: + return "Invalid element length"; + case StatInvalidRank: + return "Invalid rank"; + case StatInvalidType: + return "Invalid type"; + case StatInvalidAttribute: + return "Invalid attribute"; + case StatInvalidExtent: + return "Invalid extent"; + case StatInvalidDescriptor: + return "Invalid descriptor"; + case StatMemAllocation: + return "Memory allocation failed"; + case StatOutOfBounds: + return "Out of bounds"; + + case StatFailedImage: + return "Failed image"; + case StatLocked: + return "Locked"; + case StatLockedOtherImage: + return "Other image locked"; + case StatStoppedImage: + return "Image stopped"; + case StatUnlocked: + return "Unlocked"; + case StatUnlockedFailedImage: + return "Failed image unlocked"; + + default: + return nullptr; + } +} + +int ToErrmsg(Descriptor *errmsg, int stat) { + if (stat != StatOk && errmsg && errmsg->raw().base_addr && + errmsg->type() == TypeCode(TypeCategory::Character, 1) && + errmsg->rank() == 0) { + if (const char *msg{StatErrorString(stat)}) { + char *buffer{errmsg->OffsetElement()}; + std::size_t bufferLength{errmsg->ElementBytes()}; + std::size_t msgLength{std::strlen(msg)}; + if (msgLength <= bufferLength) { + std::memcpy(buffer, msg, bufferLength); + } else { + std::memcpy(buffer, msg, msgLength); + std::memset(buffer + msgLength, ' ', bufferLength - msgLength); + } + } + } + return stat; +} + +int ReturnError( + Terminator &terminator, int stat, Descriptor *errmsg, bool hasStat) { + if (stat == StatOk || hasStat) { + return ToErrmsg(errmsg, stat); + } else if (const char *msg{StatErrorString(stat)}) { + terminator.Crash(msg); + } else { + terminator.Crash("Invalid Fortran runtime STAT= code %d", stat); + } + return stat; +} +} // namespace Fortran::runtime diff --git a/flang/runtime/terminator.h b/flang/runtime/terminator.h --- a/flang/runtime/terminator.h +++ b/flang/runtime/terminator.h @@ -32,6 +32,7 @@ [[noreturn]] void CrashArgs(const char *message, va_list &) const; [[noreturn]] void CheckFailed( const char *predicate, const char *file, int line) const; + [[noreturn]] void CheckFailed(const char *predicate) const; // For test harnessing - overrides CrashArgs(). static void RegisterCrashHandler(void (*)(const char *sourceFile, @@ -49,6 +50,12 @@ else \ (terminator).CheckFailed(#pred, __FILE__, __LINE__) +#define INTERNAL_CHECK(pred) \ + if (pred) \ + ; \ + else \ + Terminator{__FILE__, __LINE__}.CheckFailed(#pred) + void NotifyOtherImagesOfNormalEnd(); void NotifyOtherImagesOfFailImageStatement(); void NotifyOtherImagesOfErrorTermination(); diff --git a/flang/runtime/terminator.cpp b/flang/runtime/terminator.cpp --- a/flang/runtime/terminator.cpp +++ b/flang/runtime/terminator.cpp @@ -54,6 +54,11 @@ line); } +[[noreturn]] void Terminator::CheckFailed(const char *predicate) const { + Crash("Internal error: RUNTIME_CHECK(%s) failed at %s(%d)", predicate, + sourceFileName_, sourceLine_); +} + // TODO: These will be defined in the coarray runtime library void NotifyOtherImagesOfNormalEnd() {} void NotifyOtherImagesOfFailImageStatement() {} diff --git a/flang/runtime/type-code.h b/flang/runtime/type-code.h --- a/flang/runtime/type-code.h +++ b/flang/runtime/type-code.h @@ -52,6 +52,9 @@ std::optional> GetCategoryAndKind() const; + bool operator==(const TypeCode &that) const { return raw_ == that.raw_; } + bool operator!=(const TypeCode &that) const { return raw_ != that.raw_; } + private: ISO::CFI_type_t raw_{CFI_type_other}; };