yggdrasil/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[flang] Add GETCWD runtime and lowering intrinsics implementation (#92746)

Browse Source 
This patch add support of intrinsics GNU extension GETCWD
https://github.com/llvm/llvm-project/issues/84203. Some usage info and
example has been added to `flang/docs/Intrinsics.md`. The patch contains
both the lowering and the runtime code and works on both Windows and
Linux.


|   System   |   Implmentation  |
|-----------|--------------------|
| Windows | _getcwd               |
| Linux       |getcwd                  |
This commit is contained in:
jiajie zhang 2024-06-06 12:28:02 +08:00 committed by GitHub
parent 8c452d0cc5
commit 68413219db
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
14 changed files with 264 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
flang/docs/Intrinsics.md
View File

@ -967,4 +967,35 @@ program test_etime
print *, tarray(1)
print *, tarray(2)
end program test_etime
```
### Non-Standard Intrinsics: GETCWD
#### Description
`GETCWD(C, STATUS)` returns current working directory.
This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit.
*C* and *STATUS* are `INTENT(OUT)` and provide the following:
| | |
|------------|---------------------------------------------------------------------------------------------------|
| `C` | Current work directory. The type shall be `CHARACTER` and of default kind. |
| `STATUS` | (Optional) Status flag. Returns 0 on success, a system specific and nonzero error code otherwise. The type shall be `INTEGER` and of a kind greater or equal to 4. |
#### Usage and Info
- **Standard:** GNU extension
- **Class:** Subroutine, function
- **Syntax:** `CALL GETCWD(C, STATUS)`, `STATUS = GETCWD(C)`
#### Example
```Fortran
PROGRAM example_getcwd
CHARACTER(len=255) :: cwd
INTEGER :: status
CALL getcwd(cwd, status)
PRINT *, cwd
PRINT *, status
END PROGRAM
```

2
flang/include/flang/Optimizer/Builder/IntrinsicCall.h
View File

@ -232,6 +232,8 @@ struct IntrinsicLibrary {
mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
mlir::Value genFraction(mlir::Type resultType,
mlir::ArrayRef<mlir::Value> args);
fir::ExtendedValue genGetCwd(std::optional<mlir::Type> resultType,
llvm::ArrayRef<fir::ExtendedValue> args);
void genGetCommand(mlir::ArrayRef<fir::ExtendedValue> args);
mlir::Value genGetPID(mlir::Type resultType,
llvm::ArrayRef<mlir::Value> args);

5
flang/include/flang/Optimizer/Builder/Runtime/Command.h
View File

@ -53,5 +53,10 @@ mlir::Value genGetEnvVariable(fir::FirOpBuilder &, mlir::Location,
mlir::Value length, mlir::Value trimName,
mlir::Value errmsg);
/// Generate a call to the GetCwd runtime function which implements
/// the GETCWD intrinsic.
mlir::Value genGetCwd(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value c);
} // namespace fir::runtime
#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COMMAND_H

4
flang/include/flang/Runtime/command.h
View File

@ -55,6 +55,10 @@ std::int32_t RTNAME(GetEnvVariable)(const Descriptor &name,
const Descriptor *value = nullptr, const Descriptor *length = nullptr,
bool trim_name = true, const Descriptor *errmsg = nullptr,
const char *sourceFile = nullptr, int line = 0);
// Calls getcwd()
std::int32_t RTNAME(GetCwd)(
const Descriptor &cwd, const char *sourceFile, int line);
}
} // namespace Fortran::runtime

5
flang/include/flang/Runtime/magic-numbers.h
View File

@ -68,6 +68,11 @@ Additional status code for a bad pointer DEALLOCATE.
#endif
#define FORTRAN_RUNTIME_STAT_BAD_POINTER_DEALLOCATION 110
#if 0
Status codes for GETCWD.
#endif
#define FORTRAN_RUNTIME_STAT_MISSING_CWD 111
#if 0
ieee_class_type values
The sequence is that of F18 Clause 17.2p3, but nothing depends on that.

12
flang/lib/Evaluate/intrinsics.cpp
View File

@ -514,6 +514,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"gamma", {{"x", SameReal}}, SameReal},
{"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}},
TeamType, Rank::scalar, IntrinsicClass::transformationalFunction},
{"getcwd",
{{"c", DefaultChar, Rank::scalar, Optionality::required,
common::Intent::Out}},
TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}},
{"getpid", {}, DefaultInt},
{"huge",
{{"x", SameIntOrReal, Rank::anyOrAssumedRank, Optionality::required,
@ -1406,6 +1410,12 @@ static const IntrinsicInterface intrinsicSubroutine[]{
{"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
common::Intent::InOut}},
{}, Rank::elemental, IntrinsicClass::impureSubroutine},
{"getcwd",
{{"c", DefaultChar, Rank::scalar, Optionality::required,
common::Intent::Out},
{"status", TypePattern{IntType, KindCode::greaterOrEqualToKind, 4},
Rank::scalar, Optionality::optional, common::Intent::Out}},
{}, Rank::elemental, IntrinsicClass::impureSubroutine},
{"move_alloc",
{{"from", SameType, Rank::known, Optionality::required,
common::Intent::InOut},
@ -2574,7 +2584,7 @@ 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"}};
static const std::string dualIntrinsic[]{{"etime"}, {"getcwd"}};
return std::find_if(std::begin(dualIntrinsic), std::end(dualIntrinsic),
[&name](const std::string &dualName) {

35
flang/lib/Optimizer/Builder/IntrinsicCall.cpp
View File

@ -280,6 +280,10 @@ static constexpr IntrinsicHandler handlers[]{
{"trim_name", asAddr, handleDynamicOptional},
{"errmsg", asBox, handleDynamicOptional}}},
/*isElemental=*/false},
{"getcwd",
&I::genGetCwd,
{{{"c", asBox}, {"status", asAddr, handleDynamicOptional}}},
/*isElemental=*/false},
{"getpid", &I::genGetPID},
{"iachar", &I::genIchar},
{"iall",
@ -3476,6 +3480,37 @@ mlir::Value IntrinsicLibrary::genFraction(mlir::Type resultType,
fir::runtime::genFraction(builder, loc, fir::getBase(args[0])));
}
// GETCWD
fir::ExtendedValue
IntrinsicLibrary::genGetCwd(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 cwd = fir::getBase(args[0]);
mlir::Value statusValue = fir::runtime::genGetCwd(builder, loc, cwd);
if (resultType.has_value()) {
// Function form, return status.
return statusValue;
} else {
// Subroutine form, store status and return none.
const fir::ExtendedValue &status = args[1];
if (!isStaticallyAbsent(status)) {
mlir::Value statusAddr = fir::getBase(status);
mlir::Value statusIsPresentAtRuntime =
builder.genIsNotNullAddr(loc, statusAddr);
builder.genIfThen(loc, statusIsPresentAtRuntime)
.genThen([&]() {
builder.createStoreWithConvert(loc, statusValue, statusAddr);
})
.end();
}
}
return {};
}
// GET_COMMAND
void IntrinsicLibrary::genGetCommand(llvm::ArrayRef<fir::ExtendedValue> args) {
assert(args.size() == 4);

13
flang/lib/Optimizer/Builder/Runtime/Command.cpp
View File

@ -88,3 +88,16 @@ mlir::Value fir::runtime::genGetEnvVariable(fir::FirOpBuilder &builder,
sourceFile, sourceLine);
return builder.create<fir::CallOp>(loc, runtimeFunc, args).getResult(0);
}
mlir::Value fir::runtime::genGetCwd(fir::FirOpBuilder &builder,
mlir::Location loc, mlir::Value cwd) {
mlir::func::FuncOp func =
fir::runtime::getRuntimeFunc<mkRTKey(GetCwd)>(loc, builder);
auto runtimeFuncTy = func.getFunctionType();
mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
mlir::Value sourceLine =
fir::factory::locationToLineNo(builder, loc, runtimeFuncTy.getInput(2));
llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
builder, loc, runtimeFuncTy, cwd, sourceFile, sourceLine);
return builder.create<fir::CallOp>(loc, func, args).getResult(0);
}

26
flang/runtime/command.cpp
View File

@ -17,12 +17,19 @@
#ifdef _WIN32
#include "flang/Common/windows-include.h"
#include <direct.h>
#define getcwd _getcwd
#define PATH_MAX MAX_PATH
// On Windows GetCurrentProcessId returns a DWORD aka uint32_t
#include <processthreadsapi.h>
inline pid_t getpid() { return GetCurrentProcessId(); }
#else
#include <unistd.h> //getpid()
#ifndef PATH_MAX
#define PATH_MAX 4096
#endif
#endif
namespace Fortran::runtime {
@ -239,4 +246,23 @@ std::int32_t RTNAME(GetEnvVariable)(const Descriptor &name,
return StatOk;
}
std::int32_t RTNAME(GetCwd)(
const Descriptor &cwd, const char *sourceFile, int line) {
Terminator terminator{sourceFile, line};
RUNTIME_CHECK(terminator, IsValidCharDescriptor(&cwd));
char *buf{(char *)AllocateMemoryOrCrash(terminator, PATH_MAX)};
if (!getcwd(buf, PATH_MAX)) {
return StatMissingCurrentWorkDirectory;
}
std::int64_t strLen{StringLength(buf)};
std::int32_t status{CopyCharsToDescriptor(cwd, buf, strLen)};
std::free(buf);
return status;
}
} // namespace Fortran::runtime

1
flang/runtime/stat.h
View File

@ -41,6 +41,7 @@ enum Stat {
StatLocked = FORTRAN_RUNTIME_STAT_LOCKED,
StatLockedOtherImage = FORTRAN_RUNTIME_STAT_LOCKED_OTHER_IMAGE,
StatMissingEnvVariable = FORTRAN_RUNTIME_STAT_MISSING_ENV_VAR,
StatMissingCurrentWorkDirectory = FORTRAN_RUNTIME_STAT_MISSING_CWD,
StatStoppedImage = FORTRAN_RUNTIME_STAT_STOPPED_IMAGE,
StatUnlocked = FORTRAN_RUNTIME_STAT_UNLOCKED,
StatUnlockedFailedImage = FORTRAN_RUNTIME_STAT_UNLOCKED_FAILED_IMAGE,

23
flang/test/Lower/Intrinsics/getcwd-function.f90 Normal file
View File

@ -0,0 +1,23 @@
! Test GETCWD with dynamically optional arguments.
! RUN: bbc -emit-fir %s -o - | FileCheck %s
! CHECK-LABEL: func.func @_QPtest(
! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"}) -> i32 {
integer function test(cwd)
CHARACTER(len=255) :: cwd
test = getcwd(cwd)
! CHECK-NEXT: %[[c8:.*]] = arith.constant 8 : i32
! CHECK-NEXT: %[[c255:.*]] = arith.constant 255 : index
! CHECK-NEXT: %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
! CHECK-NEXT: %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK-NEXT: %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFtestEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[test:.*]] = fir.alloca i32 {bindc_name = "test", uniq_name = "_QFtestEtest"}
! CHECK-NEXT: %[[testAddr:.*]] = fir.declare %[[test]] {uniq_name = "_QFtestEtest"} : (!fir.ref<i32>) -> !fir.ref<i32>
! CHECK-NEXT: %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
! CHECK: %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
! CHECK: %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_9:.*]], %[[c8]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
! CHECK-NEXT: fir.store %[[statusValue]] to %[[testAddr]] : !fir.ref<i32>
! CHECK-NEXT: %[[returnValue:.*]] = fir.load %[[testAddr]] : !fir.ref<i32>
! CHECK-NEXT: return %[[returnValue]] : i32
end function

29
flang/test/Lower/Intrinsics/getcwd-optional.f90 Normal file
View File

@ -0,0 +1,29 @@
! Test GETCWD with dynamically optional arguments.
! RUN: bbc -emit-fir %s -o - | FileCheck %s
! CHECK-LABEL: func.func @_QPtest(
! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"},
! CHECK-SAME: %[[statusArg:.*]]: !fir.ref<i32> {fir.bindc_name = "status", fir.optional}) {
subroutine test(cwd, status)
CHARACTER(len=255) :: cwd
INTEGER, OPTIONAL :: status
call getcwd(cwd, status)
! CHECK-NEXT: %[[c0:.*]] = arith.constant 0 : i64
! CHECK-NEXT: %[[c11:.*]] = arith.constant 11 : i32
! CHECK-NEXT: %[[c255:.*]] = arith.constant 255 : index
! CHECK-NEXT: %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
! CHECK-NEXT: %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK-NEXT: %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFtestEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[statusAddr:.*]] = fir.declare %[[statusArg]] dummy_scope %[[DSCOPE]] {fortran_attrs = #fir.var_attrs<optional>, uniq_name = "_QFtestEstatus"} : (!fir.ref<i32>, !fir.dscope) -> !fir.ref<i32>
! CHECK-NEXT: %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
! CHECK: %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
! CHECK: %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_8:.*]], %[[c11]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
! CHECK-NEXT: %[[statusCast:.*]] = fir.convert %[[statusAddr]] : (!fir.ref<i32>) -> i64
! CHECK-NEXT: %[[isPresent:.*]] = arith.cmpi ne, %[[statusCast]], %[[c0]] : i64
! CHECK-NEXT: fir.if %[[isPresent]] {
! CHECK-NEXT: fir.store %[[statusValue]] to %[[statusAddr]] : !fir.ref<i32>
! CHECK-NEXT: }
! CHECK-NEXT: return
end subroutine

44
flang/test/Lower/Intrinsics/getcwd.f90 Normal file
View File

@ -0,0 +1,44 @@
! RUN: bbc -emit-fir %s -o - | FileCheck %s
! CHECK-LABEL: func.func @_QPcwd_only(
! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"}) {
subroutine cwd_only(cwd)
CHARACTER(len=255) :: cwd
call getcwd(cwd)
! CHECK-NEXT: %[[c7:.*]] = arith.constant 7 : i32
! CHECK-NEXT: %[[c255:.*]] = arith.constant 255 : index
! CHECK-NEXT: %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
! CHECK-NEXT: %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK-NEXT: %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFcwd_onlyEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
! CHECK: %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
! CHECK: %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_7:.*]], %[[c7]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
! CHECK-NEXT: return
end subroutine cwd_only
! CHECK-LABEL: func.func @_QPall_arguments(
! CHECK-SAME: %[[cwdArg:.*]]: !fir.boxchar<1> {fir.bindc_name = "cwd"},
! CHECK-SAME: %[[statusArg:.*]]: !fir.ref<i32> {fir.bindc_name = "status"}) {
subroutine all_arguments(cwd, status)
CHARACTER(len=255) :: cwd
INTEGER :: status
call getcwd(cwd, status)
! CHECK-NEXT: %[[c0:.*]] = arith.constant 0 : i64
! CHECK-NEXT: %[[c26:.*]] = arith.constant 26 : i32
! CHECK-NEXT: %[[c255:.*]] = arith.constant 255 : index
! CHECK-NEXT: %[[DSCOPE:.*]] = fir.dummy_scope : !fir.dscope
! CHECK-NEXT: %[[cwdUnbox:.*]]:2 = fir.unboxchar %[[cwdArg]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
! CHECK-NEXT: %[[cwdCast:.*]] = fir.convert %[[cwdUnbox]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[cwdDeclare:.*]] = fir.declare %[[cwdCast]] typeparams %[[c255]] dummy_scope %[[DSCOPE]] {uniq_name = "_QFall_argumentsEcwd"} : (!fir.ref<!fir.char<1,255>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,255>>
! CHECK-NEXT: %[[statusAddr:.*]] = fir.declare %[[statusArg]] dummy_scope %0 {uniq_name = "_QFall_argumentsEstatus"} : (!fir.ref<i32>, !fir.dscope) -> !fir.ref<i32>
! CHECK-NEXT: %[[cwdBox:.*]] = fir.embox %[[cwdDeclare]] : (!fir.ref<!fir.char<1,255>>) -> !fir.box<!fir.char<1,255>>
! CHECK: %[[cwd:.*]] = fir.convert %[[cwdBox]] : (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
! CHECK: %[[statusValue:.*]] = fir.call @_FortranAGetCwd(%[[cwd]], %[[VAL_8:.*]], %[[c26]]) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> i32
! CHECK-NEXT: %[[statusCast:.*]] = fir.convert %[[statusAddr]] : (!fir.ref<i32>) -> i64
! CHECK-NEXT: %[[isPresent:.*]] = arith.cmpi ne, %[[statusCast]], %[[c0]] : i64
! CHECK-NEXT: fir.if %[[isPresent]] {
! CHECK-NEXT: fir.store %[[statusValue]] to %[[statusAddr]] : !fir.ref<i32>
! CHECK-NEXT: }
! CHECK-NEXT: return
end subroutine all_arguments

35
flang/test/Semantics/getcwd.f90 Normal file
View File

@ -0,0 +1,35 @@
! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Tests for the GETCWD intrinsics
subroutine bad_kind_error(cwd, status)
CHARACTER(len=255) :: cwd
INTEGER(2) :: status
!ERROR: Actual argument for 'status=' has bad type or kind 'INTEGER(2)'
call getcwd(cwd, status)
end subroutine bad_kind_error
subroutine bad_args_error()
!ERROR: missing mandatory 'c=' argument
call getcwd()
end subroutine bad_args_error
subroutine bad_apply_form(cwd)
CHARACTER(len=255) :: cwd
INTEGER :: status
!Declaration of 'getcwd'
call getcwd(cwd, status)
!ERROR: Cannot call subroutine 'getcwd' like a function
status = getcwd(cwd)
end subroutine bad_apply_form
subroutine good_subroutine(cwd, status)
CHARACTER(len=255) :: cwd
INTEGER :: status
call getcwd(cwd, status)
end subroutine good_subroutine
subroutine good_function(cwd, status)
CHARACTER(len=255) :: cwd
INTEGER :: status
status = getcwd(cwd)
end subroutine good_function