[flang-commits] [flang] 8df28f0 - [flang] Implement runtime support for basic ALLOCATE/DEALLOCATE
peter klausler via flang-commits
flang-commits at lists.llvm.org
Thu Nov 12 10:21:49 PST 2020
Author: peter klausler
Date: 2020-11-12T10:21:40-08:00
New Revision: 8df28f0aa3c0aba79a3c134df05808e47b141375
URL: https://github.com/llvm/llvm-project/commit/8df28f0aa3c0aba79a3c134df05808e47b141375
DIFF: https://github.com/llvm/llvm-project/commit/8df28f0aa3c0aba79a3c134df05808e47b141375.diff
LOG: [flang] Implement runtime support for basic ALLOCATE/DEALLOCATE
Add error reporting infrastructure and support for ALLOCATE
and DEALLOCATE statements of intrinsic types without SOURCE=
or MOLD=.
Differential revision: https://reviews.llvm.org/D91215
Added:
flang/runtime/stat.cpp
flang/runtime/stat.h
Modified:
flang/runtime/CMakeLists.txt
flang/runtime/ISO_Fortran_binding.cpp
flang/runtime/allocatable.cpp
flang/runtime/descriptor.cpp
flang/runtime/descriptor.h
flang/runtime/magic-numbers.h
flang/runtime/terminator.cpp
flang/runtime/terminator.h
flang/runtime/type-code.h
Removed:
################################################################################
diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index 5f0a1e20647e..2295082fd4ad 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -50,6 +50,7 @@ add_flang_library(FortranRuntime
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
index 40907e272246..7c2fb65ba88b 100644
--- a/flang/runtime/ISO_Fortran_binding.cpp
+++ b/flang/runtime/ISO_Fortran_binding.cpp
@@ -78,7 +78,7 @@ int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[],
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
index b47a40e5759a..3e33caca33d1 100644
--- 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.cpp b/flang/runtime/descriptor.cpp
index 6edaa515e49d..94d081038c9b 100644
--- a/flang/runtime/descriptor.cpp
+++ b/flang/runtime/descriptor.cpp
@@ -109,6 +109,26 @@ std::size_t Descriptor::Elements() const {
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/descriptor.h b/flang/runtime/descriptor.h
index 983d483788b9..28ac0d30db4a 100644
--- a/flang/runtime/descriptor.h
+++ b/flang/runtime/descriptor.h
@@ -44,6 +44,16 @@ class Dimension {
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 @@ class Descriptor {
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/magic-numbers.h b/flang/runtime/magic-numbers.h
index 55790c5ee60a..388ee8a281a5 100644
--- a/flang/runtime/magic-numbers.h
+++ b/flang/runtime/magic-numbers.h
@@ -19,6 +19,10 @@ These include:
16.10.2, and 16.10.2.33)
Codes from <errno.h>, 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 @@ and are used "raw" as IOSTAT values.
#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.cpp b/flang/runtime/stat.cpp
new file mode 100644
index 000000000000..c8120f155836
--- /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/stat.h b/flang/runtime/stat.h
new file mode 100644
index 000000000000..ee1a5346e8d8
--- /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/terminator.cpp b/flang/runtime/terminator.cpp
index e2ea80d3aa55..ed59b1d33ba2 100644
--- a/flang/runtime/terminator.cpp
+++ b/flang/runtime/terminator.cpp
@@ -54,6 +54,11 @@ void Terminator::RegisterCrashHandler(
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/terminator.h b/flang/runtime/terminator.h
index 33a6d5d2c156..c63f8950df3d 100644
--- a/flang/runtime/terminator.h
+++ b/flang/runtime/terminator.h
@@ -32,6 +32,7 @@ class Terminator {
[[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 @@ class Terminator {
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/type-code.h b/flang/runtime/type-code.h
index 9992497445cc..3c5891ba6c68 100644
--- a/flang/runtime/type-code.h
+++ b/flang/runtime/type-code.h
@@ -52,6 +52,9 @@ class TypeCode {
std::optional<std::pair<TypeCategory, int>> 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};
};
More information about the flang-commits
mailing list