[Flang] Implement RENAME intrinsic (code-gen + runtime entry point) (llvm#98359)

mjklemm · web-flow · commit a5a29a26aaf0 · 2024-07-15T08:39:19.000+02:00
This PR implements the RENAME intrinsic, which is a GFortran extension (see https://gcc.gnu.org/onlinedocs/gfortran/intrinsic-procedures/rename.html).
diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
@@ -1001,3 +1001,49 @@ PROGRAM example_getcwd
   PRINT *, status
 END PROGRAM
 ```
+
+### Non-standard Intrinsics: RENAME
+`RENAME(OLD, NEW[, STATUS])` renames/moves a file on the filesystem.
+
+This intrinsic is provided in both subroutine and function form; however, only one form can be used in any given program unit.
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** Subroutine, function
+- **Syntax:** `CALL RENAME(SRC, DST[, STATUS])`
+- **Arguments:**
+- **Return value** status code (0: success, non-zero for errors)
+
+| Argument | Description                       |
+|----------|-----------------------------------|
+| `SRC`    | Source path                       |
+| `DST`    | Destination path                  |
+| `STATUS` | Status code (for subroutine form) |
+
+The status code returned by both the subroutine and function form corresponds to the value of `errno` if the invocation of `rename(2)` was not successful.
+
+#### Example
+
+Function form:
+```
+program rename_func
+    implicit none
+    integer :: status
+    status = rename('src', 'dst')
+    print *, 'status:', status
+    status = rename('dst', 'src')
+    print *, 'status:', status
+end program rename_func
+```
+
+Subroutine form:
+```
+program rename_proc
+    implicit none
+    integer :: status
+    call rename('src', 'dst', status)
+    print *, 'status:', status
+    call rename('dst', 'src')
+end program rename_proc
+```
diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
@@ -347,6 +347,8 @@ struct IntrinsicLibrary {
   fir::ExtendedValue genReduce(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genReduceDim(mlir::Type,
                                   llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genRename(std::optional<mlir::Type>,
+                               mlir::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genRepeat(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genReshape(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genRRSpacing(mlir::Type resultType,
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h
@@ -53,6 +53,10 @@ void genRandomNumber(fir::FirOpBuilder &, mlir::Location, mlir::Value harvest);
 void genRandomSeed(fir::FirOpBuilder &, mlir::Location, mlir::Value size,
                    mlir::Value put, mlir::Value get);
 
+/// generate rename runtime call
+void genRename(fir::FirOpBuilder &builder, mlir::Location loc,
+               mlir::Value path1, mlir::Value path2, mlir::Value status);
+
 /// generate runtime call to transfer intrinsic with no size argument
 void genTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
                  mlir::Value resultBox, mlir::Value sourceBox,
diff --git a/flang/include/flang/Runtime/misc-intrinsic.h b/flang/include/flang/Runtime/misc-intrinsic.h
@@ -19,6 +19,8 @@ namespace Fortran::runtime {
 class Descriptor;
 
 extern "C" {
+void RTDECL(Rename)(const Descriptor &path1, const Descriptor &path2,
+    const Descriptor *status, const char *sourceFile, int line);
 void RTDECL(Transfer)(Descriptor &result, const Descriptor &source,
     const Descriptor &mold, const char *sourceFile, int line);
 void RTDECL(TransferSize)(Descriptor &result, const Descriptor &source,
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
@@ -795,6 +795,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
             {"identity", SameType, Rank::scalar, Optionality::optional},
             {"ordered", AnyLogical, Rank::scalar, Optionality::optional}},
         SameType, Rank::scalar, IntrinsicClass::transformationalFunction},
+    {"rename",
+        {{"path1", DefaultChar, Rank::scalar},
+            {"path2", DefaultChar, Rank::scalar}},
+        DefaultInt, Rank::scalar},
     {"repeat",
         {{"string", SameCharNoLen, Rank::scalar},
             {"ncopies", AnyInt, Rank::scalar}},
@@ -1464,6 +1468,12 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"get", DefaultInt, Rank::vector, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"rename",
+        {{"path1", DefaultChar, Rank::scalar},
+            {"path2", DefaultChar, Rank::scalar},
+            {"status", DefaultInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::scalar, IntrinsicClass::impureSubroutine},
     {"system",
         {{"command", DefaultChar, Rank::scalar},
             {"exitstat", DefaultInt, Rank::scalar, Optionality::optional,
@@ -2612,7 +2622,8 @@ bool IntrinsicProcTable::Implementation::IsDualIntrinsic(
     const std::string &name) const {
   // Collection for some intrinsics with function and subroutine form,
   // in order to pass the semantic check.
-  static const std::string dualIntrinsic[]{{"etime"}, {"getcwd"}};
+  static const std::string dualIntrinsic[]{
+      {"etime"s}, {"getcwd"s}, {"rename"s}};
 
   return std::find_if(std::begin(dualIntrinsic), std::end(dualIntrinsic),
              [&name](const std::string &dualName) {
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -550,6 +550,12 @@ static constexpr IntrinsicHandler handlers[]{
        {"identity", asAddr, handleDynamicOptional},
        {"ordered", asValue, handleDynamicOptional}}},
      /*isElemental=*/false},
+    {"rename",
+     &I::genRename,
+     {{{"path1", asBox},
+       {"path2", asBox},
+       {"status", asBox, handleDynamicOptional}}},
+     /*isElemental=*/false},
     {"repeat",
      &I::genRepeat,
      {{{"string", asAddr}, {"ncopies", asValue}}},
@@ -5917,6 +5923,37 @@ IntrinsicLibrary::genReduce(mlir::Type resultType,
   return readAndAddCleanUp(resultMutableBox, resultType, "REDUCE");
 }
 
+// RENAME
+fir::ExtendedValue
+IntrinsicLibrary::genRename(std::optional<mlir::Type> resultType,
+                            mlir::ArrayRef<fir::ExtendedValue> args) {
+  assert((args.size() == 3 && !resultType.has_value()) ||
+         (args.size() == 2 && resultType.has_value()));
+
+  mlir::Value path1 = fir::getBase(args[0]);
+  mlir::Value path2 = fir::getBase(args[1]);
+  if (!path1 || !path2)
+    fir::emitFatalError(loc, "Expected at least two dummy arguments");
+
+  if (resultType.has_value()) {
+    // code-gen for the function form of RENAME
+    auto statusAddr = builder.createTemporary(loc, *resultType);
+    auto statusBox = builder.createBox(loc, statusAddr);
+    fir::runtime::genRename(builder, loc, path1, path2, statusBox);
+    return builder.create<fir::LoadOp>(loc, statusAddr);
+  } else {
+    // code-gen for the procedure form of RENAME
+    mlir::Type boxNoneTy = fir::BoxType::get(builder.getNoneType());
+    auto status = args[2];
+    mlir::Value statusBox =
+        isStaticallyPresent(status)
+            ? fir::getBase(status)
+            : builder.create<fir::AbsentOp>(loc, boxNoneTy).getResult();
+    fir::runtime::genRename(builder, loc, path1, path2, statusBox);
+    return {};
+  }
+}
+
 // REPEAT
 fir::ExtendedValue
 IntrinsicLibrary::genRepeat(mlir::Type resultType,
diff --git a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp
@@ -199,6 +199,24 @@ void fir::runtime::genRandomSeed(fir::FirOpBuilder &builder, mlir::Location loc,
   builder.create<fir::CallOp>(loc, func, args);
 }
 
+/// generate rename runtime call
+void fir::runtime::genRename(fir::FirOpBuilder &builder, mlir::Location loc,
+                             mlir::Value path1, mlir::Value path2,
+                             mlir::Value status) {
+  auto runtimeFunc =
+      fir::runtime::getRuntimeFunc<mkRTKey(Rename)>(loc, builder);
+  mlir::FunctionType runtimeFuncTy = runtimeFunc.getFunctionType();
+
+  mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
+  mlir::Value sourceLine =
+      fir::factory::locationToLineNo(builder, loc, runtimeFuncTy.getInput(4));
+
+  llvm::SmallVector<mlir::Value> args =
+      fir::runtime::createArguments(builder, loc, runtimeFuncTy, path1, path2,
+                                    status, sourceFile, sourceLine);
+  builder.create<fir::CallOp>(loc, runtimeFunc, args);
+}
+
 /// generate runtime call to transfer intrinsic with no size argument
 void fir::runtime::genTransfer(fir::FirOpBuilder &builder, mlir::Location loc,
                                mlir::Value resultBox, mlir::Value sourceBox,
diff --git a/flang/runtime/misc-intrinsic.cpp b/flang/runtime/misc-intrinsic.cpp
@@ -12,6 +12,7 @@
 #include "flang/Common/optional.h"
 #include "flang/Runtime/descriptor.h"
 #include <algorithm>
+#include <cstdio>
 #include <cstring>
 
 namespace Fortran::runtime {
@@ -55,6 +56,36 @@ static RT_API_ATTRS void TransferImpl(Descriptor &result,
 extern "C" {
 RT_EXT_API_GROUP_BEGIN
 
+void RTDECL(Rename)(const Descriptor &path1, const Descriptor &path2,
+    const Descriptor *status, const char *sourceFile, int line) {
+  Terminator terminator{sourceFile, line};
+
+  char *pathSrc{EnsureNullTerminated(
+      path1.OffsetElement(), path1.ElementBytes(), terminator)};
+  char *pathDst{EnsureNullTerminated(
+      path2.OffsetElement(), path2.ElementBytes(), terminator)};
+
+  // We simply call rename(2) from POSIX
+  int result{rename(pathSrc, pathDst)};
+  if (status) {
+    // When an error has happened,
+    int errorCode{0}; // Assume success
+    if (result != 0) {
+      // The rename operation has failed, so return the error code as status.
+      errorCode = errno;
+    }
+    StoreIntToDescriptor(status, errorCode, terminator);
+  }
+
+  // Deallocate memory if EnsureNullTerminated dynamically allocated memory
+  if (pathSrc != path1.OffsetElement()) {
+    FreeMemory(pathSrc);
+  }
+  if (pathDst != path2.OffsetElement()) {
+    FreeMemory(pathDst);
+  }
+}
+
 void RTDEF(Transfer)(Descriptor &result, const Descriptor &source,
     const Descriptor &mold, const char *sourceFile, int line) {
   Fortran::common::optional<std::int64_t> elements;
diff --git a/flang/test/Lower/Intrinsics/rename.f90 b/flang/test/Lower/Intrinsics/rename.f90
@@ -0,0 +1,51 @@
+!RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+
+!CHECK-LABEL: func.func @_QPtest_rename
+!CHECK-SAME:    %[[dummySrc:.*]]: !fir.boxchar<1> {fir.bindc_name = "src"},
+!CHECK-SAME:    %[[dummyDst:.*]]: !fir.boxchar<1> {fir.bindc_name = "dst"}) {
+subroutine test_rename(src, dst)
+    implicit none
+    character(*) :: src, dst
+
+    call rename(src, dst)
+    !CHECK:      %[[dstUnbox:.*]]:2 = fir.unboxchar %[[dummyDst]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+    !CHECK-NEXT: %[[dstDecl:.*]]:2 = hlfir.declare %[[dstUnbox]]#0 typeparams %[[dstUnbox]]#1 dummy_scope %0 {uniq_name = "_QFtest_renameEdst"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+    !CHECK-NEXT: %[[srcUnbox:.*]]:2 = fir.unboxchar %[[dummySrc]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+    !CHECK-NEXT: %[[srcDecl:.*]]:2 = hlfir.declare %3#0 typeparams %[[srcUnbox]]#1 dummy_scope %0 {uniq_name = "_QFtest_renameEsrc"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+    !CHECK-NEXT: %[[srcBox:.*]] = fir.embox %[[srcDecl]]#1 typeparams %[[srcUnbox]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+    !CHECK-NEXT: %[[dstBox:.*]] = fir.embox %[[dstDecl]]#1 typeparams %[[dstUnbox]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+    !CHECK-NEXT: %[[statusBox:.*]] = fir.absent !fir.box<none>
+    !CHECK-NEXT: %[[sourceFile:.*]] = fir.address_of(@[[someString:.*]]) : !fir.ref<!fir.char<1,[[len:.*]]>>
+    !CHECK-NEXT: %[[c10_i32:.*]] = arith.constant [[line:.*]] : i32
+    !CHECK-NEXT: %[[src:.*]] = fir.convert %[[srcBox]] : (!fir.box<!fir.char<1,?>>) -> !fir.box<none>
+    !CHECK-NEXT: %[[dst:.*]] = fir.convert %[[dstBox]] : (!fir.box<!fir.char<1,?>>) -> !fir.box<none>
+    !CHECK-NEXT: %[[loc:.*]] = fir.convert %[[sourceFileConv:.*]]: (!fir.ref<!fir.char<1,[[len:.*]]>>) -> !fir.ref<i8>
+    !CHECK-NEXT: %[[result:.*]] = fir.call @_FortranARename(%[[src]], %[[dst]], %[[statusBox]], %[[loc]], %[[c10_i32]]) fastmath<contract> : (!fir.box<none>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> none
+end subroutine test_rename
+
+!CHECK-LABEL: func.func @_QPtest_rename_status
+!CHECK-SAME:    %[[dummySrc:.*]]: !fir.boxchar<1> {fir.bindc_name = "src"},
+!CHECK-SAME:    %[[dummyDst:.*]]: !fir.boxchar<1> {fir.bindc_name = "dst"}) {
+subroutine test_rename_status(src, dst)
+    implicit none
+    character(*) :: src, dst
+    integer :: status
+
+    call rename(src, dst, status)
+    !CHECK:      %[[dstUnbox:.*]]:2 = fir.unboxchar %[[dummyDst]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+    !CHECK-NEXT: %[[dstDecl:.*]]:2 = hlfir.declare %[[dstUnbox]]#0 typeparams %[[dstUnbox]]#1 dummy_scope %0 {uniq_name = "_QFtest_rename_statusEdst"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+    !CHECK-NEXT: %[[srcUnbox:.*]]:2 = fir.unboxchar %[[dummySrc]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+    !CHECK-NEXT: %[[srcDecl:.*]]:2 = hlfir.declare %3#0 typeparams %[[srcUnbox]]#1 dummy_scope %0 {uniq_name = "_QFtest_rename_statusEsrc"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> (!fir.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+    !CHECK-NEXT: %[[statusAlloc:.*]] = fir.alloca i32 {bindc_name = "status", uniq_name = "_QFtest_rename_statusEstatus"}
+    !CHECK-NEXT: %[[statusDecl:.*]]:2 = hlfir.declare %[[statusAlloc]] {uniq_name = "_QFtest_rename_statusEstatus"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+    !CHECK-NEXT: %[[srcBox:.*]] = fir.embox %[[srcDecl]]#1 typeparams %[[srcUnbox]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+    !CHECK-NEXT: %[[dstBox:.*]] = fir.embox %[[dstDecl]]#1 typeparams %[[dstUnbox]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+    !CHECK-NEXT: %[[statusBox:.*]] = fir.embox %[[statusDecl]]#1 : (!fir.ref<i32>) -> !fir.box<i32>
+    !CHECK-NEXT: %[[sourceFile:.*]] = fir.address_of(@[[someString:.*]]) : !fir.ref<!fir.char<1,[[len:.*]]>>
+    !CHECK-NEXT: %[[c10_i32:.*]] = arith.constant [[line:.*]] : i32
+    !CHECK-NEXT: %[[src:.*]] = fir.convert %[[srcBox]] : (!fir.box<!fir.char<1,?>>) -> !fir.box<none>
+    !CHECK-NEXT: %[[dst:.*]] = fir.convert %[[dstBox]] : (!fir.box<!fir.char<1,?>>) -> !fir.box<none>
+    !CHECK-NEXT: %[[status:.*]] = fir.convert %[[statusBox]] : (!fir.box<i32>) -> !fir.box<none>
+    !CHECK-NEXT: %[[loc:.*]] = fir.convert %[[sourceFileConv:.*]]: (!fir.ref<!fir.char<1,[[len:.*]]>>) -> !fir.ref<i8>
+    !CHECK-NEXT: %[[result:.*]] = fir.call @_FortranARename(%[[src]], %[[dst]], %[[status]], %[[loc]], %[[c10_i32]]) fastmath<contract> : (!fir.box<none>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> none
+end subroutine test_rename_status
diff --git a/flang/test/Lower/namelist.f90 b/flang/test/Lower/namelist.f90
@@ -71,7 +71,7 @@ program p
   ! CHECK:     %[[V_70:[0-9]+]] = fir.call @_FortranAioEndIoStatement(%[[V_58]]) fastmath<contract> : (!fir.ref<i8>) -> i32
   write(*, nnn)
 
-  call rename
+  call rename_sub
 end
 
 ! CHECK-LABEL: c.func @_QPsss
@@ -128,8 +128,8 @@ module mmm
   namelist /aaa/ rrr
 end
 
-! CHECK-LABEL: c.func @_QPrename
-subroutine rename
+! CHECK-LABEL: c.func @_QPrename_sub
+subroutine rename_sub
   use mmm, bbb => aaa
   rrr = 3.
   ! CHECK:     %[[V_4:[0-9]+]] = fir.call @_FortranAioBeginExternalListOutput
