[flang] Add HOSTNM runtime and lowering intrinsics implementation

flang-rt/lib/runtime/command.cpp

@@ -263,4 +263,39 @@ 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};
+
+#ifdef _WIN32
+
+  DWORD dwSize{sizeof(buf)};
+
+  // Note: Winsock has gethostname(), but use Win32 API GetComputerNameEx(),
+  // in order to avoid adding dependency on Winsock.
+  if (!GetComputerNameEx(ComputerNameDnsHostname, buf, &dwSize)) {
+    status = GetLastError();
+  }
+
+#else
+
+  if (gethostname(buf, sizeof(buf)) < 0) {
+    status = errno;
+  }
+
+#endif
+
+  if (status == 0) {
+    std::int64_t strLen{StringLength(buf)};
+    std::int32_t status{CopyCharsToDescriptor(res, buf, strLen)};
+  }
+
+  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 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 {};
+}
+
 /// 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/Intrinsics/hostnm-linux-func.f90

@@ -0,0 +1,60 @@
+! REQUIRES: system-linux
+
+! Verify that the hostname obtained by HOSTNM() intrinsic is the same
+! as the hostname obtained by directly calling C gethostname().
+
+! RUN: %flang -L"%libdir" %s -o %t
+! RUN: env LD_LIBRARY_PATH="$LD_LIBRARY_PATH:%libdir" %t | FileCheck %s
+
+! CHECK: PASS
+
+program get_hostname_cinterop
+  use, intrinsic :: iso_c_binding, only: c_char, c_int, c_size_t, c_null_char
+  implicit none
+
+  interface
+    function gethostname(name, namelen) bind(C)
+      import :: c_char, c_int, c_size_t
+      integer(c_int) :: gethostname
+      character(kind=c_char), dimension(*) :: name
+      integer(c_size_t), value :: namelen
+    end function gethostname
+  end interface
+
+  integer, parameter :: HOST_NAME_MAX = 255
+  character(kind=c_char), dimension(HOST_NAME_MAX + 1) :: c_hostname
+  character(HOST_NAME_MAX) :: hostname
+  character(HOST_NAME_MAX) :: hostnm_str
+  integer(c_int) :: status, i
+
+  status = gethostname(c_hostname, HOST_NAME_MAX)
+  if (status /= 0) then
+    print *, "Error in gethostname(), status code: ", status
+    error stop
+  end if
+
+  status = hostnm(hostnm_str)
+  if (status /= 0) then
+    print *, "Error in hostnm(), status code: ", status
+    error stop
+  end if
+
+  ! Find the position of the null terminator to convert C string to Fortran string
+  i = 1
+  do while (i <= HOST_NAME_MAX .and. c_hostname(i) /= c_null_char)
+    i = i + 1
+  end do
+
+  hostname = transfer(c_hostname(1:i-1), hostname)
+
+  print *, "Hostname from OS: ", hostname(1:i-1)
+  print *, "Hostname from hostnm(): ", hostnm_str(1:i-1)
+
+  if (hostname /= hostnm_str) then
+    print *, "FAIL"
+  else
+    print *, "PASS"
+  end if
+
+end program get_hostname_cinterop
+

flang/test/Intrinsics/hostnm-linux-sub.f90

@@ -0,0 +1,60 @@
+! REQUIRES: system-linux
+
+! Verify that the hostname obtained by HOSTNM() intrinsic is the same
+! as the hostname obtained by directly calling C gethostname().
+
+! RUN: %flang -L"%libdir" %s -o %t
+! RUN: env LD_LIBRARY_PATH="$LD_LIBRARY_PATH:%libdir" %t | FileCheck %s
+
+! CHECK: PASS
+
+program get_hostname_cinterop
+  use, intrinsic :: iso_c_binding, only: c_char, c_int, c_size_t, c_null_char
+  implicit none
+
+  interface
+    function gethostname(name, namelen) bind(C)
+      import :: c_char, c_int, c_size_t
+      integer(c_int) :: gethostname
+      character(kind=c_char), dimension(*) :: name
+      integer(c_size_t), value :: namelen
+    end function gethostname
+  end interface
+
+  integer, parameter :: HOST_NAME_MAX = 255
+  character(kind=c_char), dimension(HOST_NAME_MAX + 1) :: c_hostname
+  character(HOST_NAME_MAX) :: hostname
+  character(HOST_NAME_MAX) :: hostnm_str
+  integer(c_int) :: status, i
+
+  status = gethostname(c_hostname, HOST_NAME_MAX)
+  if (status /= 0) then
+    print *, "Error in gethostname(), status code: ", status
+    error stop
+  end if
+
+  call hostnm(hostnm_str, status)
+  if (status /= 0) then
+    print *, "Error in hostnm(), status code: ", status
+    error stop
+  end if
+
+  ! Find the position of the null terminator to convert C string to Fortran string
+  i = 1
+  do while (i <= HOST_NAME_MAX .and. c_hostname(i) /= c_null_char)
+    i = i + 1
+  end do
+
+  hostname = transfer(c_hostname(1:i-1), hostname)
+
+  print *, "Hostname from OS: ", hostname(1:i-1)
+  print *, "Hostname from hostnm(): ", hostnm_str(1:i-1)
+
+  if (hostname /= hostnm_str) then
+    print *, "FAIL"
+  else
+    print *, "PASS"
+  end if
+
+end program get_hostname_cinterop
+