[flang] Add implementation of move_alloc to the runtime

[DavidTruby]

Summary

This patch adds a move_alloc implementation to the flang runtime.
Most of the checks required by the standard for move_alloc are
done by semenatic analysis; these checks are not replicated here.

[klausler]

flang/runtime/allocatable.cpp

48

RUNTIME_CHECK() is the macro to use here.

This check will not catch a discrepancy in derived types.

You should confirm that both d'tors are allocatables.

50

Deallocate won't run finalizers (7.5.6.3 p2). You want

int stat{to.Destroy()};
if (stat != StatOk) {

return ReturnError(...);

}

58

swap() doesn't know how large the descriptors are. You want memcpy(to, from, from.SizeInBytes()) followed by from.raw.base_address = nullptr.

69

In the case of MOVE_ALLOC(x,x), it must be the case that x is in the deallocated state and nothing happens. Is that true with this implementation? If not, you'll need to check for this condition.

flang/unittests/Runtime/Allocatable.cpp

55

Braced initialization, please.

75

Other tests: ensure that FINAL procedures are called; ensure that MOVE_ALLOC(x,x) is allowed only with x in a deallocated state.

[DavidTruby]

Use Destroy over Deallocate
Don't swap the descriptors
Add handling for MOVE_ALLOC(x,x)

[DavidTruby]

Thanks for the review!

flang/runtime/allocatable.cpp

48

I don't think it's possible in the general case to detect discrepancies in derived types here, because the requirement for derived types is that they're compatible, not that they're identical. This check should be done at semantic analysis, I only added the assert here as an extra precaution.

58

std::swap() just calls the assignment operator, which I performs the memcpy you are describing internally. I agree that it isn't actually necessary to do the swap though, so I've changed to just use the assignment operator once and set from to nullptr as you suggested.

flang/unittests/Runtime/Allocatable.cpp

75

I had trouble writing the test for FINAL procedures as it would require creating a derived type and associating a finalizer with it from the C++ side here; do you know if there are any other tests that do this that I can use as a reference?

[DavidTruby]

Fix error string comparison check

[klausler]

flang/runtime/allocatable.cpp

47

handled*

53

Consider the case where neither allocatable is allocated.

[DavidTruby]

flang/runtime/allocatable.cpp

53

The case where neither is allocated should already fall through to the return at the end, and do nothing. I believe this is what is required in the standard.

[DavidTruby]

Rebase and spelling correction

[klausler]

flang/runtime/allocatable.cpp

59

if (stat != StatOk) should be used for readability so that one doesn't need to know that Fortran's successful status value is zero.

[vzakhari]

Hello David,

I am getting the following error with -DBUILD_SHARED_LIBS=OFF build and make check-flang:

ld.lld: error: undefined symbol: mlir::SuccessorRange::SuccessorRange(mlir::Operation*)
>>> referenced by Operation.h:549 (/llvm-project/llvm/../mlir/include/mlir/IR/Operation.h:549)
>>>               CMakeFiles/FlangRuntimeTests.dir/Allocatable.cpp.o:(mlir::Operation::getSuccessors())

[vzakhari]

In D141286#4063924, @vzakhari wrote:

Hello David,

I am getting the following error with -DBUILD_SHARED_LIBS=OFF build and make check-flang:

ld.lld: error: undefined symbol: mlir::SuccessorRange::SuccessorRange(mlir::Operation*)
>>> referenced by Operation.h:549 (/llvm-project/llvm/../mlir/include/mlir/IR/Operation.h:549)
>>>               CMakeFiles/FlangRuntimeTests.dir/Allocatable.cpp.o:(mlir::Operation::getSuccessors())

D142069 seems to fix it for me.

[clementval]

flang/runtime/allocatable.cpp

47

This is not the case when one of the descriptor is polymorphic or unlimited polymorphic.
An unallocated unlimited polymorphic descriptor has not type to begin with but should be allowed here. Same with a polymorphic descriptor that is compatible.

[clementval]

flang/runtime/allocatable.cpp

47

An example can be found here: https://github.com/llvm/llvm-project/issues/60250

