From c8bde44cfcc75a8389f1a72917e0aadc125f5e22 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Fri, 4 Apr 2025 08:40:51 -0700 Subject: [PATCH] [flang] Implement FSEEK and FTELL (#133003) Add function and subroutine forms of FSEEK and FTELL as intrinsic procedures. Accept common aliases from legacy compilers as well. A separate patch to llvm-test-suite will enable tests for these procedures once this patch has merged. Depends on https://github.com/llvm/llvm-project/pull/132423; CI builds will likely fail until that patch is merged and this PR is rebased. --- flang-rt/lib/runtime/extensions.cpp | 30 ++++++++ flang-rt/lib/runtime/unit.cpp | 45 +++++++++-- flang-rt/lib/runtime/unit.h | 14 +++- flang/docs/Intrinsics.md | 38 ++++++++++ .../flang/Optimizer/Builder/IntrinsicCall.h | 4 + .../Optimizer/Builder/Runtime/Intrinsics.h | 5 ++ flang/include/flang/Runtime/extensions.h | 5 ++ flang/lib/Evaluate/intrinsics.cpp | 32 ++++++-- flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 74 +++++++++++++++++++ .../Optimizer/Builder/Runtime/Intrinsics.cpp | 24 ++++++ 10 files changed, 255 insertions(+), 16 deletions(-) diff --git a/flang-rt/lib/runtime/extensions.cpp b/flang-rt/lib/runtime/extensions.cpp index a73279e44579..6b553ff97e5a 100644 --- a/flang-rt/lib/runtime/extensions.cpp +++ b/flang-rt/lib/runtime/extensions.cpp @@ -10,12 +10,14 @@ // extensions that will eventually be implemented in Fortran. #include "flang/Runtime/extensions.h" +#include "unit.h" #include "flang-rt/runtime/descriptor.h" #include "flang-rt/runtime/terminator.h" #include "flang-rt/runtime/tools.h" #include "flang/Runtime/command.h" #include "flang/Runtime/entry-names.h" #include "flang/Runtime/io-api.h" +#include "flang/Runtime/iostat-consts.h" #include #include #include @@ -275,5 +277,33 @@ void RTNAME(Perror)(const char *str) { perror(str); } // GNU extension function TIME() std::int64_t RTNAME(time)() { return time(nullptr); } +// Extension procedures related to I/O + +namespace io { +std::int32_t RTNAME(Fseek)(int unitNumber, std::int64_t zeroBasedPos, + int whence, const char *sourceFileName, int lineNumber) { + if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) { + Terminator terminator{sourceFileName, lineNumber}; + IoErrorHandler handler{terminator}; + if (unit->Fseek( + zeroBasedPos, static_cast(whence), handler)) { + return IostatOk; + } else { + return IostatCannotReposition; + } + } else { + return IostatBadUnitNumber; + } +} + +std::int64_t RTNAME(Ftell)(int unitNumber) { + if (ExternalFileUnit * unit{ExternalFileUnit::LookUp(unitNumber)}) { + return unit->InquirePos() - 1; // zero-based result + } else { + return -1; + } +} +} // namespace io + } // namespace Fortran::runtime } // extern "C" diff --git a/flang-rt/lib/runtime/unit.cpp b/flang-rt/lib/runtime/unit.cpp index 43501aeb4845..199287d7237f 100644 --- a/flang-rt/lib/runtime/unit.cpp +++ b/flang-rt/lib/runtime/unit.cpp @@ -441,14 +441,14 @@ void ExternalFileUnit::Rewind(IoErrorHandler &handler) { "REWIND(UNIT=%d) on non-sequential file", unitNumber()); } else { DoImpliedEndfile(handler); - SetPosition(0, handler); + SetPosition(0); currentRecordNumber = 1; leftTabLimit.reset(); anyWriteSinceLastPositioning_ = false; } } -void ExternalFileUnit::SetPosition(std::int64_t pos, IoErrorHandler &handler) { +void ExternalFileUnit::SetPosition(std::int64_t pos) { frameOffsetInFile_ = pos; recordOffsetInFrame_ = 0; if (access == Access::Direct) { @@ -457,6 +457,18 @@ void ExternalFileUnit::SetPosition(std::int64_t pos, IoErrorHandler &handler) { BeginRecord(); } +void ExternalFileUnit::Sought(std::int64_t zeroBasedPos) { + SetPosition(zeroBasedPos); + if (zeroBasedPos == 0) { + currentRecordNumber = 1; + } else { + // We no longer know which record we're in. Set currentRecordNumber to + // a large value from whence we can both advance and backspace. + currentRecordNumber = std::numeric_limits::max() / 2; + endfileRecordNumber.reset(); + } +} + bool ExternalFileUnit::SetStreamPos( std::int64_t oneBasedPos, IoErrorHandler &handler) { if (access != Access::Stream) { @@ -474,14 +486,31 @@ bool ExternalFileUnit::SetStreamPos( frameOffsetInFile_ + recordOffsetInFrame_) { DoImpliedEndfile(handler); } - SetPosition(oneBasedPos - 1, handler); - // We no longer know which record we're in. Set currentRecordNumber to - // a large value from whence we can both advance and backspace. - currentRecordNumber = std::numeric_limits::max() / 2; - endfileRecordNumber.reset(); + Sought(oneBasedPos - 1); return true; } +// GNU FSEEK extension +RT_API_ATTRS bool ExternalFileUnit::Fseek(std::int64_t zeroBasedPos, + enum FseekWhence whence, IoErrorHandler &handler) { + if (whence == FseekEnd) { + Flush(handler); // updates knownSize_ + if (auto size{knownSize()}) { + zeroBasedPos += *size; + } else { + return false; + } + } else if (whence == FseekCurrent) { + zeroBasedPos += InquirePos() - 1; + } + if (zeroBasedPos >= 0) { + Sought(zeroBasedPos); + return true; + } else { + return false; + } +} + bool ExternalFileUnit::SetDirectRec( std::int64_t oneBasedRec, IoErrorHandler &handler) { if (access != Access::Direct) { @@ -498,7 +527,7 @@ bool ExternalFileUnit::SetDirectRec( return false; } currentRecordNumber = oneBasedRec; - SetPosition((oneBasedRec - 1) * *openRecl, handler); + SetPosition((oneBasedRec - 1) * *openRecl); return true; } diff --git a/flang-rt/lib/runtime/unit.h b/flang-rt/lib/runtime/unit.h index bb3d3650da34..86e5639f1250 100644 --- a/flang-rt/lib/runtime/unit.h +++ b/flang-rt/lib/runtime/unit.h @@ -33,6 +33,12 @@ class UnitMap; class ChildIo; class ExternalFileUnit; +enum FseekWhence { + FseekSet = 0, + FseekCurrent = 1, + FseekEnd = 2, +}; + RT_OFFLOAD_VAR_GROUP_BEGIN // Predefined file units. extern RT_VAR_ATTRS ExternalFileUnit *defaultInput; // unit 5 @@ -176,8 +182,9 @@ public: RT_API_ATTRS void Endfile(IoErrorHandler &); RT_API_ATTRS void Rewind(IoErrorHandler &); RT_API_ATTRS void EndIoStatement(); - RT_API_ATTRS bool SetStreamPos( - std::int64_t, IoErrorHandler &); // one-based, for POS= + RT_API_ATTRS bool SetStreamPos(std::int64_t oneBasedPos, IoErrorHandler &); + RT_API_ATTRS bool Fseek( + std::int64_t zeroBasedPos, enum FseekWhence, IoErrorHandler &); RT_API_ATTRS bool SetDirectRec( std::int64_t, IoErrorHandler &); // one-based, for REC= RT_API_ATTRS std::int64_t InquirePos() const { @@ -196,7 +203,8 @@ private: static RT_API_ATTRS UnitMap &CreateUnitMap(); static RT_API_ATTRS UnitMap &GetUnitMap(); RT_API_ATTRS const char *FrameNextInput(IoErrorHandler &, std::size_t); - RT_API_ATTRS void SetPosition(std::int64_t, IoErrorHandler &); // zero-based + RT_API_ATTRS void SetPosition(std::int64_t zeroBasedPos); + RT_API_ATTRS void Sought(std::int64_t zeroBasedPos); RT_API_ATTRS void BeginSequentialVariableUnformattedInputRecord( IoErrorHandler &); RT_API_ATTRS void BeginVariableFormattedInputRecord(IoErrorHandler &); diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md index 8b675c33b09d..ecf6fbeabd65 100644 --- a/flang/docs/Intrinsics.md +++ b/flang/docs/Intrinsics.md @@ -1197,6 +1197,44 @@ program chdir_func end program chdir_func ``` +### Non-Standard Intrinsics: FSEEK and FTELL + +#### Description +`FSEEK(UNIT, OFFSET, WHENCE)` Sets position in file opened as `UNIT`, returns status. + +`CALL FSEEK(UNIT, OFFSET, WHENCE[, STATUS])` Sets position, returns any error in `STATUS` if present. + +`FTELL(UNIT)` Returns current absolute byte offset. + +`CALL FTELL(UNIT, OFFSET)` Set `OFFSET` to current byte offset in file. + +These intrinsic procedures are available as both functions and subroutines, +but both forms cannot be used in the same scope. + +These arguments must all be integers. +The value returned from the function form of `FTELL` is `INTEGER(8)`. + +| | | +|------------|-------------------------------------------------| +| `UNIT` | An open unit number | +| `OFFSET` | A byte offset; set to -1 by `FTELL` on error | +| `WHENCE` | 0: `OFFSET` is an absolute position | +| | 1: `OFFSET` is relative to the current position | +| | 2: `OFFSET` is relative to the end of the file | +| `STATUS` | Set to a nonzero value if an error occurs | +|------------|-------------------------------------------------| + +The aliases `FSEEK64`, `FSEEKO64`, `FSEEKI8`, `FTELL64`, `FTELLO64`, and +`FTELLI8` are also accepted for further compatibility. + +Avoid using these intrinsics in new code when the standard `ACCESS="STREAM"` +feature meets your needs. + +#### Usage and Info + +- **Standard:** Extensions to GNU, Intel, and SUN (at least) +- **Class:** Subroutine, function + ### Non-Standard Intrinsics: IERRNO #### Description diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h index 29cde0548017..00b7b696eb4f 100644 --- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h +++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h @@ -266,6 +266,10 @@ struct IntrinsicLibrary { mlir::Value genFraction(mlir::Type resultType, mlir::ArrayRef args); void genFree(mlir::ArrayRef args); + fir::ExtendedValue genFseek(std::optional, + mlir::ArrayRef args); + fir::ExtendedValue genFtell(std::optional, + mlir::ArrayRef args); fir::ExtendedValue genGetCwd(std::optional resultType, llvm::ArrayRef args); void genGetCommand(mlir::ArrayRef args); diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h index 2e5adf6bd0ab..9ca4b2baeaa6 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h @@ -49,6 +49,11 @@ void genEtime(fir::FirOpBuilder &builder, mlir::Location loc, void genFree(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value ptr); +mlir::Value genFseek(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value unit, mlir::Value offset, mlir::Value whence); +mlir::Value genFtell(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value unit); + mlir::Value genGetUID(fir::FirOpBuilder &, mlir::Location); mlir::Value genGetGID(fir::FirOpBuilder &, mlir::Location); diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h index 47ef4c12ef73..db2245875e85 100644 --- a/flang/include/flang/Runtime/extensions.h +++ b/flang/include/flang/Runtime/extensions.h @@ -38,6 +38,11 @@ void FORTRAN_PROCEDURE_NAME(fdate)(char *string, std::int64_t length); void RTNAME(Free)(std::intptr_t ptr); +// Common extensions FSEEK & FTELL, variously named +std::int32_t RTNAME(Fseek)(int unit, std::int64_t zeroBasedPos, int whence, + const char *sourceFileName, int lineNumber); +std::int64_t RTNAME(Ftell)(int unit); + // GNU Fortran 77 compatibility function IARGC. std::int32_t FORTRAN_PROCEDURE_NAME(iargc)(); diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index e4f82b7fddb0..ed90b4bc097d 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -545,6 +545,12 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, {"floor", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, {"fraction", {{"x", SameReal}}, SameReal}, + {"fseek", + {{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar}, + {"whence", AnyInt, Rank::scalar}}, + DefaultInt, Rank::scalar}, + {"ftell", {{"unit", AnyInt, Rank::scalar}}, + TypePattern{IntType, KindCode::exactKind, 8}, Rank::scalar}, {"gamma", {{"x", SameReal}}, SameReal}, {"get_team", {{"level", DefaultInt, Rank::scalar, Optionality::optional}}, TeamType, Rank::scalar, IntrinsicClass::transformationalFunction}, @@ -1083,11 +1089,16 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ // LOC, probably others // TODO: Optionally warn on operand promotion extension -// Aliases for a few generic intrinsic functions for legacy -// compatibility and builtins. +// Aliases for a few generic procedures for legacy compatibility and builtins. static const std::pair genericAlias[]{ {"and", "iand"}, {"getenv", "get_environment_variable"}, + {"fseek64", "fseek"}, + {"fseeko64", "fseek"}, // SUN + {"fseeki8", "fseek"}, // Intel + {"ftell64", "ftell"}, + {"ftello64", "ftell"}, // SUN + {"ftelli8", "ftell"}, // Intel {"imag", "aimag"}, {"lshift", "shiftl"}, {"or", "ior"}, @@ -1524,6 +1535,17 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"free", {{"ptr", Addressable}}, {}}, + {"fseek", + {{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar}, + {"whence", AnyInt, Rank::scalar}, + {"status", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"ftell", + {{"unit", AnyInt, Rank::scalar}, + {"offset", AnyInt, Rank::scalar, Optionality::required, + common::Intent::Out}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"get_command", {{"command", DefaultChar, Rank::scalar, Optionality::optional, common::Intent::Out}, @@ -2811,9 +2833,9 @@ bool IntrinsicProcTable::Implementation::IsDualIntrinsic( const std::string &name) const { // 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}, - {"hostnm"s}, {"rename"s}, {"second"s}, {"system"s}, {"unlink"s}}; - + static const std::string dualIntrinsic[]{{"chdir"}, {"etime"}, {"fseek"}, + {"ftell"}, {"getcwd"}, {"hostnm"}, {"rename"}, {"second"}, {"system"}, + {"unlink"}}; return llvm::is_contained(dualIntrinsic, name); } diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 2df9349269a6..0ca636bc091e 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -462,6 +462,17 @@ static constexpr IntrinsicHandler handlers[]{ {"floor", &I::genFloor}, {"fraction", &I::genFraction}, {"free", &I::genFree}, + {"fseek", + &I::genFseek, + {{{"unit", asValue}, + {"offset", asValue}, + {"whence", asValue}, + {"status", asAddr, handleDynamicOptional}}}, + /*isElemental=*/false}, + {"ftell", + &I::genFtell, + {{{"unit", asValue}, {"offset", asAddr}}}, + /*isElemental=*/false}, {"get_command", &I::genGetCommand, {{{"command", asBox, handleDynamicOptional}, @@ -4139,6 +4150,69 @@ void IntrinsicLibrary::genFree(llvm::ArrayRef args) { fir::runtime::genFree(builder, loc, fir::getBase(args[0])); } +// FSEEK +fir::ExtendedValue +IntrinsicLibrary::genFseek(std::optional resultType, + llvm::ArrayRef args) { + assert((args.size() == 4 && !resultType.has_value()) || + (args.size() == 3 && resultType.has_value())); + mlir::Value unit = fir::getBase(args[0]); + mlir::Value offset = fir::getBase(args[1]); + mlir::Value whence = fir::getBase(args[2]); + if (!unit) + fir::emitFatalError(loc, "expected UNIT argument"); + if (!offset) + fir::emitFatalError(loc, "expected OFFSET argument"); + if (!whence) + fir::emitFatalError(loc, "expected WHENCE argument"); + mlir::Value statusValue = + fir::runtime::genFseek(builder, loc, unit, offset, whence); + if (resultType.has_value()) { // function + return builder.createConvert(loc, *resultType, statusValue); + } else { // subroutine + const fir::ExtendedValue &statusVar = args[3]; + if (!isStaticallyAbsent(statusVar)) { + mlir::Value statusAddr = fir::getBase(statusVar); + mlir::Value statusIsPresentAtRuntime = + builder.genIsNotNullAddr(loc, statusAddr); + builder.genIfThen(loc, statusIsPresentAtRuntime) + .genThen([&]() { + builder.createStoreWithConvert(loc, statusValue, statusAddr); + }) + .end(); + } + return {}; + } +} + +// FTELL +fir::ExtendedValue +IntrinsicLibrary::genFtell(std::optional resultType, + llvm::ArrayRef args) { + assert((args.size() == 2 && !resultType.has_value()) || + (args.size() == 1 && resultType.has_value())); + mlir::Value unit = fir::getBase(args[0]); + if (!unit) + fir::emitFatalError(loc, "expected UNIT argument"); + mlir::Value offsetValue = fir::runtime::genFtell(builder, loc, unit); + if (resultType.has_value()) { // function + return offsetValue; + } else { // subroutine + const fir::ExtendedValue &offsetVar = args[1]; + if (!isStaticallyAbsent(offsetVar)) { + mlir::Value offsetAddr = fir::getBase(offsetVar); + mlir::Value offsetIsPresentAtRuntime = + builder.genIsNotNullAddr(loc, offsetAddr); + builder.genIfThen(loc, offsetIsPresentAtRuntime) + .genThen([&]() { + builder.createStoreWithConvert(loc, offsetValue, offsetAddr); + }) + .end(); + } + return {}; + } +} + // GETCWD fir::ExtendedValue IntrinsicLibrary::genGetCwd(std::optional resultType, diff --git a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp index 3aad0625042a..773d6408079c 100644 --- a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp +++ b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp @@ -128,6 +128,30 @@ void fir::runtime::genFree(fir::FirOpBuilder &builder, mlir::Location loc, builder.createConvert(loc, intPtrTy, ptr)); } +mlir::Value fir::runtime::genFseek(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value unit, + mlir::Value offset, mlir::Value whence) { + auto runtimeFunc = fir::runtime::getRuntimeFunc(loc, builder); + mlir::FunctionType runtimeFuncTy = runtimeFunc.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, unit, offset, + whence, sourceFile, sourceLine); + return builder.create(loc, runtimeFunc, args).getResult(0); + ; +} + +mlir::Value fir::runtime::genFtell(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value unit) { + auto runtimeFunc = fir::runtime::getRuntimeFunc(loc, builder); + mlir::FunctionType runtimeFuncTy = runtimeFunc.getFunctionType(); + llvm::SmallVector args = + fir::runtime::createArguments(builder, loc, runtimeFuncTy, unit); + return builder.create(loc, runtimeFunc, args).getResult(0); +} + mlir::Value fir::runtime::genGetGID(fir::FirOpBuilder &builder, mlir::Location loc) { auto runtimeFunc =