[flang-commits] [flang] 513a91a - [flang/flang-rt] Implement PERROR intrinsic form GNU Extension (#132406)
via flang-commits
flang-commits at lists.llvm.org
Tue Apr 1 06:47:58 PDT 2025
Author: Jean-Didier PAILLEUX
Date: 2025-04-01T15:47:54+02:00
New Revision: 513a91a5f155746c7323a555a6e5ad0505627ca7
URL: https://github.com/llvm/llvm-project/commit/513a91a5f155746c7323a555a6e5ad0505627ca7
DIFF: https://github.com/llvm/llvm-project/commit/513a91a5f155746c7323a555a6e5ad0505627ca7.diff
LOG: [flang/flang-rt] Implement PERROR intrinsic form GNU Extension (#132406)
Add the implementation of the `PERROR(STRING) ` intrinsic from the GNU
Extension to prints on the stderr a newline-terminated error message
corresponding to the last system error prefixed by `STRING`.
(https://gcc.gnu.org/onlinedocs/gfortran/PERROR.html)
Added:
flang/test/Lower/Intrinsics/perror.f90
Modified:
flang-rt/lib/runtime/extensions.cpp
flang/docs/Intrinsics.md
flang/include/flang/Optimizer/Builder/IntrinsicCall.h
flang/include/flang/Optimizer/Builder/Runtime/Command.h
flang/include/flang/Runtime/extensions.h
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Optimizer/Builder/IntrinsicCall.cpp
flang/lib/Optimizer/Builder/Runtime/Command.cpp
Removed:
################################################################################
diff --git a/flang-rt/lib/runtime/extensions.cpp b/flang-rt/lib/runtime/extensions.cpp
index 7e9e512778a75..618e184e28519 100644
--- a/flang-rt/lib/runtime/extensions.cpp
+++ b/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"
diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index b09de8ee77645..ddb053d7a3d0b 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -1175,3 +1175,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)`
diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
index cdbb78224e3b4..83f08bb88f7f3 100644
--- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
+++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
@@ -373,6 +373,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>);
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Command.h b/flang/include/flang/Optimizer/Builder/Runtime/Command.h
index d896393ce02f7..ba0d3b094f40c 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Command.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Command.h
@@ -63,5 +63,10 @@ mlir::Value genGetCwd(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value genHostnm(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value res);
+/// 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
diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h
index 4e96f253a6c2c..57de3f8f05948 100644
--- a/flang/include/flang/Runtime/extensions.h
+++ b/flang/include/flang/Runtime/extensions.h
@@ -78,5 +78,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_
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 2f34b12ca80bf..0c15ec5473965 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1573,6 +1573,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,
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index e1e2fa875bff3..0948396ac3fb8 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -753,6 +753,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",
@@ -7158,6 +7162,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) {
diff --git a/flang/lib/Optimizer/Builder/Runtime/Command.cpp b/flang/lib/Optimizer/Builder/Runtime/Command.cpp
index 612599551528f..9b814c3395aa1 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Command.cpp
+++ b/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;
@@ -114,3 +115,13 @@ mlir::Value fir::runtime::genHostnm(fir::FirOpBuilder &builder,
builder, loc, runtimeFuncTy, res, 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);
+}
diff --git a/flang/test/Lower/Intrinsics/perror.f90 b/flang/test/Lower/Intrinsics/perror.f90
new file mode 100644
index 0000000000000..acecf0b996949
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/perror.f90
@@ -0,0 +1,52 @@
+! RUN: bbc -emit-hlfir %s -o - | FileCheck --check-prefixes=CHECK %s
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck --check-prefixes=CHECK %s
+
+! CHECK-LABEL: func @_QPtest_perror(
+subroutine test_perror()
+ character(len=10) :: string
+ character(len=1) :: one
+ ! CHECK: %[[C1:.*]] = arith.constant 1 : index
+ ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.char<1> {bindc_name = "one", uniq_name = "_QFtest_perrorEone"}
+ ! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] typeparams %[[C1]] {uniq_name = "_QFtest_perrorEone"} : (!fir.ref<!fir.char<1>>, index) -> (!fir.ref<!fir.char<1>>, !fir.ref<!fir.char<1>>)
+ ! CHECK: %[[C10:.*]] = arith.constant 10 : index
+ ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.char<1,10> {bindc_name = "string", uniq_name = "_QFtest_perrorEstring"}
+ ! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_2]] typeparams %[[C10]] {uniq_name = "_QFtest_perrorEstring"} : (!fir.ref<!fir.char<1,10>>, index) -> (!fir.ref<!fir.char<1,10>>, !fir.ref<!fir.char<1,10>>)
+
+ call perror(string)
+ ! CHECK: %[[VAL_4:.*]] = fir.embox %[[VAL_3]]#0 : (!fir.ref<!fir.char<1,10>>) -> !fir.box<!fir.char<1,10>>
+ ! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,10>>
+ ! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<i8>
+ ! CHECK: fir.call @_FortranAPerror(%[[VAL_6]]) fastmath<contract> : (!fir.ref<i8>) -> ()
+
+ call perror("prefix")
+ ! CHECK: %[[VAL_7:.*]] = fir.address_of(@{{.*}}) : !fir.ref<!fir.char<1,6>>
+ ! CHECK: %[[C6:.*]] = arith.constant 6 : index
+ ! CHECK: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_7]] typeparams %[[C6]] {fortran_attrs = #fir.var_attrs<parameter>, uniq_name = {{.*}}} : (!fir.ref<!fir.char<1,6>>, index) -> (!fir.ref<!fir.char<1,6>>, !fir.ref<!fir.char<1,6>>)
+ ! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_8]]#0 : (!fir.ref<!fir.char<1,6>>) -> !fir.box<!fir.char<1,6>>
+ ! CHECK: %[[VAL_10:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box<!fir.char<1,6>>) -> !fir.ref<!fir.char<1,6>>
+ ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.ref<!fir.char<1,6>>) -> !fir.ref<i8>
+ ! CHECK: fir.call @_FortranAPerror(%[[VAL_11]]) fastmath<contract> : (!fir.ref<i8>) -> ()
+
+ call perror(one)
+ ! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<!fir.char<1>>) -> !fir.box<!fir.char<1>>
+ ! CHECK: %[[VAL_13:.*]] = fir.box_addr %[[VAL_12]] : (!fir.box<!fir.char<1>>) -> !fir.ref<!fir.char<1>>
+ ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (!fir.ref<!fir.char<1>>) -> !fir.ref<i8>
+ ! CHECK: fir.call @_FortranAPerror(%[[VAL_14]]) 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:.*]]:2 = hlfir.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.boxchar<1>, !fir.ref<!fir.char<1,?>>)
+ ! CHECK: %[[VAL_3:.*]] = fir.embox %[[VAL_2]]#1 typeparams %[[VAL_1]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+ ! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+ ! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+ ! CHECK: fir.call @_FortranAPerror(%[[VAL_5]]) fastmath<contract> : (!fir.ref<i8>) -> ()
+ ! CHECK: return
+end subroutine test_perror_unknown_length
More information about the flang-commits
mailing list