flang/include/flang/Runtime/allocatable.h

 int RTNAME(AllocatableAllocateSource)(Descriptor &, const Descriptor &source,
     bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // Implements the intrinsic subroutine MOVE_ALLOC (16.9.137 in F'2018,
 // but note the order of first two arguments is reversed for consistency
 // with the other APIs for allocatables.)  The destination descriptor
 // must be initialized.
-int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor &from,
+std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
     bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // Deallocates an allocatable.  Finalizes elements &/or components as needed.
 // The allocatable is left in an initialized state suitable for reallocation
 // with the same bounds, cobounds, and length type parameters.
 int RTNAME(AllocatableDeallocate)(Descriptor &, bool hasStat = false,
     const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,

flang/runtime/allocatable.cpp

 //===-- runtime/allocatable.cpp -------------------------------------------===//
 //
 // 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 "flang/Runtime/allocatable.h"
 #include "assign.h"
 #include "derived.h"
 #include "stat.h"
 #include "terminator.h"
 #include "type-info.h"
+#include "flang/ISO_Fortran_binding.h"
+#include "flang/Runtime/assign.h"
+#include "flang/Runtime/descriptor.h"
 
 namespace Fortran::runtime {
 extern "C" {
 
 void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor,
     TypeCategory category, int kind, int rank, int corank) {
   INTERNAL_CHECK(corank == 0);
   descriptor.Establish(TypeCode{category, kind},

 
 void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
     const typeInfo::DerivedType &derivedType, int rank, int corank) {
   INTERNAL_CHECK(corank == 0);
   descriptor.Establish(
       derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
 }
 
-int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
-    bool /*hasStat*/, const Descriptor * /*errMsg*/,
-    const char * /*sourceFile*/, int /*sourceLine*/) {
-  INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented
+std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from, bool hasStat,
+    const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  // Should be handled by semantic analysis
+  RUNTIME_CHECK(terminator, to.type() == from.type());
+  RUNTIME_CHECK(terminator, to.IsAllocatable() && from.IsAllocatable());
+
+  // If to and from are the same allocatable they must not be allocated
+  // and nothing should be done.
+  if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) {
+    return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
+  }
+
+  if (to.IsAllocated()) {
+    int stat{to.Destroy(/*finalize=*/true)};
+    if (stat != StatOk) {
+      return ReturnError(terminator, stat, errMsg, hasStat);
+    }
+  }
+
+  // If from isn't allocated, the standard defines that nothing should be done.
+  if (from.IsAllocated()) {
+    to = from;
+    from.raw().base_addr = nullptr;
+  }
   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.
 }

flang/unittests/Runtime/Allocatable.cpp

+//===-- flang/unittests/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 "flang/Runtime/allocatable.h"
+#include "gtest/gtest.h"
+#include "tools.h"
+#include "flang/Common/Fortran.h"
+#include "flang/ISO_Fortran_binding.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Support/InitFIR.h"
+#include "flang/Optimizer/Support/KindMapping.h"
+#include "flang/Runtime/descriptor.h"
+#include "flang/Runtime/memory.h"
+
+using namespace Fortran::runtime;
+
+static OwningPtr<Descriptor> createAllocatable(
+    Fortran::common::TypeCategory tc, int kind, int rank = 1) {
+  return Descriptor::Create(TypeCode{tc, kind}, kind, nullptr, rank, nullptr,
+      CFI_attribute_allocatable);
+}
+
+TEST(AllocatableTest, MoveAlloc) {
+  using Fortran::common::TypeCategory;
+  // INTEGER(4), ALLOCATABLE :: a(:)
+  auto a{createAllocatable(TypeCategory::Integer, 4)};
+  // INTEGER(4), ALLOCATABLE :: b(:)
+  auto b{createAllocatable(TypeCategory::Integer, 4)};
+  // ALLOCATE(a(20))
+  a->GetDimension(0).SetBounds(1, 20);
+  a->Allocate();
+
+  EXPECT_TRUE(a->IsAllocated());
+  EXPECT_FALSE(b->IsAllocated());
+
+  // Simple move_alloc
+  RTNAME(MoveAlloc)(*b, *a, false, nullptr, __FILE__, __LINE__);
+  EXPECT_FALSE(a->IsAllocated());
+  EXPECT_TRUE(b->IsAllocated());
+
+  // move_alloc with stat
+  std::int32_t stat{
+      RTNAME(MoveAlloc)(*a, *b, true, nullptr, __FILE__, __LINE__)};
+  EXPECT_TRUE(a->IsAllocated());
+  EXPECT_FALSE(b->IsAllocated());
+  EXPECT_EQ(stat, 0);
+
+  // move_alloc with errMsg
+  auto errMsg{Descriptor::Create(
+      sizeof(char), 64, nullptr, 0, nullptr, CFI_attribute_allocatable)};
+  errMsg->Allocate();
+  RTNAME(MoveAlloc)(*b, *a, false, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_FALSE(a->IsAllocated());
+  EXPECT_TRUE(b->IsAllocated());
+
+  // move_alloc with stat and errMsg
+  stat = RTNAME(MoveAlloc)(*a, *b, true, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_TRUE(a->IsAllocated());
+  EXPECT_FALSE(b->IsAllocated());
+  EXPECT_EQ(stat, 0);
+
+  // move_alloc with the same deallocated array
+  stat = RTNAME(MoveAlloc)(*b, *b, true, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_FALSE(b->IsAllocated());
+  EXPECT_EQ(stat, 0);
+
+  // move_alloc with the same allocated array should fail
+  stat = RTNAME(MoveAlloc)(*a, *a, true, errMsg.get(), __FILE__, __LINE__);
+  EXPECT_EQ(stat, 18);
+  std::string_view errStr{errMsg->OffsetElement(), errMsg->ElementBytes()};
+  auto trim_pos = errStr.find_last_not_of(' ');
+  if (trim_pos != errStr.npos)
+    errStr.remove_suffix(errStr.size() - trim_pos - 1);
+  EXPECT_EQ(errStr, "Invalid descriptor");
+}

flang/unittests/Runtime/CMakeLists.txt

 add_flang_unittest(FlangRuntimeTests
+  Allocatable.cpp
   BufferTest.cpp
   CharacterTest.cpp
   CommandTest.cpp
   Complex.cpp
   CrashHandlerFixture.cpp
   ExternalIOTest.cpp
   Format.cpp
   Inquiry.cpp