[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

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

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;

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;
 }
 
-int RTNAME(AllocatableDeallocate)(Descriptor &, bool /*hasStat*/,
-    Descriptor * /*errMsg*/, const char * /*sourceFile*/, int /*sourceLine*/) {
-  // TODO
-  return 0;
+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 &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

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) {

flang/runtime/descriptor.h

@@ -44,6 +44,16 @@ public:
   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 @@ public:
   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;

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

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

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

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() {}

flang/runtime/terminator.h

@@ -32,6 +32,7 @@ public:
   [[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 @@ private:
   else \
     (terminator).CheckFailed(#pred, __FILE__, __LINE__)
 
+#define INTERNAL_CHECK(pred) \
+  if (pred) \
+    ; \
+  else \
+    Terminator{__FILE__, __LINE__}.CheckFailed(#pred)
+
 void NotifyOtherImagesOfNormalEnd();
 void NotifyOtherImagesOfFailImageStatement();
 void NotifyOtherImagesOfErrorTermination();

flang/runtime/type-code.h

@@ -52,6 +52,9 @@ public:
 
   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};
 };