[flang] Implement runtime support for basic ALLOCATE/DEALLOCATE

[klausler]

Summary

Add error reporting infrastructure and support for ALLOCATE
and DEALLOCATE statements of intrinsic types without SOURCE=
or MOLD=.

[jeanPerier]

flang/runtime/allocatable.cpp

52

I finally was able to test end-to-end and there is a very sneaky issue here, auto dim is making a copy of the dimension instead of taking it by reference (at least for me using gcc 8.3, I do not know what is the C++ type resolution here).
Both:
auto& dim{descriptor.GetDimension(zeroBasedDim)};
or
descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
fixed the issue for me.

[klausler]

Fix bug noticed by Jean.

[jeanPerier]

Thanks, looks good to me.

flang/runtime/CMakeLists.txt

add_flang_library(FortranRuntime
   format.cpp
   internal-unit.cpp
   iostat.cpp
   io-api.cpp
   io-error.cpp
   io-stmt.cpp
   main.cpp
   memory.cpp
+  stat.cpp
   stop.cpp
   terminator.cpp
   tools.cpp
   transformational.cpp
   type-code.cpp
   unit.cpp
   unit-map.cpp
 
   LINK_LIBS
   FortranDecimal
 )

flang/runtime/ISO_Fortran_binding.cpp

for (std::size_t j{0}; j < rank; ++j, ++dim) {
     CFI_index_t ub{upper_bounds[j]};
     CFI_index_t extent{ub >= lb ? ub - lb + 1 : 0};
     dim->lower_bound = lb;
     dim->extent = extent;
     dim->sm = byteSize;
     byteSize *= extent;
   }
   void *p{std::malloc(byteSize)};
-  if (!p) {
+  if (!p && byteSize) {
     return CFI_ERROR_MEM_ALLOCATION;
   }
   descriptor->base_addr = p;
   descriptor->elem_len = elem_len;
   return CFI_SUCCESS;
 }
 
 int CFI_deallocate(CFI_cdesc_t *descriptor) {

flang/runtime/allocatable.cpp

 //===-- runtime/allocatable.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 "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 &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 &descriptor,
+    const DerivedType &derivedType, int rank, int corank) {
+  INTERNAL_CHECK(corank == 0);
+  descriptor.Establish(
+      derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
 }
 
-void RTNAME(AllocatableInitCharacter)(Descriptor &, SubscriptValue /*length*/,
-    int /*kind*/, int /*rank*/, int /*corank*/) {
-  // TODO
+void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {
+  INTERNAL_CHECK(!"AllocatableAssign is not yet implemented");
 }
 
-void RTNAME(AllocatableInitDerived)(
-    Descriptor &, const DerivedType &, int /*rank*/, int /*corank*/) {
-  // TODO
-}
-
-void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {}
-
 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.h

 
 class Dimension {
 public:
   SubscriptValue LowerBound() const { return raw_.lower_bound; }
   SubscriptValue Extent() const { return raw_.extent; }
   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_;
 };
 
 // The storage for this object follows the last used dim[] entry in a
 // Descriptor (CFI_cdesc_t) generic descriptor.  Space matters here, since
 // descriptors serve as POINTER and ALLOCATABLE components of derived type
 // instances.  The presence of this structure is implied by the flag
static constexpr std::size_t SizeInBytes(
     return bytes;
   }
 
   std::size_t SizeInBytes() const;
 
   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;
 
   bool IsContiguous(int leadingDimensions = maxRank) const {
     auto bytes{static_cast<SubscriptValue>(ElementBytes())};
     for (int j{0}; j < leadingDimensions && j < raw_.rank; ++j) {
       const Dimension &dim{GetDimension(j)};

flang/runtime/descriptor.cpp

std::size_t Descriptor::Elements() const {
   int n{rank()};
   std::size_t elements{1};
   for (int j{0}; j < n; ++j) {
     elements *= GetDimension(j).Extent();
   }
   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) {
     // TODO: derived type initialization
   }
   return result;
 }
 

flang/runtime/magic-numbers.h

 code in the compiler and runtime library.
 These include:
  - the error/end code values that can be returned
    to an IOSTAT= or STAT= specifier on a Fortran I/O statement
    or coindexed data reference (see Fortran 2018 12.11.5,
    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_
 
 #define FORTRAN_RUNTIME_IOSTAT_END (-1)
 #define FORTRAN_RUNTIME_IOSTAT_EOR (-2)
 #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.h

+//===-- 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/stat.cpp

+//===-- 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/terminator.h

public:
   void SetLocation(const char *sourceFileName = nullptr, int sourceLine = 0) {
     sourceFileName_ = sourceFileName;
     sourceLine_ = sourceLine;
   }
   [[noreturn]] void Crash(const char *message, ...) const;
   [[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,
       int sourceLine, const char *message, va_list &ap));
 
 private:
   const char *sourceFileName_{nullptr};
   int sourceLine_{0};
 };
 
 // RUNTIME_CHECK() guarantees evaluation of its predicate.
 #define RUNTIME_CHECK(terminator, pred) \
   if (pred) \
     ; \
   else \
     (terminator).CheckFailed(#pred, __FILE__, __LINE__)
 
+#define INTERNAL_CHECK(pred) \
+  if (pred) \
+    ; \
+  else \
+    Terminator{__FILE__, __LINE__}.CheckFailed(#pred)
+
 void NotifyOtherImagesOfNormalEnd();
 void NotifyOtherImagesOfFailImageStatement();
 void NotifyOtherImagesOfErrorTermination();
 } // namespace Fortran::runtime
 
 namespace Fortran::runtime::io {
 void FlushOutputOnCrash(const Terminator &);
 }
 
 #endif // FORTRAN_RUNTIME_TERMINATOR_H_

flang/runtime/terminator.cpp

 }
 
 [[noreturn]] void Terminator::CheckFailed(
     const char *predicate, const char *file, int line) const {
   Crash("Internal error: RUNTIME_CHECK(%s) failed at %s(%d)", predicate, file,
       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() {}
 void NotifyOtherImagesOfErrorTermination() {}
 } // namespace Fortran::runtime

flang/runtime/type-code.h

constexpr bool IsLogical() const {
     return raw_ == CFI_type_Bool ||
         (raw_ >= CFI_type_int_fast8_t && raw_ <= CFI_type_int_fast64_t);
   }
   constexpr bool IsDerived() const { return raw_ == CFI_type_struct; }
   constexpr bool IsIntrinsic() const { return IsValid() && !IsDerived(); }
 
   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};
 };
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_TYPE_CODE_H_