From 2c8e26081fc5a023471622ddc98638431c66ac6f Mon Sep 17 00:00:00 2001 From: Eugene Epshteyn Date: Tue, 25 Mar 2025 13:17:17 -0400 Subject: [PATCH] [flang] Add HOSTNM runtime and lowering intrinsics implementation (#131910) Implement GNU extension intrinsic HOSTNM, both function and subroutine forms. Add HOSTNM documentation to `flang/docs/Intrinsics.md`. Add lowering and semantic unit tests. (This change is modeled after GETCWD implementation.) --- flang-rt/lib/runtime/command.cpp | 44 +++++++++++++++++++ flang/docs/Intrinsics.md | 44 ++++++++++++++++--- flang/include/flang/Common/windows-include.h | 4 ++ .../flang/Optimizer/Builder/IntrinsicCall.h | 2 + .../flang/Optimizer/Builder/Runtime/Command.h | 5 +++ flang/include/flang/Runtime/command.h | 4 ++ flang/include/flang/Runtime/extensions.h | 3 ++ flang/lib/Evaluate/intrinsics.cpp | 12 ++++- flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 35 +++++++++++++++ .../lib/Optimizer/Builder/Runtime/Command.cpp | 13 ++++++ flang/test/Lower/Intrinsics/hostnm-func.f90 | 23 ++++++++++ flang/test/Lower/Intrinsics/hostnm-sub.f90 | 38 ++++++++++++++++ flang/test/Semantics/hostnm.f90 | 42 ++++++++++++++++++ 13 files changed, 262 insertions(+), 7 deletions(-) create mode 100644 flang/test/Lower/Intrinsics/hostnm-func.f90 create mode 100644 flang/test/Lower/Intrinsics/hostnm-sub.f90 create mode 100644 flang/test/Semantics/hostnm.f90 diff --git a/flang-rt/lib/runtime/command.cpp b/flang-rt/lib/runtime/command.cpp index 9ada5bd59c0b..d2e09639fdb5 100644 --- a/flang-rt/lib/runtime/command.cpp +++ b/flang-rt/lib/runtime/command.cpp @@ -263,4 +263,48 @@ std::int32_t RTNAME(GetCwd)( return status; } +std::int32_t RTNAME(Hostnm)( + const Descriptor &res, const char *sourceFile, int line) { + Terminator terminator{sourceFile, line}; + + RUNTIME_CHECK(terminator, IsValidCharDescriptor(&res)); + + char buf[256]; + std::int32_t status{0}; + + // Fill the output with spaces. Upon success, CopyCharsToDescriptor() + // will overwrite part of the string with the result, so we'll end up + // with a padded string. If we fail to obtain the host name, we return + // the string of all spaces, which is the original gfortran behavior. + FillWithSpaces(res); + +#ifdef _WIN32 + + DWORD dwSize{sizeof(buf)}; + + // Note: Winsock has gethostname(), but use Win32 API GetComputerNameEx(), + // in order to avoid adding dependency on Winsock. + if (!GetComputerNameExA(ComputerNameDnsHostname, buf, &dwSize)) { + status = GetLastError(); + } + +#else + + if (gethostname(buf, sizeof(buf)) < 0) { + status = errno; + } + +#endif + + if (status == 0) { + std::int64_t strLen{StringLength(buf)}; + status = CopyCharsToDescriptor(res, buf, strLen); + + // Note: if the result string is too short, then we'll return partial + // host name with "too short" error status. + } + + return status; +} + } // namespace Fortran::runtime diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md index eb09d550504d..c5c45c2f87d3 100644 --- a/flang/docs/Intrinsics.md +++ b/flang/docs/Intrinsics.md @@ -1,9 +1,9 @@ - # A categorization of standard (2018) and extended Fortran intrinsic procedures @@ -703,7 +703,7 @@ CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, LOC MALLOC, FREE ``` -### Library subroutine +### Library subroutine ``` CALL BACKTRACE() CALL FDATE(TIME) @@ -961,7 +961,7 @@ program test_etime call ETIME(tarray, result) print *, result print *, tarray(1) - print *, tarray(2) + print *, tarray(2) do i=1,100000000 ! Just a delay j = i * i - i end do @@ -1003,6 +1003,38 @@ PROGRAM example_getcwd END PROGRAM ``` +### Non-Standard Intrinsics: HOSTNM + +#### Description +`HOSTNM(C, STATUS)` returns the host name of the system. + +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` | The host name of the system. 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 HOSTNM(C, STATUS)`, `STATUS = HOSTNM(C)` + +#### Example +```Fortran +PROGRAM example_hostnm + CHARACTER(len=255) :: hnam + INTEGER :: status + CALL hostnm(hnam, status) + PRINT *, hnam + PRINT *, status +END PROGRAM +``` + + ### Non-standard Intrinsics: RENAME `RENAME(OLD, NEW[, STATUS])` renames/moves a file on the filesystem. @@ -1088,7 +1120,7 @@ This intrinsic is provided in both subroutine and function forms; however, only ```Fortran program chdir_func character(len=) :: path - integer :: status + integer :: status call chdir("/tmp") status = chdir("..") diff --git a/flang/include/flang/Common/windows-include.h b/flang/include/flang/Common/windows-include.h index 75ef4974251f..01bc6fc9eb94 100644 --- a/flang/include/flang/Common/windows-include.h +++ b/flang/include/flang/Common/windows-include.h @@ -18,6 +18,10 @@ #define WIN32_LEAN_AND_MEAN #define NOMINMAX +// Target Windows 2000 and above. This is needed for newer Windows API +// functions, e.g. GetComputerNameExA() +#define _WIN32_WINNT 0x0500 + #include #endif // _WIN32 diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h index 589a936f8b8c..cdbb78224e3b 100644 --- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h +++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h @@ -277,6 +277,8 @@ struct IntrinsicLibrary { llvm::ArrayRef args); mlir::Value genGetUID(mlir::Type resultType, llvm::ArrayRef args); + fir::ExtendedValue genHostnm(std::optional resultType, + llvm::ArrayRef args); fir::ExtendedValue genIall(mlir::Type, llvm::ArrayRef); mlir::Value genIand(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genIany(mlir::Type, llvm::ArrayRef); diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Command.h b/flang/include/flang/Optimizer/Builder/Runtime/Command.h index 0d60a367d999..d896393ce02f 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/Command.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/Command.h @@ -58,5 +58,10 @@ mlir::Value genGetEnvVariable(fir::FirOpBuilder &, mlir::Location, mlir::Value genGetCwd(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value c); +/// Generate a call to the Hostnm runtime function which implements +/// the HOSTNM intrinsic. +mlir::Value genHostnm(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value res); + } // namespace fir::runtime #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COMMAND_H diff --git a/flang/include/flang/Runtime/command.h b/flang/include/flang/Runtime/command.h index 3add66dd50d4..e0069a9bc032 100644 --- a/flang/include/flang/Runtime/command.h +++ b/flang/include/flang/Runtime/command.h @@ -59,6 +59,10 @@ std::int32_t RTNAME(GetEnvVariable)(const Descriptor &name, // Calls getcwd() std::int32_t RTNAME(GetCwd)( const Descriptor &cwd, const char *sourceFile, int line); + +// Calls hostnm() +std::int32_t RTNAME(Hostnm)( + const Descriptor &res, const char *sourceFile, int line); } } // namespace Fortran::runtime diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h index 133194dea87c..4e96f253a6c2 100644 --- a/flang/include/flang/Runtime/extensions.h +++ b/flang/include/flang/Runtime/extensions.h @@ -54,6 +54,9 @@ uid_t RTNAME(GetUID)(); // GNU extension subroutine GETLOG(C). void FORTRAN_PROCEDURE_NAME(getlog)(char *name, std::int64_t length); +// GNU extension subroutine HOSTNM(C) +void FORTRAN_PROCEDURE_NAME(hostnm)(char *name, std::int64_t length); + std::intptr_t RTNAME(Malloc)(std::size_t size); // GNU extension function STATUS = SIGNAL(number, handler) diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index fe691e85ee01..dc0ccd2cb342 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -553,6 +553,10 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ {"getgid", {}, DefaultInt}, {"getpid", {}, DefaultInt}, {"getuid", {}, DefaultInt}, + {"hostnm", + {{"c", DefaultChar, Rank::scalar, Optionality::required, + common::Intent::Out}}, + TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}}, {"huge", {{"x", SameIntUnsignedOrReal, Rank::anyOrAssumedRank, Optionality::required, common::Intent::In, @@ -1545,6 +1549,12 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"status", TypePattern{IntType, KindCode::greaterOrEqualToKind, 4}, Rank::scalar, Optionality::optional, common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"hostnm", + {{"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}, @@ -2765,7 +2775,7 @@ bool IntrinsicProcTable::Implementation::IsDualIntrinsic( // Collection for some intrinsics with function and subroutine form, // in order to pass the semantic check. static const std::string dualIntrinsic[]{{"chdir"s}, {"etime"s}, {"getcwd"s}, - {"rename"s}, {"second"s}, {"system"s}}; + {"hostnm"s}, {"rename"s}, {"second"s}, {"system"s}}; return llvm::is_contained(dualIntrinsic, name); } diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 25d3ef82b83d..e1e2fa875bff 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -480,6 +480,10 @@ static constexpr IntrinsicHandler handlers[]{ {"getgid", &I::genGetGID}, {"getpid", &I::genGetPID}, {"getuid", &I::genGetUID}, + {"hostnm", + &I::genHostnm, + {{{"c", asBox}, {"status", asAddr, handleDynamicOptional}}}, + /*isElemental=*/false}, {"iachar", &I::genIchar}, {"iall", &I::genIall, @@ -4317,6 +4321,37 @@ void IntrinsicLibrary::genGetEnvironmentVariable( } } +// HOSTNM +fir::ExtendedValue +IntrinsicLibrary::genHostnm(std::optional resultType, + llvm::ArrayRef args) { + assert((args.size() == 1 && resultType.has_value()) || + (args.size() >= 1 && !resultType.has_value())); + + mlir::Value res = fir::getBase(args[0]); + mlir::Value statusValue = fir::runtime::genHostnm(builder, loc, res); + + if (resultType.has_value()) { + // Function form, return status. + return builder.createConvert(loc, *resultType, statusValue); + } + + // 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 {}; +} + /// Process calls to Maxval, Minval, Product, Sum intrinsic functions that /// take a DIM argument. template diff --git a/flang/lib/Optimizer/Builder/Runtime/Command.cpp b/flang/lib/Optimizer/Builder/Runtime/Command.cpp index 8320d89493b3..612599551528 100644 --- a/flang/lib/Optimizer/Builder/Runtime/Command.cpp +++ b/flang/lib/Optimizer/Builder/Runtime/Command.cpp @@ -101,3 +101,16 @@ mlir::Value fir::runtime::genGetCwd(fir::FirOpBuilder &builder, builder, loc, runtimeFuncTy, cwd, sourceFile, sourceLine); return builder.create(loc, func, args).getResult(0); } + +mlir::Value fir::runtime::genHostnm(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value res) { + mlir::func::FuncOp func = + fir::runtime::getRuntimeFunc(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 args = fir::runtime::createArguments( + builder, loc, runtimeFuncTy, res, sourceFile, sourceLine); + return builder.create(loc, func, args).getResult(0); +} diff --git a/flang/test/Lower/Intrinsics/hostnm-func.f90 b/flang/test/Lower/Intrinsics/hostnm-func.f90 new file mode 100644 index 000000000000..c2def1148d52 --- /dev/null +++ b/flang/test/Lower/Intrinsics/hostnm-func.f90 @@ -0,0 +1,23 @@ +!RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s + +!CHECK-LABEL: func.func @_QPhostnm_test +!CHECK-SAME: %[[dummyHn:.*]]: !fir.boxchar<1> {fir.bindc_name = "hn"}) -> i32 { +integer function hostnm_test(hn) + CHARACTER(len=255) :: hn + + ! Check that _FortranAHostnm is called with boxed char 255, some other char + ! string of variable length (source file path) and some integer (source line) + !CHECK-DAG: %[[func_result:.*]] = fir.alloca i32 {bindc_name = "hostnm_test", uniq_name = "_QFhostnm_testEhostnm_test"} + !CHECK-DAG: %[[func_result_decl:.*]]:{{.*}} = hlfir.declare %[[func_result]] {uniq_name = "_QFhostnm_testEhostnm_test"} : {{.*}}fir.ref{{.*}} + !CHECK-DAG: %[[line:.*]] = arith.constant {{.*}} : i32 + !CHECK-DAG: %[[hn:.*]] = fir.convert {{.*}} (!fir.box>) -> !fir.box + !CHECK-DAG: %[[src_path:.*]] = fir.convert {{.*}} (!fir.ref !fir.ref + !CHECK: %[[hn_result:.*]] = fir.call @_FortranAHostnm(%[[hn]], %[[src_path]], %[[line]]) + !CHECK-SAME: -> i32 + + ! Check _FortranAHostnm result code handling + !CHECK-DAG: hlfir.assign %[[hn_result]] to %[[func_result_decl]]{{.*}}i32{{.*}} + !CHECK-DAG: %[[load_result:.*]] = fir.load %[[func_result_decl]]{{.*}}i32{{.*}} + !CHECK: return %[[load_result]] : i32 + hostnm_test = hostnm(hn) +end function hostnm_test diff --git a/flang/test/Lower/Intrinsics/hostnm-sub.f90 b/flang/test/Lower/Intrinsics/hostnm-sub.f90 new file mode 100644 index 000000000000..d384e9686222 --- /dev/null +++ b/flang/test/Lower/Intrinsics/hostnm-sub.f90 @@ -0,0 +1,38 @@ +!RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s + +!CHECK-LABEL: func.func @_QPhostnm_only +!CHECK-SAME: %[[dummyHn:.*]]: !fir.boxchar<1> {fir.bindc_name = "hn"}) { +subroutine hostnm_only(hn) + CHARACTER(len=255) :: hn + + ! Check that _FortranAHostnm is called with boxed char 255, some other char + ! string of variable length (source file path) and some integer (source line) + !CHECK-DAG: %[[line:.*]] = arith.constant {{.*}} : i32 + !CHECK-DAG: %[[hn:.*]] = fir.convert {{.*}} (!fir.box>) -> !fir.box + !CHECK-DAG: %[[src_path:.*]] = fir.convert {{.*}} (!fir.ref !fir.ref + !CHECK: fir.call @_FortranAHostnm(%[[hn]], %[[src_path]], %[[line]]) + !CHECK-SAME: -> i32 + call hostnm(hn) +end subroutine hostnm_only + +!CHECK-LABEL: func.func @_QPall_arguments +!CHECK-SAME: %[[dummyHn:.*]]: !fir.boxchar<1> {fir.bindc_name = "hn"}, +!CHECK-SAME: %[[dummyStat:.*]]: !fir.ref {fir.bindc_name = "status"}) { +subroutine all_arguments(hn, status) + CHARACTER(len=255) :: hn + INTEGER :: status + + ! Check that _FortranAHostnm is called with boxed char 255, some other char + ! string of variable length (source file path) and some integer (source line) + !CHECK-DAG: %[[line:.*]] = arith.constant {{.*}} : i32 + !CHECK-DAG: %[[hn:.*]] = fir.convert {{.*}} (!fir.box>) -> !fir.box + !CHECK-DAG: %[[src_path:.*]] = fir.convert {{.*}} (!fir.ref !fir.ref + !CHECK: %[[hn_result:.*]] = fir.call @_FortranAHostnm(%[[hn]], %[[src_path]], %[[line]]) + !CHECK-SAME: -> i32 + + ! Check _FortranAHostnm result code handling + !CHECK-DAG: %[[c0_i64:.*]] = arith.constant 0 : i64 + !CHECK-DAG: %[[cmp_result:.*]] = arith.cmpi ne, {{.*}}, %[[c0_i64]] : i64 + !CHECK: fir.store %[[hn_result]] {{.*}} !fir.ref + call hostnm(hn, status) +end subroutine all_arguments diff --git a/flang/test/Semantics/hostnm.f90 b/flang/test/Semantics/hostnm.f90 new file mode 100644 index 000000000000..c9293a7f7bf8 --- /dev/null +++ b/flang/test/Semantics/hostnm.f90 @@ -0,0 +1,42 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic +! Tests for the HOSTNM 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 hostnm(cwd, status) +end subroutine bad_kind_error + +subroutine bad_args_error() + !ERROR: missing mandatory 'c=' argument + call hostnm() +end subroutine bad_args_error + +subroutine bad_function(cwd) + CHARACTER(len=255) :: cwd + INTEGER :: status + call hostnm(cwd, status) + !ERROR: Cannot call subroutine 'hostnm' like a function + status = hostnm(cwd) +end subroutine bad_function + +subroutine bad_sub(cwd) + CHARACTER(len=255) :: cwd + INTEGER :: status + status = hostnm(cwd) + !ERROR: Cannot call function 'hostnm' like a subroutine + call hostnm(cwd, status) +end subroutine bad_sub + +subroutine good_subroutine(cwd, status) + CHARACTER(len=255) :: cwd + INTEGER :: status + call hostnm(cwd, status) +end subroutine good_subroutine + +subroutine good_function(cwd, status) + CHARACTER(len=255) :: cwd + INTEGER :: status + status = hostnm(cwd) +end subroutine good_function