[flang/flang-rt] Implement PERROR intrinsic form GNU Extension

Author: JDPailleux

flang-rt/lib/runtime/extensions.cpp

@@ -17,6 +17,7 @@
 #include "flang/Runtime/entry-names.h"
 #include "flang/Runtime/io-api.h"
 #include <chrono>
+#include <cstdio>
 #include <cstring>
 #include <ctime>
 #include <signal.h>
@@ -268,5 +269,8 @@ void FORTRAN_PROCEDURE_NAME(qsort)(int *array, int *len, int *isize,
   qsort(array, *len, *isize, compar);
 }
 
+// PERROR(STRING)
+void RTNAME(Perror)(const char *str) { perror(str); }
+
 } // namespace Fortran::runtime
 } // extern "C"

flang/docs/Intrinsics.md

@@ -1137,3 +1137,15 @@ by `ISIZE`.
 - **Standard:** lib3f (section 3f of old man pages).
 - **Class:** subroutine
 - **Syntax:** `CALL QSORT(ARRAY, LEN, ISIZE, COMPAR)`
+
+### Non-Standard Intrinsics: PERROR
+
+#### Description
+`PERROR(STRING)` prints (on the C stderr stream) a newline-terminated error message corresponding to the last system error.
+This is prefixed by `STRING`, a colon and a space.
+
+#### Usage and Info
+
+- **Standard:** GNU extension
+- **Class:** subroutine
+- **Syntax:** `CALL PERROR(STRING)`

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

