[flang] Implement CHDIR intrinsic (#124280)

This intrinsic is a gnu extension
(https://gcc.gnu.org/onlinedocs/gfortran/CHDIR.html) and is used in
FLEUR (https://github.com/JuDFTteam/FLEUR).

Author: JDPailleux

flang/docs/Intrinsics.md

@@ -767,7 +767,7 @@ This phase currently supports all the intrinsic procedures listed above but the
 | Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE |
 | Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY|
 | Non-standard intrinsic functions | AND, OR, XOR, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, GETPID, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC, FREE, GETUID, GETGID |
-| Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SIGNAL, SLEEP, SYSTEM, SYSTEM_CLOCK |
+| Intrinsic subroutines |MVBITS (elemental), CHDIR, CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SIGNAL, SLEEP, SYSTEM, SYSTEM_CLOCK |
 | Atomic intrinsic subroutines | ATOMIC_ADD |
 | Collective intrinsic subroutines | CO_REDUCE |
 | Library subroutines | BACKTRACE, FDATE, GETLOG, GETENV |
@@ -1064,3 +1064,34 @@ This intrinsic is an alias for `LEN_TRIM`, without the optional KIND argument.
 - **Arguments:** `TIME` - a REAL value into which the elapsed CPU time in
                           seconds is written
 - **RETURN value:** same as TIME argument
+
+### Non-Standard Intrinsics: CHDIR
+
+#### Description
+`CHDIR(NAME[, STATUS])` Change current working directory to a specified path.
+
+This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit.
+*STATUS* is `INTENT(OUT)` and provide the following:
+
+|            |                                                                                                   |
+|------------|---------------------------------------------------------------------------------------------------|
+| `NAME`     | The type shall be `CHARACTER` of default kind and shall specify a valid path within the file system.       |
+| `STATUS`   | (Optional) Status flag. Returns 0 on success, a system specific and nonzero error code otherwise. The type shall be `INTEGER` and of the default kind. |
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** Subroutine, function
+- **Syntax:** `CALL CHDIR(NAME[, STATUS])` and `STATUS = CHDIR(NAME)`
+
+#### Example
+```Fortran
+program chdir_func
+  character(len=) :: path
+  integer :: status 
+
+  call chdir("/tmp")
+  status = chdir("..")
+  print *, "status: ", status
+end program chdir_func
+```

flang/include/flang/Optimizer/Builder/IntrinsicCall.h

@@ -210,6 +210,8 @@ struct IntrinsicLibrary {
   mlir::Value genBtest(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genCeiling(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genChar(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genChdir(std::optional<mlir::Type> resultType,
+                              llvm::ArrayRef<fir::ExtendedValue>);
   template <mlir::arith::CmpIPredicate pred>
   fir::ExtendedValue genCharacterCompare(mlir::Type,
                                          llvm::ArrayRef<fir::ExtendedValue>);

flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h

@@ -90,6 +90,10 @@ void genSignal(fir::FirOpBuilder &builder, mlir::Location loc,
 void genSleep(fir::FirOpBuilder &builder, mlir::Location loc,
               mlir::Value seconds);
 
+/// generate chdir runtime call
+mlir::Value genChdir(fir::FirOpBuilder &builder, mlir::Location loc,
+                     mlir::Value name);
+
 } // namespace runtime
 } // namespace fir
 

flang/include/flang/Runtime/extensions.h

@@ -69,5 +69,8 @@ std::int64_t FORTRAN_PROCEDURE_NAME(access)(const char *name,
     std::int64_t nameLength, const char *mode, std::int64_t modeLength);
 #endif
 
+// GNU extension subroutine CHDIR(NAME, [STATUS])
+int RTNAME(Chdir)(const char *name);
+
 } // extern "C"
 #endif // FORTRAN_RUNTIME_EXTENSIONS_H_

flang/lib/Evaluate/intrinsics.cpp

@@ -406,6 +406,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         DefaultLogical},
     {"ceiling", {{"a", AnyReal}, DefaultingKIND}, KINDInt},
     {"char", {{"i", AnyInt, Rank::elementalOrBOZ}, DefaultingKIND}, KINDChar},
+    {"chdir", {{"name", DefaultChar, Rank::scalar, Optionality::required}},
+        DefaultInt},
     {"cmplx", {{"x", AnyComplex}, DefaultingKIND}, KINDComplex},
     {"cmplx",
         {{"x", AnyIntUnsignedOrReal, Rank::elementalOrBOZ},
@@ -1413,6 +1415,11 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"stat", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
+    {"chdir",
+        {{"name", DefaultChar, Rank::scalar, Optionality::required},
+            {"status", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"co_broadcast",
         {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required,
              common::Intent::InOut},
@@ -2742,8 +2749,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"s}, {"getcwd"s}, {"rename"s}, {"second"s}, {"system"s}};
+  static const std::string dualIntrinsic[]{{"chdir"s}, {"etime"s}, {"getcwd"s},
+      {"rename"s}, {"second"s}, {"system"s}};
 
   return llvm::is_contained(dualIntrinsic, name);
 }

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -205,6 +205,10 @@ static constexpr IntrinsicHandler handlers[]{
     {"c_ptr_ne", &I::genCPtrCompare<mlir::arith::CmpIPredicate::ne>},
     {"ceiling", &I::genCeiling},
     {"char", &I::genChar},
+    {"chdir",
+     &I::genChdir,
+     {{{"name", asAddr}, {"status", asAddr, handleDynamicOptional}}},
+     /*isElemental=*/false},
     {"cmplx",
      &I::genCmplx,
      {{{"x", asValue}, {"y", asValue, handleDynamicOptional}}}},
@@ -3186,6 +3190,35 @@ IntrinsicLibrary::genChar(mlir::Type type,
   return fir::CharBoxValue{cast, len};
 }
 
+// CHDIR
+fir::ExtendedValue
+IntrinsicLibrary::genChdir(std::optional<mlir::Type> resultType,
+                           llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert((args.size() == 1 && resultType.has_value()) ||
+         (args.size() >= 1 && !resultType.has_value()));
+  mlir::Value name = fir::getBase(args[0]);
+  mlir::Value status = fir::runtime::genChdir(builder, loc, name);
+
+  if (resultType.has_value()) {
+    return status;
+  } else {
+    // Subroutine form, store status and return none.
+    if (!isStaticallyAbsent(args[1])) {
+      mlir::Value statusAddr = fir::getBase(args[1]);
+      statusAddr.dump();
+      mlir::Value statusIsPresentAtRuntime =
+          builder.genIsNotNullAddr(loc, statusAddr);
+      builder.genIfThen(loc, statusIsPresentAtRuntime)
+          .genThen([&]() {
+            builder.createStoreWithConvert(loc, status, statusAddr);
+          })
+          .end();
+    }
+  }
+
+  return {};
+}
+
 // CMPLX
 mlir::Value IntrinsicLibrary::genCmplx(mlir::Type resultType,
                                        llvm::ArrayRef<mlir::Value> args) {

flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp

@@ -384,3 +384,13 @@ void fir::runtime::genSleep(fir::FirOpBuilder &builder, mlir::Location loc,
       fir::runtime::getRuntimeFunc<mkRTKey(Sleep)>(loc, builder)};
   builder.create<fir::CallOp>(loc, func, seconds);
 }
+
+/// generate chdir runtime call
+mlir::Value fir::runtime::genChdir(fir::FirOpBuilder &builder,
+                                   mlir::Location loc, mlir::Value name) {
+  mlir::func::FuncOp func{
+      fir::runtime::getRuntimeFunc<mkRTKey(Chdir)>(loc, builder)};
+  llvm::SmallVector<mlir::Value> args =
+      fir::runtime::createArguments(builder, loc, func.getFunctionType(), name);
+  return builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}

flang/runtime/extensions.cpp

@@ -51,7 +51,9 @@ inline void CtimeBuffer(char *buffer, size_t bufsize, const time_t cur_time,
 
 #ifndef _WIN32
 // posix-compliant and has getlogin_r and F_OK
-#include <unistd.h> 
+#include <unistd.h>
+#else
+#include <direct.h>
 #endif
 
 extern "C" {
@@ -248,5 +250,15 @@ std::int64_t FORTRAN_PROCEDURE_NAME(access)(const char *name,
 }
 #endif
 
+// CHDIR(DIR)
+int RTNAME(Chdir)(const char *name) {
+// chdir alias seems to be deprecated on Windows.
+#ifndef _WIN32
+  return chdir(name);
+#else
+  return _chdir(name);
+#endif
+}
+
 } // namespace Fortran::runtime
 } // extern "C"

flang/test/Lower/Intrinsics/chdir.f90

@@ -0,0 +1,94 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
+
+subroutine test_chdir()
+  implicit none
+! CHECK-LABEL:   func.func @_QPtest_chdir() {
+
+  call chdir("..")
+! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QQclX2E2E) : !fir.ref<!fir.char<1,2>>
+! CHECK:  %[[C_2:.*]] = arith.constant 2 : index
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] typeparams %[[C_2]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = "_QQclX2E2E"} : (!fir.ref<!fir.char<1,2>>, index) -> (!fir.ref<!fir.char<1,2>>, !fir.ref<!fir.char<1,2>>)
+! CHECK:  %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#1 : (!fir.ref<!fir.char<1,2>>) -> !fir.ref<i8>
+! CHECK:  %[[VAL_3:.*]] = fir.call @_FortranAChdir(%[[VAL_2]]) fastmath<contract> : (!fir.ref<i8>) -> i32
+end subroutine
+
+subroutine test_chdir_subroutine_status_i4()
+  implicit none
+  integer(4) :: stat
+! CHECK-LABEL:   func.func @_QPtest_chdir_subroutine_status_i4() {
+
+  call chdir("..", STATUS=stat)
+! CHECK:  %[[VAL_0:.*]] = fir.alloca i32 {bindc_name = "stat", uniq_name = "_QFtest_chdir_subroutine_status_i4Estat"}
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_chdir_subroutine_status_i4Estat"} : (!fir.ref<i32>) ->
+! (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK:  %[[VAL_2:.*]] = fir.address_of(@_QQclX2E2E) : !fir.ref<!fir.char<1,2>>
+! CHECK:  %[[C_2:.*]] = arith.constant 2 : index
+! CHECK:  %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[C_2]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = {{.*}} : (!fir.ref<!fir.char<1,2>>, index) -> (!fir.ref<!fir.char<1,2>>, !fir.ref<!fir.char<1,2>>)
+! CHECK:  %[[VAL_4:.*]] = fir.convert %[[VAL_3]]#1 : (!fir.ref<!fir.char<1,2>>) -> !fir.ref<i8>
+! CHECK:  %[[VAL_5:.*]] = fir.call @_FortranAChdir(%[[VAL_4]]) fastmath<contract> : (!fir.ref<i8>) -> i32
+! CHECK:  %[[VAL_6:.*]] = fir.convert %{{.*}} : (!fir.ref<i32>) -> i64
+! CHECK:  %[[C_0_I64:.*]] = arith.constant 0 : i64
+! CHECK:  %[[VAL_7:.*]] = arith.cmpi ne, %[[VAL_6]], %[[C_0_I64]] : i64
+! CHECK: fir.if %[[VAL_7]] {
+! CHECK:   fir.store %[[VAL_5]] to %[[VAL_1]]#1 : !fir.ref<i32>
+! CHECK: }
+end subroutine
+
+subroutine test_chdir_function_status_i4()
+  implicit none
+  integer(4) :: stat
+! CHECK-LABEL:   func.func @_QPtest_chdir_function_status_i4() {
+
+  stat = chdir("..")
+! CHECK:  %[[VAL_0:.*]] = fir.alloca i32 {bindc_name = "stat", uniq_name = "_QFtest_chdir_function_status_i4Estat"}
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_chdir_function_status_i4Estat"} : (!fir.ref<i32>) ->
+! (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK:  %[[VAL_2:.*]] = fir.address_of(@_QQclX2E2E) : !fir.ref<!fir.char<1,2>>
+! CHECK:  %[[C_2:.*]] = arith.constant 2 : index
+! CHECK:  %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[C_2]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = {{.*}} : (!fir.ref<!fir.char<1,2>>, index) -> (!fir.ref<!fir.char<1,2>>, !fir.ref<!fir.char<1,2>>)
+! CHECK:  %[[VAL_4:.*]] = fir.convert %[[VAL_3]]#1 : (!fir.ref<!fir.char<1,2>>) -> !fir.ref<i8>
+! CHECK:  %[[VAL_5:.*]] = fir.call @_FortranAChdir(%[[VAL_4]]) fastmath<contract> : (!fir.ref<i8>) -> i32
+! CHECK: hlfir.assign %[[VAL_5]] to %[[VAL_1]]#0 : i32, !fir.ref<i32>
+end subroutine
+
+subroutine test_chdir_subroutine_status_i8()
+  implicit none
+  integer(8) :: stat
+! CHECK-LABEL:   func.func @_QPtest_chdir_subroutine_status_i8() {
+
+  call chdir("..", STATUS=stat)
+! CHECK:  %[[VAL_0:.*]] = fir.alloca i64 {bindc_name = "stat", uniq_name = "_QFtest_chdir_subroutine_status_i8Estat"}
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_chdir_subroutine_status_i8Estat"} : (!fir.ref<i64>) ->
+! (!fir.ref<i64>, !fir.ref<i64>)
+! CHECK:  %[[VAL_2:.*]] = fir.address_of(@_QQclX2E2E) : !fir.ref<!fir.char<1,2>>
+! CHECK:  %[[C_2:.*]] = arith.constant 2 : index
+! CHECK:  %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[C_2]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = {{.*}} : (!fir.ref<!fir.char<1,2>>, index) -> (!fir.ref<!fir.char<1,2>>, !fir.ref<!fir.char<1,2>>)
+! CHECK:  %[[VAL_4:.*]] = fir.convert %{{.*}} : (!fir.ref<!fir.char<1,2>>) -> !fir.ref<i8>
+! CHECK:  %[[VAL_5:.*]] = fir.call @_FortranAChdir(%[[VAL_4]]) fastmath<contract> : (!fir.ref<i8>) -> i32
+! CHECK:  %[[VAL_6:.*]] = fir.convert %[[VAL_1]]#1 : (!fir.ref<i64>) -> i64
+! CHECK:  %[[C_0_I64:.*]] = arith.constant 0 : i64
+! CHECK:  %[[VAL_7:.*]] = arith.cmpi ne, %[[VAL_6]], %[[C_0_I64]] : i64
+! CHECK: fir.if %[[VAL_7]] {
+! CHECK:  %[[VAL_8:.*]] = fir.convert %[[VAL_5]] : (i32) -> i64
+! CHECK:   fir.store %[[VAL_8]] to %[[VAL_1]]#1 : !fir.ref<i64>
+! CHECK: }
+end subroutine
+
+subroutine test_chdir_function_status_i8()
+  implicit none
+  integer(8) :: stat
+! CHECK-LABEL:   func.func @_QPtest_chdir_function_status_i8() {
+
+  stat = chdir("..")
+! CHECK:  %[[VAL_0:.*]] = fir.alloca i64 {bindc_name = "stat", uniq_name = "_QFtest_chdir_function_status_i8Estat"}
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_chdir_function_status_i8Estat"} : (!fir.ref<i64>) ->
+! (!fir.ref<i64>, !fir.ref<i64>)
+! CHECK:  %[[VAL_2:.*]] = fir.address_of(@_QQclX2E2E) : !fir.ref<!fir.char<1,2>>
+! CHECK:  %[[C_2:.*]] = arith.constant 2 : index
+! CHECK:  %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[C_2]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = {{.*}} : (!fir.ref<!fir.char<1,2>>, index) -> (!fir.ref<!fir.char<1,2>>, !fir.ref<!fir.char<1,2>>)
+! CHECK:  %[[VAL_4:.*]] = fir.convert %[[VAL_3]]#1 : (!fir.ref<!fir.char<1,2>>) -> !fir.ref<i8>
+! CHECK:  %[[VAL_5:.*]] = fir.call @_FortranAChdir(%[[VAL_4]]) fastmath<contract> : (!fir.ref<i8>) -> i32
+! CHECK:  %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> i64
+! CHECK: hlfir.assign %[[VAL_6]] to %[[VAL_1]]#0 : i64, !fir.ref<i64>
+end subroutine
+