[flang] Add HOSTNM runtime and lowering intrinsics implementation

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

flang/docs/Intrinsics.md

@@ -1,9 +1,9 @@
-<!--===- docs/Intrinsics.md 
-  
+<!--===- docs/Intrinsics.md
+
    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
-  
+
 -->
 
 # 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("..")

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 <windows.h>
 
 #endif // _WIN32

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

@@ -277,6 +277,8 @@ struct IntrinsicLibrary {
                         llvm::ArrayRef<mlir::Value> args);
   mlir::Value genGetUID(mlir::Type resultType,
                         llvm::ArrayRef<mlir::Value> args);
+  fir::ExtendedValue genHostnm(std::optional<mlir::Type> resultType,
+                               llvm::ArrayRef<fir::ExtendedValue> args);
   fir::ExtendedValue genIall(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genIand(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genIany(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);

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

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
 

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)

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);
 }

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<mlir::Type> resultType,
+                            llvm::ArrayRef<fir::ExtendedValue> 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 <typename FD>

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<fir::CallOp>(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<mkRTKey(Hostnm)>(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, res, sourceFile, sourceLine);
+  return builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}

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<i32>{{.*}}
+  !CHECK-DAG:   %[[line:.*]] = arith.constant {{.*}} : i32
+  !CHECK-DAG:   %[[hn:.*]] = fir.convert {{.*}} (!fir.box<!fir.char<1,255>>) -> !fir.box<none>
+  !CHECK-DAG:   %[[src_path:.*]] = fir.convert {{.*}} (!fir.ref<!fir.char<1,{{.*}} -> !fir.ref<i8>
+  !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

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.char<1,255>>) -> !fir.box<none>
+  !CHECK-DAG:     %[[src_path:.*]] = fir.convert {{.*}} (!fir.ref<!fir.char<1,{{.*}} -> !fir.ref<i8>
+  !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<i32> {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.char<1,255>>) -> !fir.box<none>
+  !CHECK-DAG: %[[src_path:.*]] = fir.convert {{.*}} (!fir.ref<!fir.char<1,{{.*}} -> !fir.ref<i8>
+  !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<i32>
+  call hostnm(hn, status)
+end subroutine all_arguments

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