@@ -371,6 +371,7 @@ struct IntrinsicLibrary {
   fir::ExtendedValue genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genPack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genParity(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  void genPerror(llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genPopcnt(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genPoppar(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genPresent(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 Perror runtime function which implements
+/// the PERROR GNU intrinsic.
+void genPerror(fir::FirOpBuilder &builder, mlir::Location loc,
+               mlir::Value string);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_COMMAND_H

flang/include/flang/Runtime/extensions.h

@@ -75,5 +75,8 @@ int RTNAME(Chdir)(const char *name);
 // GNU extension function IERRNO()
 int FORTRAN_PROCEDURE_NAME(ierrno)();
 
+// GNU extension subroutine PERROR(STRING)
+void RTNAME(Perror)(const char *str);
+
 } // extern "C"
 #endif // FORTRAN_RUNTIME_EXTENSIONS_H_

flang/lib/Evaluate/intrinsics.cpp

@@ -1555,6 +1555,8 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
         {}, Rank::elemental, IntrinsicClass::pureSubroutine},
+    {"perror", {{"string", DefaultChar, Rank::scalar}}, {}, Rank::elemental,
+        IntrinsicClass::impureSubroutine},
     {"mvbits",
         {{"from", SameIntOrUnsigned}, {"frompos", AnyInt}, {"len", AnyInt},
             {"to", SameIntOrUnsigned, Rank::elemental, Optionality::required,

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

@@ -749,6 +749,10 @@ static constexpr IntrinsicHandler handlers[]{
      &I::genParity,
      {{{"mask", asBox}, {"dim", asValue}}},
      /*isElemental=*/false},
+    {"perror",
+     &I::genPerror,
+     {{{"string", asBox}}},
+     /*isElemental*/ false},
     {"popcnt", &I::genPopcnt},
     {"poppar", &I::genPoppar},
     {"present",
@@ -7085,6 +7089,17 @@ IntrinsicLibrary::genParity(mlir::Type resultType,
   return readAndAddCleanUp(resultMutableBox, resultType, "PARITY");
 }
 
+// PERROR
+void IntrinsicLibrary::genPerror(llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+
+  fir::ExtendedValue str = args[0];
+  const auto *box = str.getBoxOf<fir::BoxValue>();
+  mlir::Value addr =
+      builder.create<fir::BoxAddrOp>(loc, box->getMemTy(), fir::getBase(*box));
+  fir::runtime::genPerror(builder, loc, addr);
+}
+
 // POPCNT
 mlir::Value IntrinsicLibrary::genPopcnt(mlir::Type resultType,
                                         llvm::ArrayRef<mlir::Value> args) {

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

@@ -10,6 +10,7 @@
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Runtime/command.h"
+#include "flang/Runtime/extensions.h"
 
 using namespace Fortran::runtime;
 
@@ -101,3 +102,13 @@ mlir::Value fir::runtime::genGetCwd(fir::FirOpBuilder &builder,
       builder, loc, runtimeFuncTy, cwd, sourceFile, sourceLine);
   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
 }
+
+void fir::runtime::genPerror(fir::FirOpBuilder &builder, mlir::Location loc,
+                             mlir::Value string) {
+  auto runtimeFunc =
+      fir::runtime::getRuntimeFunc<mkRTKey(Perror)>(loc, builder);
+  mlir::FunctionType runtimeFuncTy = runtimeFunc.getFunctionType();
+  llvm::SmallVector<mlir::Value> args =
+      fir::runtime::createArguments(builder, loc, runtimeFuncTy, string);
+  builder.create<fir::CallOp>(loc, runtimeFunc, args);
+}

flang/test/Lower/Intrinsics/perror.f90

@@ -0,0 +1,45 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck --check-prefixes=CHECK %s
+! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck --check-prefixes=CHECK %s
+
+! CHECK-LABEL: func @_QPtest_perror(
+subroutine test_perror()
+  character(len=10) :: string
+  character(len=1) :: one
+  ! CHECK: %[[C6:.*]] = arith.constant 6 : index
+  ! CHECK: %[[C10:.*]] = arith.constant 10 : index
+  ! CHECK: %[[C1:.*]] = arith.constant 1 : index
+  ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.char<1> {bindc_name = "one", uniq_name = "_QFtest_perrorEone"}
+  ! CHECK: %[[VAL_1:.*]] = fir.declare %[[VAL_0]] typeparams %[[C1]] {uniq_name = "_QFtest_perrorEone"} : (!fir.ref<!fir.char<1>>, index) -> !fir.ref<!fir.char<1>>
+  ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.char<1,10> {bindc_name = "string", uniq_name = "_QFtest_perrorEstring"}
+  ! CHECK: %[[VAL_3:.*]] = fir.declare %[[VAL_2]] typeparams %[[C10]] {uniq_name = "_QFtest_perrorEstring"} : (!fir.ref<!fir.char<1,10>>, index) -> !fir.ref<!fir.char<1,10>>
+  
+  call perror(string)
+  ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_4]]) fastmath<contract> : (!fir.ref<i8>) -> () 
+  
+  call perror("prefix")
+  ! CHECK: %[[VAL_5:.*]] = fir.address_of(@{{.*}}) : !fir.ref<!fir.char<1,6>>
+  ! CHECK:  %[[VAL_6:.*]] = fir.declare %[[VAL_5]] typeparams %[[C6]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = {{.*}}} : (!fir.ref<!fir.char<1,6>>, index) -> !fir.ref<!fir.char<1,6>>
+  ! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (!fir.ref<!fir.char<1,6>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_7]]) fastmath<contract> : (!fir.ref<i8>) -> () 
+  
+  call perror(one)
+  ! CHECK: %[[VAL_8:.*]] = fir.convert %1 : (!fir.ref<!fir.char<1>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_8]]) fastmath<contract> : (!fir.ref<i8>) -> () 
+end subroutine test_perror
+
+! CHECK-LABEL: func @_QPtest_perror_unknown_length(
+! CHECK-SAME: %[[ARG0:.*]]:  !fir.boxchar<1> {fir.bindc_name = "str"}
+subroutine test_perror_unknown_length(str)
+    implicit none
+    character(len=*), intent(in) :: str
+
+  call perror(str)
+  ! CHECK: %[[VAL_0:.*]] = fir.dummy_scope : !fir.dscope
+  ! CHECK: %[[VAL_1:.*]]:2 = fir.unboxchar %[[ARG0]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+  ! CHECK: %[[VAL_2:.*]] = fir.declare %[[VAL_1]]#0 typeparams %[[VAL_1]]#1 dummy_scope %[[VAL_0]] {fortran_attrs = #fir.var_attrs<intent_in>, uniq_name = "_QFtest_perror_unknown_lengthEstr"} : (!fir.ref<!fir.char<1,?>>, index, !fir.dscope) -> !fir.ref<!fir.char<1,?>>
+  ! CHECK: %[[VAL_3:.*]] = fir.emboxchar %[[VAL_2]], %[[VAL_1]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+  ! CHECK: fir.call @_FortranAPerror(%[[VAL_4]]) fastmath<contract> : (!fir.ref<i8>) -> ()
+  ! CHECK: return
+end subroutine test_perror_unknown_length