[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
This commit is contained in:
parent
06db8f984f
commit
8df28f0aa3
|
@ -50,6 +50,7 @@ add_flang_library(FortranRuntime
|
||||||
io-stmt.cpp
|
io-stmt.cpp
|
||||||
main.cpp
|
main.cpp
|
||||||
memory.cpp
|
memory.cpp
|
||||||
|
stat.cpp
|
||||||
stop.cpp
|
stop.cpp
|
||||||
terminator.cpp
|
terminator.cpp
|
||||||
tools.cpp
|
tools.cpp
|
||||||
|
|
|
@ -78,7 +78,7 @@ int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[],
|
||||||
byteSize *= extent;
|
byteSize *= extent;
|
||||||
}
|
}
|
||||||
void *p{std::malloc(byteSize)};
|
void *p{std::malloc(byteSize)};
|
||||||
if (!p) {
|
if (!p && byteSize) {
|
||||||
return CFI_ERROR_MEM_ALLOCATION;
|
return CFI_ERROR_MEM_ALLOCATION;
|
||||||
}
|
}
|
||||||
descriptor->base_addr = p;
|
descriptor->base_addr = p;
|
||||||
|
|
|
@ -7,39 +7,74 @@
|
||||||
//===----------------------------------------------------------------------===//
|
//===----------------------------------------------------------------------===//
|
||||||
|
|
||||||
#include "allocatable.h"
|
#include "allocatable.h"
|
||||||
|
#include "stat.h"
|
||||||
#include "terminator.h"
|
#include "terminator.h"
|
||||||
|
|
||||||
namespace Fortran::runtime {
|
namespace Fortran::runtime {
|
||||||
extern "C" {
|
extern "C" {
|
||||||
|
|
||||||
void RTNAME(AllocatableInitIntrinsic)(
|
void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor,
|
||||||
Descriptor &, TypeCategory, int /*kind*/, int /*rank*/, int /*corank*/) {
|
TypeCategory category, int kind, int rank, int corank) {
|
||||||
// TODO
|
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*/,
|
void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor,
|
||||||
int /*kind*/, int /*rank*/, int /*corank*/) {
|
SubscriptValue length, int kind, int rank, int corank) {
|
||||||
// TODO
|
INTERNAL_CHECK(corank == 0);
|
||||||
|
descriptor.Establish(
|
||||||
|
kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable);
|
||||||
}
|
}
|
||||||
|
|
||||||
void RTNAME(AllocatableInitDerived)(
|
void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
|
||||||
Descriptor &, const DerivedType &, int /*rank*/, int /*corank*/) {
|
const DerivedType &derivedType, int rank, int corank) {
|
||||||
// TODO
|
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*/,
|
int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
|
||||||
bool /*hasStat*/, Descriptor * /*errMsg*/, const char * /*sourceFile*/,
|
bool /*hasStat*/, Descriptor * /*errMsg*/, const char * /*sourceFile*/,
|
||||||
int /*sourceLine*/) {
|
int /*sourceLine*/) {
|
||||||
// TODO
|
INTERNAL_CHECK(!"MoveAlloc is not yet implemented");
|
||||||
return 0;
|
return StatOk;
|
||||||
}
|
}
|
||||||
|
|
||||||
int RTNAME(AllocatableDeallocate)(Descriptor &, bool /*hasStat*/,
|
void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
|
||||||
Descriptor * /*errMsg*/, const char * /*sourceFile*/, int /*sourceLine*/) {
|
SubscriptValue lower, SubscriptValue upper) {
|
||||||
// TODO
|
INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
|
||||||
return 0;
|
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 &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
|
} // namespace Fortran::runtime
|
||||||
|
|
|
@ -109,6 +109,26 @@ std::size_t Descriptor::Elements() const {
|
||||||
return elements;
|
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 Descriptor::Allocate(const SubscriptValue lb[], const SubscriptValue ub[]) {
|
||||||
int result{ISO::CFI_allocate(&raw_, lb, ub, ElementBytes())};
|
int result{ISO::CFI_allocate(&raw_, lb, ub, ElementBytes())};
|
||||||
if (result == CFI_SUCCESS) {
|
if (result == CFI_SUCCESS) {
|
||||||
|
|
|
@ -44,6 +44,16 @@ public:
|
||||||
SubscriptValue UpperBound() const { return LowerBound() + Extent() - 1; }
|
SubscriptValue UpperBound() const { return LowerBound() + Extent() - 1; }
|
||||||
SubscriptValue ByteStride() const { return raw_.sm; }
|
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:
|
private:
|
||||||
ISO::CFI_dim_t raw_;
|
ISO::CFI_dim_t raw_;
|
||||||
};
|
};
|
||||||
|
@ -271,6 +281,7 @@ public:
|
||||||
std::size_t Elements() const;
|
std::size_t Elements() const;
|
||||||
|
|
||||||
// TODO: SOURCE= and MOLD=
|
// TODO: SOURCE= and MOLD=
|
||||||
|
int Allocate();
|
||||||
int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]);
|
int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]);
|
||||||
int Deallocate(bool finalize = true);
|
int Deallocate(bool finalize = true);
|
||||||
void Destroy(char *data, bool finalize = true) const;
|
void Destroy(char *data, bool finalize = true) const;
|
||||||
|
|
|
@ -19,6 +19,10 @@ These include:
|
||||||
16.10.2, and 16.10.2.33)
|
16.10.2, and 16.10.2.33)
|
||||||
Codes from <errno.h>, e.g. ENOENT, are assumed to be positive
|
Codes from <errno.h>, e.g. ENOENT, are assumed to be positive
|
||||||
and are used "raw" as IOSTAT values.
|
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
|
#endif
|
||||||
#ifndef FORTRAN_RUNTIME_MAGIC_NUMBERS_H_
|
#ifndef FORTRAN_RUNTIME_MAGIC_NUMBERS_H_
|
||||||
#define 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_FLUSH (-3)
|
||||||
#define FORTRAN_RUNTIME_IOSTAT_INQUIRE_INTERNAL_UNIT 256
|
#define FORTRAN_RUNTIME_IOSTAT_INQUIRE_INTERNAL_UNIT 256
|
||||||
|
|
||||||
#define FORTRAN_RUNTIME_STAT_FAILED_IMAGE 10
|
#define FORTRAN_RUNTIME_STAT_FAILED_IMAGE 101
|
||||||
#define FORTRAN_RUNTIME_STAT_LOCKED 11
|
#define FORTRAN_RUNTIME_STAT_LOCKED 102
|
||||||
#define FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE 12
|
#define FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE 103
|
||||||
#define FORTRAN_RUNTIME_STAT_STOPPED_IMAGE 13
|
#define FORTRAN_RUNTIME_STAT_STOPPED_IMAGE 104
|
||||||
#define FORTRAN_RUNTIME_STAT_UNLOCKED 14
|
#define FORTRAN_RUNTIME_STAT_UNLOCKED 105
|
||||||
#define FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE 15
|
#define FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE 106
|
||||||
#endif
|
#endif
|
||||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -54,6 +54,11 @@ void Terminator::RegisterCrashHandler(
|
||||||
line);
|
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
|
// TODO: These will be defined in the coarray runtime library
|
||||||
void NotifyOtherImagesOfNormalEnd() {}
|
void NotifyOtherImagesOfNormalEnd() {}
|
||||||
void NotifyOtherImagesOfFailImageStatement() {}
|
void NotifyOtherImagesOfFailImageStatement() {}
|
||||||
|
|
|
@ -32,6 +32,7 @@ public:
|
||||||
[[noreturn]] void CrashArgs(const char *message, va_list &) const;
|
[[noreturn]] void CrashArgs(const char *message, va_list &) const;
|
||||||
[[noreturn]] void CheckFailed(
|
[[noreturn]] void CheckFailed(
|
||||||
const char *predicate, const char *file, int line) const;
|
const char *predicate, const char *file, int line) const;
|
||||||
|
[[noreturn]] void CheckFailed(const char *predicate) const;
|
||||||
|
|
||||||
// For test harnessing - overrides CrashArgs().
|
// For test harnessing - overrides CrashArgs().
|
||||||
static void RegisterCrashHandler(void (*)(const char *sourceFile,
|
static void RegisterCrashHandler(void (*)(const char *sourceFile,
|
||||||
|
@ -49,6 +50,12 @@ private:
|
||||||
else \
|
else \
|
||||||
(terminator).CheckFailed(#pred, __FILE__, __LINE__)
|
(terminator).CheckFailed(#pred, __FILE__, __LINE__)
|
||||||
|
|
||||||
|
#define INTERNAL_CHECK(pred) \
|
||||||
|
if (pred) \
|
||||||
|
; \
|
||||||
|
else \
|
||||||
|
Terminator{__FILE__, __LINE__}.CheckFailed(#pred)
|
||||||
|
|
||||||
void NotifyOtherImagesOfNormalEnd();
|
void NotifyOtherImagesOfNormalEnd();
|
||||||
void NotifyOtherImagesOfFailImageStatement();
|
void NotifyOtherImagesOfFailImageStatement();
|
||||||
void NotifyOtherImagesOfErrorTermination();
|
void NotifyOtherImagesOfErrorTermination();
|
||||||
|
|
|
@ -52,6 +52,9 @@ public:
|
||||||
|
|
||||||
std::optional<std::pair<TypeCategory, int>> GetCategoryAndKind() const;
|
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:
|
private:
|
||||||
ISO::CFI_type_t raw_{CFI_type_other};
|
ISO::CFI_type_t raw_{CFI_type_other};
|
||||||
};
|
};
|
||||||
|
|
Loading…
Reference in New Issue