1 //===-- IO.cpp -- IO statement lowering -----------------------------------===// 2 // 3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. 4 // See https://llvm.org/LICENSE.txt for license information. 5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 6 // 7 //===----------------------------------------------------------------------===// 8 // 9 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/ 10 // 11 //===----------------------------------------------------------------------===// 12 13 #include "flang/Lower/IO.h" 14 #include "flang/Common/uint128.h" 15 #include "flang/Lower/Bridge.h" 16 #include "flang/Lower/ConvertVariable.h" 17 #include "flang/Lower/PFTBuilder.h" 18 #include "flang/Lower/StatementContext.h" 19 #include "flang/Lower/Support/Utils.h" 20 #include "flang/Lower/Todo.h" 21 #include "flang/Optimizer/Builder/BoxValue.h" 22 #include "flang/Optimizer/Builder/Character.h" 23 #include "flang/Optimizer/Builder/Complex.h" 24 #include "flang/Optimizer/Builder/FIRBuilder.h" 25 #include "flang/Optimizer/Builder/MutableBox.h" 26 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" 27 #include "flang/Parser/parse-tree.h" 28 #include "flang/Runtime/io-api.h" 29 #include "flang/Semantics/tools.h" 30 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h" 31 32 #define DEBUG_TYPE "flang-lower-io" 33 34 // Define additional runtime type models specific to IO. 35 namespace fir::runtime { 36 template <> 37 constexpr TypeBuilderFunc getModel<Fortran::runtime::io::IoStatementState *>() { 38 return getModel<char *>(); 39 } 40 template <> 41 constexpr TypeBuilderFunc 42 getModel<const Fortran::runtime::io::NamelistGroup &>() { 43 return [](mlir::MLIRContext *context) -> mlir::Type { 44 return fir::ReferenceType::get(mlir::TupleType::get(context)); 45 }; 46 } 47 template <> 48 constexpr TypeBuilderFunc getModel<Fortran::runtime::io::Iostat>() { 49 return [](mlir::MLIRContext *context) -> mlir::Type { 50 return mlir::IntegerType::get(context, 51 8 * sizeof(Fortran::runtime::io::Iostat)); 52 }; 53 } 54 } // namespace fir::runtime 55 56 using namespace Fortran::runtime::io; 57 58 #define mkIOKey(X) FirmkKey(IONAME(X)) 59 60 namespace Fortran::lower { 61 /// Static table of IO runtime calls 62 /// 63 /// This logical map contains the name and type builder function for each IO 64 /// runtime function listed in the tuple. This table is fully constructed at 65 /// compile-time. Use the `mkIOKey` macro to access the table. 66 static constexpr std::tuple< 67 mkIOKey(BeginInternalArrayListOutput), mkIOKey(BeginInternalArrayListInput), 68 mkIOKey(BeginInternalArrayFormattedOutput), 69 mkIOKey(BeginInternalArrayFormattedInput), mkIOKey(BeginInternalListOutput), 70 mkIOKey(BeginInternalListInput), mkIOKey(BeginInternalFormattedOutput), 71 mkIOKey(BeginInternalFormattedInput), mkIOKey(BeginExternalListOutput), 72 mkIOKey(BeginExternalListInput), mkIOKey(BeginExternalFormattedOutput), 73 mkIOKey(BeginExternalFormattedInput), mkIOKey(BeginUnformattedOutput), 74 mkIOKey(BeginUnformattedInput), mkIOKey(BeginAsynchronousOutput), 75 mkIOKey(BeginAsynchronousInput), mkIOKey(BeginWait), mkIOKey(BeginWaitAll), 76 mkIOKey(BeginClose), mkIOKey(BeginFlush), mkIOKey(BeginBackspace), 77 mkIOKey(BeginEndfile), mkIOKey(BeginRewind), mkIOKey(BeginOpenUnit), 78 mkIOKey(BeginOpenNewUnit), mkIOKey(BeginInquireUnit), 79 mkIOKey(BeginInquireFile), mkIOKey(BeginInquireIoLength), 80 mkIOKey(EnableHandlers), mkIOKey(SetAdvance), mkIOKey(SetBlank), 81 mkIOKey(SetDecimal), mkIOKey(SetDelim), mkIOKey(SetPad), mkIOKey(SetPos), 82 mkIOKey(SetRec), mkIOKey(SetRound), mkIOKey(SetSign), 83 mkIOKey(OutputNamelist), mkIOKey(InputNamelist), mkIOKey(OutputDescriptor), 84 mkIOKey(InputDescriptor), mkIOKey(OutputUnformattedBlock), 85 mkIOKey(InputUnformattedBlock), mkIOKey(OutputInteger8), 86 mkIOKey(OutputInteger16), mkIOKey(OutputInteger32), 87 mkIOKey(OutputInteger64), 88 #ifdef __SIZEOF_INT128__ 89 mkIOKey(OutputInteger128), 90 #endif 91 mkIOKey(InputInteger), mkIOKey(OutputReal32), mkIOKey(InputReal32), 92 mkIOKey(OutputReal64), mkIOKey(InputReal64), mkIOKey(OutputComplex32), 93 mkIOKey(InputComplex32), mkIOKey(OutputComplex64), mkIOKey(InputComplex64), 94 mkIOKey(OutputAscii), mkIOKey(InputAscii), mkIOKey(OutputLogical), 95 mkIOKey(InputLogical), mkIOKey(SetAccess), mkIOKey(SetAction), 96 mkIOKey(SetAsynchronous), mkIOKey(SetCarriagecontrol), mkIOKey(SetEncoding), 97 mkIOKey(SetForm), mkIOKey(SetPosition), mkIOKey(SetRecl), 98 mkIOKey(SetStatus), mkIOKey(SetFile), mkIOKey(GetNewUnit), mkIOKey(GetSize), 99 mkIOKey(GetIoLength), mkIOKey(GetIoMsg), mkIOKey(InquireCharacter), 100 mkIOKey(InquireLogical), mkIOKey(InquirePendingId), 101 mkIOKey(InquireInteger64), mkIOKey(EndIoStatement)> 102 newIOTable; 103 } // namespace Fortran::lower 104 105 namespace { 106 /// IO statements may require exceptional condition handling. A statement that 107 /// encounters an exceptional condition may branch to a label given on an ERR 108 /// (error), END (end-of-file), or EOR (end-of-record) specifier. An IOSTAT 109 /// specifier variable may be set to a value that indicates some condition, 110 /// and an IOMSG specifier variable may be set to a description of a condition. 111 struct ConditionSpecInfo { 112 const Fortran::lower::SomeExpr *ioStatExpr{}; 113 const Fortran::lower::SomeExpr *ioMsgExpr{}; 114 bool hasErr{}; 115 bool hasEnd{}; 116 bool hasEor{}; 117 118 /// Check for any condition specifier that applies to specifier processing. 119 bool hasErrorConditionSpec() const { return ioStatExpr != nullptr || hasErr; } 120 121 /// Check for any condition specifier that applies to data transfer items 122 /// in a PRINT, READ, WRITE, or WAIT statement. (WAIT may be irrelevant.) 123 bool hasTransferConditionSpec() const { 124 return hasErrorConditionSpec() || hasEnd || hasEor; 125 } 126 127 /// Check for any condition specifier, including IOMSG. 128 bool hasAnyConditionSpec() const { 129 return hasTransferConditionSpec() || ioMsgExpr != nullptr; 130 } 131 }; 132 } // namespace 133 134 template <typename D> 135 static void genIoLoop(Fortran::lower::AbstractConverter &converter, 136 mlir::Value cookie, const D &ioImpliedDo, 137 bool isFormatted, bool checkResult, mlir::Value &ok, 138 bool inLoop, Fortran::lower::StatementContext &stmtCtx); 139 140 /// Helper function to retrieve the name of the IO function given the key `A` 141 template <typename A> 142 static constexpr const char *getName() { 143 return std::get<A>(Fortran::lower::newIOTable).name; 144 } 145 146 /// Helper function to retrieve the type model signature builder of the IO 147 /// function as defined by the key `A` 148 template <typename A> 149 static constexpr fir::runtime::FuncTypeBuilderFunc getTypeModel() { 150 return std::get<A>(Fortran::lower::newIOTable).getTypeModel(); 151 } 152 153 /// Get (or generate) the MLIR FuncOp for a given IO runtime function. 154 template <typename E> 155 static mlir::FuncOp getIORuntimeFunc(mlir::Location loc, 156 fir::FirOpBuilder &builder) { 157 llvm::StringRef name = getName<E>(); 158 mlir::FuncOp func = builder.getNamedFunction(name); 159 if (func) 160 return func; 161 auto funTy = getTypeModel<E>()(builder.getContext()); 162 func = builder.createFunction(loc, name, funTy); 163 func->setAttr("fir.runtime", builder.getUnitAttr()); 164 func->setAttr("fir.io", builder.getUnitAttr()); 165 return func; 166 } 167 168 /// Generate calls to end an IO statement. Return the IOSTAT value, if any. 169 /// It is the caller's responsibility to generate branches on that value. 170 static mlir::Value genEndIO(Fortran::lower::AbstractConverter &converter, 171 mlir::Location loc, mlir::Value cookie, 172 const ConditionSpecInfo &csi, 173 Fortran::lower::StatementContext &stmtCtx) { 174 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 175 if (csi.ioMsgExpr) { 176 mlir::FuncOp getIoMsg = getIORuntimeFunc<mkIOKey(GetIoMsg)>(loc, builder); 177 fir::ExtendedValue ioMsgVar = 178 converter.genExprAddr(csi.ioMsgExpr, stmtCtx, loc); 179 builder.create<fir::CallOp>( 180 loc, getIoMsg, 181 mlir::ValueRange{ 182 cookie, 183 builder.createConvert(loc, getIoMsg.getType().getInput(1), 184 fir::getBase(ioMsgVar)), 185 builder.createConvert(loc, getIoMsg.getType().getInput(2), 186 fir::getLen(ioMsgVar))}); 187 } 188 mlir::FuncOp endIoStatement = 189 getIORuntimeFunc<mkIOKey(EndIoStatement)>(loc, builder); 190 auto call = builder.create<fir::CallOp>(loc, endIoStatement, 191 mlir::ValueRange{cookie}); 192 if (csi.ioStatExpr) { 193 mlir::Value ioStatVar = 194 fir::getBase(converter.genExprAddr(csi.ioStatExpr, stmtCtx, loc)); 195 mlir::Value ioStatResult = builder.createConvert( 196 loc, converter.genType(*csi.ioStatExpr), call.getResult(0)); 197 builder.create<fir::StoreOp>(loc, ioStatResult, ioStatVar); 198 } 199 return csi.hasTransferConditionSpec() ? call.getResult(0) : mlir::Value{}; 200 } 201 202 /// Make the next call in the IO statement conditional on runtime result `ok`. 203 /// If a call returns `ok==false`, further suboperation calls for an IO 204 /// statement will be skipped. This may generate branch heavy, deeply nested 205 /// conditionals for IO statements with a large number of suboperations. 206 static void makeNextConditionalOn(fir::FirOpBuilder &builder, 207 mlir::Location loc, bool checkResult, 208 mlir::Value ok, bool inLoop = false) { 209 if (!checkResult || !ok) 210 // Either no IO calls need to be checked, or this will be the first call. 211 return; 212 213 // A previous IO call for a statement returned the bool `ok`. If this call 214 // is in a fir.iterate_while loop, the result must be propagated up to the 215 // loop scope as an extra ifOp result. (The propagation is done in genIoLoop.) 216 mlir::TypeRange resTy; 217 if (inLoop) 218 resTy = builder.getI1Type(); 219 auto ifOp = builder.create<fir::IfOp>(loc, resTy, ok, 220 /*withElseRegion=*/inLoop); 221 builder.setInsertionPointToStart(&ifOp.getThenRegion().front()); 222 } 223 224 /// Retrieve or generate a runtime description of NAMELIST group `symbol`. 225 /// The form of the description is defined in runtime header file namelist.h. 226 /// Static descriptors are generated for global objects; local descriptors for 227 /// local objects. If all descriptors are static, the NamelistGroup is static. 228 static mlir::Value 229 getNamelistGroup(Fortran::lower::AbstractConverter &converter, 230 const Fortran::semantics::Symbol &symbol, 231 Fortran::lower::StatementContext &stmtCtx) { 232 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 233 mlir::Location loc = converter.getCurrentLocation(); 234 std::string groupMangleName = converter.mangleName(symbol); 235 if (auto group = builder.getNamedGlobal(groupMangleName)) 236 return builder.create<fir::AddrOfOp>(loc, group.resultType(), 237 group.getSymbol()); 238 239 const auto &details = 240 symbol.GetUltimate().get<Fortran::semantics::NamelistDetails>(); 241 mlir::MLIRContext *context = builder.getContext(); 242 mlir::StringAttr linkOnce = builder.createLinkOnceLinkage(); 243 mlir::IndexType idxTy = builder.getIndexType(); 244 mlir::IntegerType sizeTy = builder.getIntegerType(8 * sizeof(std::size_t)); 245 fir::ReferenceType charRefTy = 246 fir::ReferenceType::get(builder.getIntegerType(8)); 247 fir::ReferenceType descRefTy = 248 fir::ReferenceType::get(fir::BoxType::get(mlir::NoneType::get(context))); 249 fir::SequenceType listTy = fir::SequenceType::get( 250 details.objects().size(), 251 mlir::TupleType::get(context, {charRefTy, descRefTy})); 252 mlir::TupleType groupTy = mlir::TupleType::get( 253 context, {charRefTy, sizeTy, fir::ReferenceType::get(listTy)}); 254 auto stringAddress = [&](const Fortran::semantics::Symbol &symbol) { 255 return fir::factory::createStringLiteral(builder, loc, 256 symbol.name().ToString() + '\0'); 257 }; 258 259 // Define object names, and static descriptors for global objects. 260 bool groupIsLocal = false; 261 stringAddress(symbol); 262 for (const Fortran::semantics::Symbol &s : details.objects()) { 263 stringAddress(s); 264 if (!Fortran::lower::symbolIsGlobal(s)) { 265 groupIsLocal = true; 266 continue; 267 } 268 std::string mangleName = converter.mangleName(s) + ".desc"; 269 if (builder.getNamedGlobal(mangleName)) 270 continue; 271 const auto expr = Fortran::evaluate::AsGenericExpr(s); 272 fir::BoxType boxTy = 273 fir::BoxType::get(fir::PointerType::get(converter.genType(s))); 274 auto descFunc = [&](fir::FirOpBuilder &b) { 275 auto box = 276 Fortran::lower::genInitialDataTarget(converter, loc, boxTy, *expr); 277 b.create<fir::HasValueOp>(loc, box); 278 }; 279 builder.createGlobalConstant(loc, boxTy, mangleName, descFunc, linkOnce); 280 } 281 282 // Define the list of Items. 283 mlir::Value listAddr = 284 groupIsLocal ? builder.create<fir::AllocaOp>(loc, listTy) : mlir::Value{}; 285 std::string listMangleName = groupMangleName + ".list"; 286 auto listFunc = [&](fir::FirOpBuilder &builder) { 287 mlir::Value list = builder.create<fir::UndefOp>(loc, listTy); 288 mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0); 289 mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1); 290 llvm::SmallVector<mlir::Attribute, 2> idx = {mlir::Attribute{}, 291 mlir::Attribute{}}; 292 size_t n = 0; 293 for (const Fortran::semantics::Symbol &s : details.objects()) { 294 idx[0] = builder.getIntegerAttr(idxTy, n); 295 idx[1] = zero; 296 mlir::Value nameAddr = 297 builder.createConvert(loc, charRefTy, fir::getBase(stringAddress(s))); 298 list = builder.create<fir::InsertValueOp>(loc, listTy, list, nameAddr, 299 builder.getArrayAttr(idx)); 300 idx[1] = one; 301 mlir::Value descAddr; 302 if (auto desc = 303 builder.getNamedGlobal(converter.mangleName(s) + ".desc")) { 304 descAddr = builder.create<fir::AddrOfOp>(loc, desc.resultType(), 305 desc.getSymbol()); 306 } else { 307 const auto expr = Fortran::evaluate::AsGenericExpr(s); 308 fir::ExtendedValue exv = converter.genExprAddr(*expr, stmtCtx); 309 mlir::Type type = fir::getBase(exv).getType(); 310 if (mlir::Type baseTy = fir::dyn_cast_ptrOrBoxEleTy(type)) 311 type = baseTy; 312 fir::BoxType boxType = fir::BoxType::get(fir::PointerType::get(type)); 313 descAddr = builder.createTemporary(loc, boxType); 314 fir::MutableBoxValue box = fir::MutableBoxValue(descAddr, {}, {}); 315 fir::factory::associateMutableBox(builder, loc, box, exv, 316 /*lbounds=*/llvm::None); 317 } 318 descAddr = builder.createConvert(loc, descRefTy, descAddr); 319 list = builder.create<fir::InsertValueOp>(loc, listTy, list, descAddr, 320 builder.getArrayAttr(idx)); 321 ++n; 322 } 323 if (groupIsLocal) 324 builder.create<fir::StoreOp>(loc, list, listAddr); 325 else 326 builder.create<fir::HasValueOp>(loc, list); 327 }; 328 if (groupIsLocal) 329 listFunc(builder); 330 else 331 builder.createGlobalConstant(loc, listTy, listMangleName, listFunc, 332 linkOnce); 333 334 // Define the group. 335 mlir::Value groupAddr = groupIsLocal 336 ? builder.create<fir::AllocaOp>(loc, groupTy) 337 : mlir::Value{}; 338 auto groupFunc = [&](fir::FirOpBuilder &builder) { 339 mlir::IntegerAttr zero = builder.getIntegerAttr(idxTy, 0); 340 mlir::IntegerAttr one = builder.getIntegerAttr(idxTy, 1); 341 mlir::IntegerAttr two = builder.getIntegerAttr(idxTy, 2); 342 mlir::Value group = builder.create<fir::UndefOp>(loc, groupTy); 343 mlir::Value nameAddr = builder.createConvert( 344 loc, charRefTy, fir::getBase(stringAddress(symbol))); 345 group = builder.create<fir::InsertValueOp>(loc, groupTy, group, nameAddr, 346 builder.getArrayAttr(zero)); 347 mlir::Value itemCount = 348 builder.createIntegerConstant(loc, sizeTy, details.objects().size()); 349 group = builder.create<fir::InsertValueOp>(loc, groupTy, group, itemCount, 350 builder.getArrayAttr(one)); 351 if (fir::GlobalOp list = builder.getNamedGlobal(listMangleName)) 352 listAddr = builder.create<fir::AddrOfOp>(loc, list.resultType(), 353 list.getSymbol()); 354 assert(listAddr && "missing namelist object list"); 355 group = builder.create<fir::InsertValueOp>(loc, groupTy, group, listAddr, 356 builder.getArrayAttr(two)); 357 if (groupIsLocal) 358 builder.create<fir::StoreOp>(loc, group, groupAddr); 359 else 360 builder.create<fir::HasValueOp>(loc, group); 361 }; 362 if (groupIsLocal) { 363 groupFunc(builder); 364 } else { 365 fir::GlobalOp group = 366 builder.createGlobal(loc, groupTy, groupMangleName, 367 /*isConst=*/true, groupFunc, linkOnce); 368 groupAddr = builder.create<fir::AddrOfOp>(loc, group.resultType(), 369 group.getSymbol()); 370 } 371 assert(groupAddr && "missing namelist group result"); 372 return groupAddr; 373 } 374 375 /// Generate a namelist IO call. 376 static void genNamelistIO(Fortran::lower::AbstractConverter &converter, 377 mlir::Value cookie, mlir::FuncOp funcOp, 378 Fortran::semantics::Symbol &symbol, bool checkResult, 379 mlir::Value &ok, 380 Fortran::lower::StatementContext &stmtCtx) { 381 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 382 mlir::Location loc = converter.getCurrentLocation(); 383 makeNextConditionalOn(builder, loc, checkResult, ok); 384 mlir::Type argType = funcOp.getType().getInput(1); 385 mlir::Value groupAddr = getNamelistGroup(converter, symbol, stmtCtx); 386 groupAddr = builder.createConvert(loc, argType, groupAddr); 387 llvm::SmallVector<mlir::Value> args = {cookie, groupAddr}; 388 ok = builder.create<fir::CallOp>(loc, funcOp, args).getResult(0); 389 } 390 391 /// Get the output function to call for a value of the given type. 392 static mlir::FuncOp getOutputFunc(mlir::Location loc, 393 fir::FirOpBuilder &builder, mlir::Type type, 394 bool isFormatted) { 395 if (!isFormatted) 396 return getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc, builder); 397 if (auto ty = type.dyn_cast<mlir::IntegerType>()) { 398 switch (ty.getWidth()) { 399 case 1: 400 return getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder); 401 case 8: 402 return getIORuntimeFunc<mkIOKey(OutputInteger8)>(loc, builder); 403 case 16: 404 return getIORuntimeFunc<mkIOKey(OutputInteger16)>(loc, builder); 405 case 32: 406 return getIORuntimeFunc<mkIOKey(OutputInteger32)>(loc, builder); 407 case 64: 408 return getIORuntimeFunc<mkIOKey(OutputInteger64)>(loc, builder); 409 #ifdef __SIZEOF_INT128__ 410 case 128: 411 return getIORuntimeFunc<mkIOKey(OutputInteger128)>(loc, builder); 412 #endif 413 } 414 llvm_unreachable("unknown OutputInteger kind"); 415 } 416 if (auto ty = type.dyn_cast<mlir::FloatType>()) { 417 if (auto width = ty.getWidth(); width == 32) 418 return getIORuntimeFunc<mkIOKey(OutputReal32)>(loc, builder); 419 else if (width == 64) 420 return getIORuntimeFunc<mkIOKey(OutputReal64)>(loc, builder); 421 } 422 if (auto ty = type.dyn_cast<fir::ComplexType>()) { 423 if (auto kind = ty.getFKind(); kind == 4) 424 return getIORuntimeFunc<mkIOKey(OutputComplex32)>(loc, builder); 425 else if (kind == 8) 426 return getIORuntimeFunc<mkIOKey(OutputComplex64)>(loc, builder); 427 } 428 if (type.isa<fir::LogicalType>()) 429 return getIORuntimeFunc<mkIOKey(OutputLogical)>(loc, builder); 430 if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) 431 return getIORuntimeFunc<mkIOKey(OutputAscii)>(loc, builder); 432 return getIORuntimeFunc<mkIOKey(OutputDescriptor)>(loc, builder); 433 } 434 435 /// Generate a sequence of output data transfer calls. 436 static void 437 genOutputItemList(Fortran::lower::AbstractConverter &converter, 438 mlir::Value cookie, 439 const std::list<Fortran::parser::OutputItem> &items, 440 bool isFormatted, bool checkResult, mlir::Value &ok, 441 bool inLoop, Fortran::lower::StatementContext &stmtCtx) { 442 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 443 for (const Fortran::parser::OutputItem &item : items) { 444 if (const auto &impliedDo = std::get_if<1>(&item.u)) { 445 genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult, 446 ok, inLoop, stmtCtx); 447 continue; 448 } 449 auto &pExpr = std::get<Fortran::parser::Expr>(item.u); 450 mlir::Location loc = converter.genLocation(pExpr.source); 451 makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); 452 453 const auto *expr = Fortran::semantics::GetExpr(pExpr); 454 if (!expr) 455 fir::emitFatalError(loc, "internal error: could not get evaluate::Expr"); 456 mlir::Type itemTy = converter.genType(*expr); 457 mlir::FuncOp outputFunc = getOutputFunc(loc, builder, itemTy, isFormatted); 458 mlir::Type argType = outputFunc.getType().getInput(1); 459 assert((isFormatted || argType.isa<fir::BoxType>()) && 460 "expect descriptor for unformatted IO runtime"); 461 llvm::SmallVector<mlir::Value> outputFuncArgs = {cookie}; 462 fir::factory::CharacterExprHelper helper{builder, loc}; 463 if (argType.isa<fir::BoxType>()) { 464 mlir::Value box = fir::getBase(converter.genExprBox(*expr, stmtCtx, loc)); 465 outputFuncArgs.push_back(builder.createConvert(loc, argType, box)); 466 } else if (helper.isCharacterScalar(itemTy)) { 467 fir::ExtendedValue exv = converter.genExprAddr(expr, stmtCtx, loc); 468 // scalar allocatable/pointer may also get here, not clear if 469 // genExprAddr will lower them as CharBoxValue or BoxValue. 470 if (!exv.getCharBox()) 471 llvm::report_fatal_error( 472 "internal error: scalar character not in CharBox"); 473 outputFuncArgs.push_back(builder.createConvert( 474 loc, outputFunc.getType().getInput(1), fir::getBase(exv))); 475 outputFuncArgs.push_back(builder.createConvert( 476 loc, outputFunc.getType().getInput(2), fir::getLen(exv))); 477 } else { 478 fir::ExtendedValue itemBox = converter.genExprValue(expr, stmtCtx, loc); 479 mlir::Value itemValue = fir::getBase(itemBox); 480 if (fir::isa_complex(itemTy)) { 481 auto parts = 482 fir::factory::Complex{builder, loc}.extractParts(itemValue); 483 outputFuncArgs.push_back(parts.first); 484 outputFuncArgs.push_back(parts.second); 485 } else { 486 itemValue = builder.createConvert(loc, argType, itemValue); 487 outputFuncArgs.push_back(itemValue); 488 } 489 } 490 ok = builder.create<fir::CallOp>(loc, outputFunc, outputFuncArgs) 491 .getResult(0); 492 } 493 } 494 495 /// Get the input function to call for a value of the given type. 496 static mlir::FuncOp getInputFunc(mlir::Location loc, fir::FirOpBuilder &builder, 497 mlir::Type type, bool isFormatted) { 498 if (!isFormatted) 499 return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder); 500 if (auto ty = type.dyn_cast<mlir::IntegerType>()) 501 return ty.getWidth() == 1 502 ? getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder) 503 : getIORuntimeFunc<mkIOKey(InputInteger)>(loc, builder); 504 if (auto ty = type.dyn_cast<mlir::FloatType>()) { 505 if (auto width = ty.getWidth(); width <= 32) 506 return getIORuntimeFunc<mkIOKey(InputReal32)>(loc, builder); 507 else if (width <= 64) 508 return getIORuntimeFunc<mkIOKey(InputReal64)>(loc, builder); 509 } 510 if (auto ty = type.dyn_cast<fir::ComplexType>()) { 511 if (auto kind = ty.getFKind(); kind <= 4) 512 return getIORuntimeFunc<mkIOKey(InputComplex32)>(loc, builder); 513 else if (kind <= 8) 514 return getIORuntimeFunc<mkIOKey(InputComplex64)>(loc, builder); 515 } 516 if (type.isa<fir::LogicalType>()) 517 return getIORuntimeFunc<mkIOKey(InputLogical)>(loc, builder); 518 if (fir::factory::CharacterExprHelper::isCharacterScalar(type)) 519 return getIORuntimeFunc<mkIOKey(InputAscii)>(loc, builder); 520 return getIORuntimeFunc<mkIOKey(InputDescriptor)>(loc, builder); 521 } 522 523 static mlir::Value createIoRuntimeCallForItem(mlir::Location loc, 524 fir::FirOpBuilder &builder, 525 mlir::FuncOp inputFunc, 526 mlir::Value cookie, 527 const fir::ExtendedValue &item) { 528 mlir::Type argType = inputFunc.getType().getInput(1); 529 llvm::SmallVector<mlir::Value> inputFuncArgs = {cookie}; 530 if (argType.isa<fir::BoxType>()) { 531 mlir::Value box = fir::getBase(item); 532 assert(box.getType().isa<fir::BoxType>() && "must be previously emboxed"); 533 inputFuncArgs.push_back(builder.createConvert(loc, argType, box)); 534 } else { 535 mlir::Value itemAddr = fir::getBase(item); 536 mlir::Type itemTy = fir::unwrapPassByRefType(itemAddr.getType()); 537 inputFuncArgs.push_back(builder.createConvert(loc, argType, itemAddr)); 538 fir::factory::CharacterExprHelper charHelper{builder, loc}; 539 if (charHelper.isCharacterScalar(itemTy)) { 540 mlir::Value len = fir::getLen(item); 541 inputFuncArgs.push_back( 542 builder.createConvert(loc, inputFunc.getType().getInput(2), len)); 543 } else if (itemTy.isa<mlir::IntegerType>()) { 544 inputFuncArgs.push_back(builder.create<mlir::arith::ConstantOp>( 545 loc, builder.getI32IntegerAttr( 546 itemTy.cast<mlir::IntegerType>().getWidth() / 8))); 547 } 548 } 549 return builder.create<fir::CallOp>(loc, inputFunc, inputFuncArgs) 550 .getResult(0); 551 } 552 553 /// Generate a sequence of input data transfer calls. 554 static void genInputItemList(Fortran::lower::AbstractConverter &converter, 555 mlir::Value cookie, 556 const std::list<Fortran::parser::InputItem> &items, 557 bool isFormatted, bool checkResult, 558 mlir::Value &ok, bool inLoop, 559 Fortran::lower::StatementContext &stmtCtx) { 560 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 561 for (const Fortran::parser::InputItem &item : items) { 562 if (const auto &impliedDo = std::get_if<1>(&item.u)) { 563 genIoLoop(converter, cookie, impliedDo->value(), isFormatted, checkResult, 564 ok, inLoop, stmtCtx); 565 continue; 566 } 567 auto &pVar = std::get<Fortran::parser::Variable>(item.u); 568 mlir::Location loc = converter.genLocation(pVar.GetSource()); 569 makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); 570 const auto *expr = Fortran::semantics::GetExpr(pVar); 571 if (!expr) 572 fir::emitFatalError(loc, "internal error: could not get evaluate::Expr"); 573 if (Fortran::evaluate::HasVectorSubscript(*expr)) { 574 TODO(loc, "genInputItemList with VectorSubscript"); 575 } 576 mlir::Type itemTy = converter.genType(*expr); 577 mlir::FuncOp inputFunc = getInputFunc(loc, builder, itemTy, isFormatted); 578 auto itemExv = inputFunc.getType().getInput(1).isa<fir::BoxType>() 579 ? converter.genExprBox(*expr, stmtCtx, loc) 580 : converter.genExprAddr(expr, stmtCtx, loc); 581 ok = createIoRuntimeCallForItem(loc, builder, inputFunc, cookie, itemExv); 582 } 583 } 584 585 /// Generate an io-implied-do loop. 586 template <typename D> 587 static void genIoLoop(Fortran::lower::AbstractConverter &converter, 588 mlir::Value cookie, const D &ioImpliedDo, 589 bool isFormatted, bool checkResult, mlir::Value &ok, 590 bool inLoop, Fortran::lower::StatementContext &stmtCtx) { 591 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 592 mlir::Location loc = converter.getCurrentLocation(); 593 makeNextConditionalOn(builder, loc, checkResult, ok, inLoop); 594 const auto &itemList = std::get<0>(ioImpliedDo.t); 595 const auto &control = std::get<1>(ioImpliedDo.t); 596 const auto &loopSym = *control.name.thing.thing.symbol; 597 mlir::Value loopVar = converter.getSymbolAddress(loopSym); 598 auto genControlValue = [&](const Fortran::parser::ScalarIntExpr &expr) { 599 mlir::Value v = fir::getBase( 600 converter.genExprValue(*Fortran::semantics::GetExpr(expr), stmtCtx)); 601 return builder.createConvert(loc, builder.getIndexType(), v); 602 }; 603 mlir::Value lowerValue = genControlValue(control.lower); 604 mlir::Value upperValue = genControlValue(control.upper); 605 mlir::Value stepValue = 606 control.step.has_value() 607 ? genControlValue(*control.step) 608 : builder.create<mlir::arith::ConstantIndexOp>(loc, 1); 609 auto genItemList = [&](const D &ioImpliedDo) { 610 Fortran::lower::StatementContext loopCtx; 611 if constexpr (std::is_same_v<D, Fortran::parser::InputImpliedDo>) 612 genInputItemList(converter, cookie, itemList, isFormatted, checkResult, 613 ok, /*inLoop=*/true, loopCtx); 614 else 615 genOutputItemList(converter, cookie, itemList, isFormatted, checkResult, 616 ok, /*inLoop=*/true, loopCtx); 617 }; 618 if (!checkResult) { 619 // No IO call result checks - the loop is a fir.do_loop op. 620 auto doLoopOp = builder.create<fir::DoLoopOp>( 621 loc, lowerValue, upperValue, stepValue, /*unordered=*/false, 622 /*finalCountValue=*/true); 623 builder.setInsertionPointToStart(doLoopOp.getBody()); 624 mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym), 625 doLoopOp.getInductionVar()); 626 builder.create<fir::StoreOp>(loc, lcv, loopVar); 627 genItemList(ioImpliedDo); 628 builder.setInsertionPointToEnd(doLoopOp.getBody()); 629 mlir::Value result = builder.create<mlir::arith::AddIOp>( 630 loc, doLoopOp.getInductionVar(), doLoopOp.getStep()); 631 builder.create<fir::ResultOp>(loc, result); 632 builder.setInsertionPointAfter(doLoopOp); 633 // The loop control variable may be used after the loop. 634 lcv = builder.createConvert(loc, converter.genType(loopSym), 635 doLoopOp.getResult(0)); 636 builder.create<fir::StoreOp>(loc, lcv, loopVar); 637 return; 638 } 639 // Check IO call results - the loop is a fir.iterate_while op. 640 if (!ok) 641 ok = builder.createBool(loc, true); 642 auto iterWhileOp = builder.create<fir::IterWhileOp>( 643 loc, lowerValue, upperValue, stepValue, ok, /*finalCountValue*/ true); 644 builder.setInsertionPointToStart(iterWhileOp.getBody()); 645 mlir::Value lcv = builder.createConvert(loc, converter.genType(loopSym), 646 iterWhileOp.getInductionVar()); 647 builder.create<fir::StoreOp>(loc, lcv, loopVar); 648 ok = iterWhileOp.getIterateVar(); 649 mlir::Value falseValue = 650 builder.createIntegerConstant(loc, builder.getI1Type(), 0); 651 genItemList(ioImpliedDo); 652 // Unwind nested IO call scopes, filling in true and false ResultOp's. 653 for (mlir::Operation *op = builder.getBlock()->getParentOp(); 654 isa<fir::IfOp>(op); op = op->getBlock()->getParentOp()) { 655 auto ifOp = dyn_cast<fir::IfOp>(op); 656 mlir::Operation *lastOp = &ifOp.getThenRegion().front().back(); 657 builder.setInsertionPointAfter(lastOp); 658 // The primary ifOp result is the result of an IO call or loop. 659 if (mlir::isa<fir::CallOp, fir::IfOp>(*lastOp)) 660 builder.create<fir::ResultOp>(loc, lastOp->getResult(0)); 661 else 662 builder.create<fir::ResultOp>(loc, ok); // loop result 663 // The else branch propagates an early exit false result. 664 builder.setInsertionPointToStart(&ifOp.getElseRegion().front()); 665 builder.create<fir::ResultOp>(loc, falseValue); 666 } 667 builder.setInsertionPointToEnd(iterWhileOp.getBody()); 668 mlir::OpResult iterateResult = builder.getBlock()->back().getResult(0); 669 mlir::Value inductionResult0 = iterWhileOp.getInductionVar(); 670 auto inductionResult1 = builder.create<mlir::arith::AddIOp>( 671 loc, inductionResult0, iterWhileOp.getStep()); 672 auto inductionResult = builder.create<mlir::arith::SelectOp>( 673 loc, iterateResult, inductionResult1, inductionResult0); 674 llvm::SmallVector<mlir::Value> results = {inductionResult, iterateResult}; 675 builder.create<fir::ResultOp>(loc, results); 676 ok = iterWhileOp.getResult(1); 677 builder.setInsertionPointAfter(iterWhileOp); 678 // The loop control variable may be used after the loop. 679 lcv = builder.createConvert(loc, converter.genType(loopSym), 680 iterWhileOp.getResult(0)); 681 builder.create<fir::StoreOp>(loc, lcv, loopVar); 682 } 683 684 //===----------------------------------------------------------------------===// 685 // Default argument generation. 686 //===----------------------------------------------------------------------===// 687 688 static mlir::Value locToFilename(Fortran::lower::AbstractConverter &converter, 689 mlir::Location loc, mlir::Type toType) { 690 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 691 return builder.createConvert(loc, toType, 692 fir::factory::locationToFilename(builder, loc)); 693 } 694 695 static mlir::Value locToLineNo(Fortran::lower::AbstractConverter &converter, 696 mlir::Location loc, mlir::Type toType) { 697 return fir::factory::locationToLineNo(converter.getFirOpBuilder(), loc, 698 toType); 699 } 700 701 static mlir::Value getDefaultScratch(fir::FirOpBuilder &builder, 702 mlir::Location loc, mlir::Type toType) { 703 mlir::Value null = builder.create<mlir::arith::ConstantOp>( 704 loc, builder.getI64IntegerAttr(0)); 705 return builder.createConvert(loc, toType, null); 706 } 707 708 static mlir::Value getDefaultScratchLen(fir::FirOpBuilder &builder, 709 mlir::Location loc, mlir::Type toType) { 710 return builder.create<mlir::arith::ConstantOp>( 711 loc, builder.getIntegerAttr(toType, 0)); 712 } 713 714 /// Generate a reference to a buffer and the length of buffer given 715 /// a character expression. An array expression will be cast to scalar 716 /// character as long as they are contiguous. 717 static std::tuple<mlir::Value, mlir::Value> 718 genBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc, 719 const Fortran::lower::SomeExpr &expr, mlir::Type strTy, 720 mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) { 721 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 722 fir::ExtendedValue exprAddr = converter.genExprAddr(expr, stmtCtx); 723 fir::factory::CharacterExprHelper helper(builder, loc); 724 using ValuePair = std::pair<mlir::Value, mlir::Value>; 725 auto [buff, len] = exprAddr.match( 726 [&](const fir::CharBoxValue &x) -> ValuePair { 727 return {x.getBuffer(), x.getLen()}; 728 }, 729 [&](const fir::CharArrayBoxValue &x) -> ValuePair { 730 fir::CharBoxValue scalar = helper.toScalarCharacter(x); 731 return {scalar.getBuffer(), scalar.getLen()}; 732 }, 733 [&](const fir::BoxValue &) -> ValuePair { 734 // May need to copy before after IO to handle contiguous 735 // aspect. Not sure descriptor can get here though. 736 TODO(loc, "character descriptor to contiguous buffer"); 737 }, 738 [&](const auto &) -> ValuePair { 739 llvm::report_fatal_error( 740 "internal error: IO buffer is not a character"); 741 }); 742 buff = builder.createConvert(loc, strTy, buff); 743 len = builder.createConvert(loc, lenTy, len); 744 return {buff, len}; 745 } 746 747 /// Lower a string literal. Many arguments to the runtime are conveyed as 748 /// Fortran CHARACTER literals. 749 template <typename A> 750 static std::tuple<mlir::Value, mlir::Value, mlir::Value> 751 lowerStringLit(Fortran::lower::AbstractConverter &converter, mlir::Location loc, 752 Fortran::lower::StatementContext &stmtCtx, const A &syntax, 753 mlir::Type strTy, mlir::Type lenTy, mlir::Type ty2 = {}) { 754 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 755 auto *expr = Fortran::semantics::GetExpr(syntax); 756 if (!expr) 757 fir::emitFatalError(loc, "internal error: null semantic expr in IO"); 758 auto [buff, len] = genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx); 759 mlir::Value kind; 760 if (ty2) { 761 auto kindVal = expr->GetType().value().kind(); 762 kind = builder.create<mlir::arith::ConstantOp>( 763 loc, builder.getIntegerAttr(ty2, kindVal)); 764 } 765 return {buff, len, kind}; 766 } 767 768 /// Pass the body of the FORMAT statement in as if it were a CHARACTER literal 769 /// constant. NB: This is the prescribed manner in which the front-end passes 770 /// this information to lowering. 771 static std::tuple<mlir::Value, mlir::Value, mlir::Value> 772 lowerSourceTextAsStringLit(Fortran::lower::AbstractConverter &converter, 773 mlir::Location loc, llvm::StringRef text, 774 mlir::Type strTy, mlir::Type lenTy) { 775 text = text.drop_front(text.find('(')); 776 text = text.take_front(text.rfind(')') + 1); 777 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 778 mlir::Value addrGlobalStringLit = 779 fir::getBase(fir::factory::createStringLiteral(builder, loc, text)); 780 mlir::Value buff = builder.createConvert(loc, strTy, addrGlobalStringLit); 781 mlir::Value len = builder.createIntegerConstant(loc, lenTy, text.size()); 782 return {buff, len, mlir::Value{}}; 783 } 784 785 //===----------------------------------------------------------------------===// 786 // Handle IO statement specifiers. 787 // These are threaded together for a single statement via the passed cookie. 788 //===----------------------------------------------------------------------===// 789 790 /// Generic to build an integral argument to the runtime. 791 template <typename A, typename B> 792 mlir::Value genIntIOOption(Fortran::lower::AbstractConverter &converter, 793 mlir::Location loc, mlir::Value cookie, 794 const B &spec) { 795 Fortran::lower::StatementContext localStatementCtx; 796 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 797 mlir::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder); 798 mlir::FunctionType ioFuncTy = ioFunc.getType(); 799 mlir::Value expr = fir::getBase(converter.genExprValue( 800 Fortran::semantics::GetExpr(spec.v), localStatementCtx, loc)); 801 mlir::Value val = builder.createConvert(loc, ioFuncTy.getInput(1), expr); 802 llvm::SmallVector<mlir::Value> ioArgs = {cookie, val}; 803 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0); 804 } 805 806 /// Generic to build a string argument to the runtime. This passes a CHARACTER 807 /// as a pointer to the buffer and a LEN parameter. 808 template <typename A, typename B> 809 mlir::Value genCharIOOption(Fortran::lower::AbstractConverter &converter, 810 mlir::Location loc, mlir::Value cookie, 811 const B &spec) { 812 Fortran::lower::StatementContext localStatementCtx; 813 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 814 mlir::FuncOp ioFunc = getIORuntimeFunc<A>(loc, builder); 815 mlir::FunctionType ioFuncTy = ioFunc.getType(); 816 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup = 817 lowerStringLit(converter, loc, localStatementCtx, spec, 818 ioFuncTy.getInput(1), ioFuncTy.getInput(2)); 819 llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup), 820 std::get<1>(tup)}; 821 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0); 822 } 823 824 template <typename A> 825 mlir::Value genIOOption(Fortran::lower::AbstractConverter &converter, 826 mlir::Location loc, mlir::Value cookie, const A &spec) { 827 // These specifiers are processed in advance elsewhere - skip them here. 828 using PreprocessedSpecs = 829 std::tuple<Fortran::parser::EndLabel, Fortran::parser::EorLabel, 830 Fortran::parser::ErrLabel, Fortran::parser::FileUnitNumber, 831 Fortran::parser::Format, Fortran::parser::IoUnit, 832 Fortran::parser::MsgVariable, Fortran::parser::Name, 833 Fortran::parser::StatVariable>; 834 static_assert(Fortran::common::HasMember<A, PreprocessedSpecs>, 835 "missing genIOOPtion specialization"); 836 return {}; 837 } 838 839 template <> 840 mlir::Value genIOOption<Fortran::parser::FileNameExpr>( 841 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 842 mlir::Value cookie, const Fortran::parser::FileNameExpr &spec) { 843 Fortran::lower::StatementContext localStatementCtx; 844 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 845 // has an extra KIND argument 846 mlir::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(SetFile)>(loc, builder); 847 mlir::FunctionType ioFuncTy = ioFunc.getType(); 848 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup = 849 lowerStringLit(converter, loc, localStatementCtx, spec, 850 ioFuncTy.getInput(1), ioFuncTy.getInput(2)); 851 llvm::SmallVector<mlir::Value> ioArgs{cookie, std::get<0>(tup), 852 std::get<1>(tup)}; 853 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0); 854 } 855 856 template <> 857 mlir::Value genIOOption<Fortran::parser::ConnectSpec::CharExpr>( 858 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 859 mlir::Value cookie, const Fortran::parser::ConnectSpec::CharExpr &spec) { 860 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 861 mlir::FuncOp ioFunc; 862 switch (std::get<Fortran::parser::ConnectSpec::CharExpr::Kind>(spec.t)) { 863 case Fortran::parser::ConnectSpec::CharExpr::Kind::Access: 864 ioFunc = getIORuntimeFunc<mkIOKey(SetAccess)>(loc, builder); 865 break; 866 case Fortran::parser::ConnectSpec::CharExpr::Kind::Action: 867 ioFunc = getIORuntimeFunc<mkIOKey(SetAction)>(loc, builder); 868 break; 869 case Fortran::parser::ConnectSpec::CharExpr::Kind::Asynchronous: 870 ioFunc = getIORuntimeFunc<mkIOKey(SetAsynchronous)>(loc, builder); 871 break; 872 case Fortran::parser::ConnectSpec::CharExpr::Kind::Blank: 873 ioFunc = getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder); 874 break; 875 case Fortran::parser::ConnectSpec::CharExpr::Kind::Decimal: 876 ioFunc = getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder); 877 break; 878 case Fortran::parser::ConnectSpec::CharExpr::Kind::Delim: 879 ioFunc = getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder); 880 break; 881 case Fortran::parser::ConnectSpec::CharExpr::Kind::Encoding: 882 ioFunc = getIORuntimeFunc<mkIOKey(SetEncoding)>(loc, builder); 883 break; 884 case Fortran::parser::ConnectSpec::CharExpr::Kind::Form: 885 ioFunc = getIORuntimeFunc<mkIOKey(SetForm)>(loc, builder); 886 break; 887 case Fortran::parser::ConnectSpec::CharExpr::Kind::Pad: 888 ioFunc = getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder); 889 break; 890 case Fortran::parser::ConnectSpec::CharExpr::Kind::Position: 891 ioFunc = getIORuntimeFunc<mkIOKey(SetPosition)>(loc, builder); 892 break; 893 case Fortran::parser::ConnectSpec::CharExpr::Kind::Round: 894 ioFunc = getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder); 895 break; 896 case Fortran::parser::ConnectSpec::CharExpr::Kind::Sign: 897 ioFunc = getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder); 898 break; 899 case Fortran::parser::ConnectSpec::CharExpr::Kind::Carriagecontrol: 900 ioFunc = getIORuntimeFunc<mkIOKey(SetCarriagecontrol)>(loc, builder); 901 break; 902 case Fortran::parser::ConnectSpec::CharExpr::Kind::Convert: 903 TODO(loc, "CONVERT not part of the runtime::io interface"); 904 case Fortran::parser::ConnectSpec::CharExpr::Kind::Dispose: 905 TODO(loc, "DISPOSE not part of the runtime::io interface"); 906 } 907 Fortran::lower::StatementContext localStatementCtx; 908 mlir::FunctionType ioFuncTy = ioFunc.getType(); 909 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup = 910 lowerStringLit(converter, loc, localStatementCtx, 911 std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t), 912 ioFuncTy.getInput(1), ioFuncTy.getInput(2)); 913 llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup), 914 std::get<1>(tup)}; 915 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0); 916 } 917 918 template <> 919 mlir::Value genIOOption<Fortran::parser::ConnectSpec::Recl>( 920 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 921 mlir::Value cookie, const Fortran::parser::ConnectSpec::Recl &spec) { 922 return genIntIOOption<mkIOKey(SetRecl)>(converter, loc, cookie, spec); 923 } 924 925 template <> 926 mlir::Value genIOOption<Fortran::parser::ConnectSpec::Newunit>( 927 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 928 mlir::Value cookie, const Fortran::parser::ConnectSpec::Newunit &spec) { 929 Fortran::lower::StatementContext stmtCtx; 930 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 931 mlir::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(GetNewUnit)>(loc, builder); 932 mlir::FunctionType ioFuncTy = ioFunc.getType(); 933 const auto *var = Fortran::semantics::GetExpr(spec); 934 mlir::Value addr = builder.createConvert( 935 loc, ioFuncTy.getInput(1), 936 fir::getBase(converter.genExprAddr(var, stmtCtx, loc))); 937 auto kind = builder.createIntegerConstant(loc, ioFuncTy.getInput(2), 938 var->GetType().value().kind()); 939 llvm::SmallVector<mlir::Value> ioArgs = {cookie, addr, kind}; 940 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0); 941 } 942 943 template <> 944 mlir::Value genIOOption<Fortran::parser::StatusExpr>( 945 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 946 mlir::Value cookie, const Fortran::parser::StatusExpr &spec) { 947 return genCharIOOption<mkIOKey(SetStatus)>(converter, loc, cookie, spec.v); 948 } 949 950 template <> 951 mlir::Value genIOOption<Fortran::parser::IoControlSpec::CharExpr>( 952 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 953 mlir::Value cookie, const Fortran::parser::IoControlSpec::CharExpr &spec) { 954 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 955 mlir::FuncOp ioFunc; 956 switch (std::get<Fortran::parser::IoControlSpec::CharExpr::Kind>(spec.t)) { 957 case Fortran::parser::IoControlSpec::CharExpr::Kind::Advance: 958 ioFunc = getIORuntimeFunc<mkIOKey(SetAdvance)>(loc, builder); 959 break; 960 case Fortran::parser::IoControlSpec::CharExpr::Kind::Blank: 961 ioFunc = getIORuntimeFunc<mkIOKey(SetBlank)>(loc, builder); 962 break; 963 case Fortran::parser::IoControlSpec::CharExpr::Kind::Decimal: 964 ioFunc = getIORuntimeFunc<mkIOKey(SetDecimal)>(loc, builder); 965 break; 966 case Fortran::parser::IoControlSpec::CharExpr::Kind::Delim: 967 ioFunc = getIORuntimeFunc<mkIOKey(SetDelim)>(loc, builder); 968 break; 969 case Fortran::parser::IoControlSpec::CharExpr::Kind::Pad: 970 ioFunc = getIORuntimeFunc<mkIOKey(SetPad)>(loc, builder); 971 break; 972 case Fortran::parser::IoControlSpec::CharExpr::Kind::Round: 973 ioFunc = getIORuntimeFunc<mkIOKey(SetRound)>(loc, builder); 974 break; 975 case Fortran::parser::IoControlSpec::CharExpr::Kind::Sign: 976 ioFunc = getIORuntimeFunc<mkIOKey(SetSign)>(loc, builder); 977 break; 978 } 979 Fortran::lower::StatementContext localStatementCtx; 980 mlir::FunctionType ioFuncTy = ioFunc.getType(); 981 std::tuple<mlir::Value, mlir::Value, mlir::Value> tup = 982 lowerStringLit(converter, loc, localStatementCtx, 983 std::get<Fortran::parser::ScalarDefaultCharExpr>(spec.t), 984 ioFuncTy.getInput(1), ioFuncTy.getInput(2)); 985 llvm::SmallVector<mlir::Value> ioArgs = {cookie, std::get<0>(tup), 986 std::get<1>(tup)}; 987 return builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0); 988 } 989 990 template <> 991 mlir::Value genIOOption<Fortran::parser::IoControlSpec::Asynchronous>( 992 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 993 mlir::Value cookie, 994 const Fortran::parser::IoControlSpec::Asynchronous &spec) { 995 return genCharIOOption<mkIOKey(SetAsynchronous)>(converter, loc, cookie, 996 spec.v); 997 } 998 999 template <> 1000 mlir::Value genIOOption<Fortran::parser::IdVariable>( 1001 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1002 mlir::Value cookie, const Fortran::parser::IdVariable &spec) { 1003 TODO(loc, "asynchronous ID not implemented"); 1004 } 1005 1006 template <> 1007 mlir::Value genIOOption<Fortran::parser::IoControlSpec::Pos>( 1008 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1009 mlir::Value cookie, const Fortran::parser::IoControlSpec::Pos &spec) { 1010 return genIntIOOption<mkIOKey(SetPos)>(converter, loc, cookie, spec); 1011 } 1012 1013 template <> 1014 mlir::Value genIOOption<Fortran::parser::IoControlSpec::Rec>( 1015 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1016 mlir::Value cookie, const Fortran::parser::IoControlSpec::Rec &spec) { 1017 return genIntIOOption<mkIOKey(SetRec)>(converter, loc, cookie, spec); 1018 } 1019 1020 /// Generate runtime call to query the read size after an input statement if 1021 /// the statement has SIZE control-spec. 1022 template <typename A> 1023 static void genIOReadSize(Fortran::lower::AbstractConverter &converter, 1024 mlir::Location loc, mlir::Value cookie, 1025 const A &specList, bool checkResult) { 1026 // This call is not conditional on the current IO status (ok) because the size 1027 // needs to be filled even if some error condition (end-of-file...) was met 1028 // during the input statement (in which case the runtime may return zero for 1029 // the size read). 1030 for (const auto &spec : specList) 1031 if (const auto *size = 1032 std::get_if<Fortran::parser::IoControlSpec::Size>(&spec.u)) { 1033 1034 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1035 mlir::FuncOp ioFunc = getIORuntimeFunc<mkIOKey(GetSize)>(loc, builder); 1036 auto sizeValue = 1037 builder.create<fir::CallOp>(loc, ioFunc, mlir::ValueRange{cookie}) 1038 .getResult(0); 1039 Fortran::lower::StatementContext localStatementCtx; 1040 fir::ExtendedValue var = converter.genExprAddr( 1041 Fortran::semantics::GetExpr(size->v), localStatementCtx, loc); 1042 mlir::Value varAddr = fir::getBase(var); 1043 mlir::Type varType = fir::unwrapPassByRefType(varAddr.getType()); 1044 mlir::Value sizeCast = builder.createConvert(loc, varType, sizeValue); 1045 builder.create<fir::StoreOp>(loc, sizeCast, varAddr); 1046 break; 1047 } 1048 } 1049 1050 //===----------------------------------------------------------------------===// 1051 // Gather IO statement condition specifier information (if any). 1052 //===----------------------------------------------------------------------===// 1053 1054 template <typename SEEK, typename A> 1055 static bool hasX(const A &list) { 1056 for (const auto &spec : list) 1057 if (std::holds_alternative<SEEK>(spec.u)) 1058 return true; 1059 return false; 1060 } 1061 1062 template <typename SEEK, typename A> 1063 static bool hasMem(const A &stmt) { 1064 return hasX<SEEK>(stmt.v); 1065 } 1066 1067 /// Get the sought expression from the specifier list. 1068 template <typename SEEK, typename A> 1069 static const Fortran::lower::SomeExpr *getExpr(const A &stmt) { 1070 for (const auto &spec : stmt.v) 1071 if (auto *f = std::get_if<SEEK>(&spec.u)) 1072 return Fortran::semantics::GetExpr(f->v); 1073 llvm::report_fatal_error("must have a file unit"); 1074 } 1075 1076 /// For each specifier, build the appropriate call, threading the cookie. 1077 template <typename A> 1078 static void threadSpecs(Fortran::lower::AbstractConverter &converter, 1079 mlir::Location loc, mlir::Value cookie, 1080 const A &specList, bool checkResult, mlir::Value &ok) { 1081 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1082 for (const auto &spec : specList) { 1083 makeNextConditionalOn(builder, loc, checkResult, ok); 1084 ok = std::visit( 1085 Fortran::common::visitors{ 1086 [&](const Fortran::parser::IoControlSpec::Size &x) -> mlir::Value { 1087 // Size must be queried after the related READ runtime calls, not 1088 // before. 1089 return ok; 1090 }, 1091 [&](const auto &x) { 1092 return genIOOption(converter, loc, cookie, x); 1093 }}, 1094 spec.u); 1095 } 1096 } 1097 1098 /// Most IO statements allow one or more of five optional exception condition 1099 /// handling specifiers: ERR, EOR, END, IOSTAT, and IOMSG. The first three 1100 /// cause control flow to transfer to another statement. The final two return 1101 /// information from the runtime, via a variable, about the nature of the 1102 /// condition that occurred. These condition specifiers are handled here. 1103 template <typename A> 1104 static void 1105 genConditionHandlerCall(Fortran::lower::AbstractConverter &converter, 1106 mlir::Location loc, mlir::Value cookie, 1107 const A &specList, ConditionSpecInfo &csi) { 1108 for (const auto &spec : specList) { 1109 std::visit( 1110 Fortran::common::visitors{ 1111 [&](const Fortran::parser::StatVariable &var) { 1112 csi.ioStatExpr = Fortran::semantics::GetExpr(var); 1113 }, 1114 [&](const Fortran::parser::InquireSpec::IntVar &var) { 1115 if (std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t) == 1116 Fortran::parser::InquireSpec::IntVar::Kind::Iostat) 1117 csi.ioStatExpr = Fortran::semantics::GetExpr( 1118 std::get<Fortran::parser::ScalarIntVariable>(var.t)); 1119 }, 1120 [&](const Fortran::parser::MsgVariable &var) { 1121 csi.ioMsgExpr = Fortran::semantics::GetExpr(var); 1122 }, 1123 [&](const Fortran::parser::InquireSpec::CharVar &var) { 1124 if (std::get<Fortran::parser::InquireSpec::CharVar::Kind>( 1125 var.t) == 1126 Fortran::parser::InquireSpec::CharVar::Kind::Iomsg) 1127 csi.ioMsgExpr = Fortran::semantics::GetExpr( 1128 std::get<Fortran::parser::ScalarDefaultCharVariable>( 1129 var.t)); 1130 }, 1131 [&](const Fortran::parser::EndLabel &) { csi.hasEnd = true; }, 1132 [&](const Fortran::parser::EorLabel &) { csi.hasEor = true; }, 1133 [&](const Fortran::parser::ErrLabel &) { csi.hasErr = true; }, 1134 [](const auto &) {}}, 1135 spec.u); 1136 } 1137 if (!csi.hasAnyConditionSpec()) 1138 return; 1139 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1140 mlir::FuncOp enableHandlers = 1141 getIORuntimeFunc<mkIOKey(EnableHandlers)>(loc, builder); 1142 mlir::Type boolType = enableHandlers.getType().getInput(1); 1143 auto boolValue = [&](bool specifierIsPresent) { 1144 return builder.create<mlir::arith::ConstantOp>( 1145 loc, builder.getIntegerAttr(boolType, specifierIsPresent)); 1146 }; 1147 llvm::SmallVector<mlir::Value> ioArgs = {cookie, 1148 boolValue(csi.ioStatExpr != nullptr), 1149 boolValue(csi.hasErr), 1150 boolValue(csi.hasEnd), 1151 boolValue(csi.hasEor), 1152 boolValue(csi.ioMsgExpr != nullptr)}; 1153 builder.create<fir::CallOp>(loc, enableHandlers, ioArgs); 1154 } 1155 1156 //===----------------------------------------------------------------------===// 1157 // Data transfer helpers 1158 //===----------------------------------------------------------------------===// 1159 1160 template <typename SEEK, typename A> 1161 static bool hasIOControl(const A &stmt) { 1162 return hasX<SEEK>(stmt.controls); 1163 } 1164 1165 template <typename SEEK, typename A> 1166 static const auto *getIOControl(const A &stmt) { 1167 for (const auto &spec : stmt.controls) 1168 if (const auto *result = std::get_if<SEEK>(&spec.u)) 1169 return result; 1170 return static_cast<const SEEK *>(nullptr); 1171 } 1172 1173 /// Returns true iff the expression in the parse tree is not really a format but 1174 /// rather a namelist group. 1175 template <typename A> 1176 static bool formatIsActuallyNamelist(const A &format) { 1177 if (auto *e = std::get_if<Fortran::parser::Expr>(&format.u)) { 1178 auto *expr = Fortran::semantics::GetExpr(*e); 1179 if (const Fortran::semantics::Symbol *y = 1180 Fortran::evaluate::UnwrapWholeSymbolDataRef(*expr)) 1181 return y->has<Fortran::semantics::NamelistDetails>(); 1182 } 1183 return false; 1184 } 1185 1186 template <typename A> 1187 static bool isDataTransferFormatted(const A &stmt) { 1188 if (stmt.format) 1189 return !formatIsActuallyNamelist(*stmt.format); 1190 return hasIOControl<Fortran::parser::Format>(stmt); 1191 } 1192 template <> 1193 constexpr bool isDataTransferFormatted<Fortran::parser::PrintStmt>( 1194 const Fortran::parser::PrintStmt &) { 1195 return true; // PRINT is always formatted 1196 } 1197 1198 template <typename A> 1199 static bool isDataTransferList(const A &stmt) { 1200 if (stmt.format) 1201 return std::holds_alternative<Fortran::parser::Star>(stmt.format->u); 1202 if (auto *mem = getIOControl<Fortran::parser::Format>(stmt)) 1203 return std::holds_alternative<Fortran::parser::Star>(mem->u); 1204 return false; 1205 } 1206 template <> 1207 bool isDataTransferList<Fortran::parser::PrintStmt>( 1208 const Fortran::parser::PrintStmt &stmt) { 1209 return std::holds_alternative<Fortran::parser::Star>( 1210 std::get<Fortran::parser::Format>(stmt.t).u); 1211 } 1212 1213 template <typename A> 1214 static bool isDataTransferInternal(const A &stmt) { 1215 if (stmt.iounit.has_value()) 1216 return std::holds_alternative<Fortran::parser::Variable>(stmt.iounit->u); 1217 if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt)) 1218 return std::holds_alternative<Fortran::parser::Variable>(unit->u); 1219 return false; 1220 } 1221 template <> 1222 constexpr bool isDataTransferInternal<Fortran::parser::PrintStmt>( 1223 const Fortran::parser::PrintStmt &) { 1224 return false; 1225 } 1226 1227 /// If the variable `var` is an array or of a KIND other than the default 1228 /// (normally 1), then a descriptor is required by the runtime IO API. This 1229 /// condition holds even in F77 sources. 1230 static llvm::Optional<fir::ExtendedValue> getVariableBufferRequiredDescriptor( 1231 Fortran::lower::AbstractConverter &converter, 1232 const Fortran::parser::Variable &var, 1233 Fortran::lower::StatementContext &stmtCtx) { 1234 fir::ExtendedValue varBox = 1235 converter.genExprAddr(var.typedExpr->v.value(), stmtCtx); 1236 fir::KindTy defCharKind = converter.getKindMap().defaultCharacterKind(); 1237 mlir::Value varAddr = fir::getBase(varBox); 1238 if (fir::factory::CharacterExprHelper::getCharacterOrSequenceKind( 1239 varAddr.getType()) != defCharKind) 1240 return varBox; 1241 if (fir::factory::CharacterExprHelper::isArray(varAddr.getType())) 1242 return varBox; 1243 return llvm::None; 1244 } 1245 1246 template <typename A> 1247 static llvm::Optional<fir::ExtendedValue> 1248 maybeGetInternalIODescriptor(Fortran::lower::AbstractConverter &converter, 1249 const A &stmt, 1250 Fortran::lower::StatementContext &stmtCtx) { 1251 if (stmt.iounit.has_value()) 1252 if (auto *var = std::get_if<Fortran::parser::Variable>(&stmt.iounit->u)) 1253 return getVariableBufferRequiredDescriptor(converter, *var, stmtCtx); 1254 if (auto *unit = getIOControl<Fortran::parser::IoUnit>(stmt)) 1255 if (auto *var = std::get_if<Fortran::parser::Variable>(&unit->u)) 1256 return getVariableBufferRequiredDescriptor(converter, *var, stmtCtx); 1257 return llvm::None; 1258 } 1259 template <> 1260 inline llvm::Optional<fir::ExtendedValue> 1261 maybeGetInternalIODescriptor<Fortran::parser::PrintStmt>( 1262 Fortran::lower::AbstractConverter &, const Fortran::parser::PrintStmt &, 1263 Fortran::lower::StatementContext &) { 1264 return llvm::None; 1265 } 1266 1267 template <typename A> 1268 static bool isDataTransferAsynchronous(mlir::Location loc, const A &stmt) { 1269 if (auto *asynch = 1270 getIOControl<Fortran::parser::IoControlSpec::Asynchronous>(stmt)) { 1271 // FIXME: should contain a string of YES or NO 1272 TODO(loc, "asynchronous transfers not implemented in runtime"); 1273 } 1274 return false; 1275 } 1276 template <> 1277 bool isDataTransferAsynchronous<Fortran::parser::PrintStmt>( 1278 mlir::Location, const Fortran::parser::PrintStmt &) { 1279 return false; 1280 } 1281 1282 template <typename A> 1283 static bool isDataTransferNamelist(const A &stmt) { 1284 if (stmt.format) 1285 return formatIsActuallyNamelist(*stmt.format); 1286 return hasIOControl<Fortran::parser::Name>(stmt); 1287 } 1288 template <> 1289 constexpr bool isDataTransferNamelist<Fortran::parser::PrintStmt>( 1290 const Fortran::parser::PrintStmt &) { 1291 return false; 1292 } 1293 1294 /// Lowers a format statment that uses an assigned variable label reference as 1295 /// a select operation to allow for run-time selection of the format statement. 1296 static std::tuple<mlir::Value, mlir::Value, mlir::Value> 1297 lowerReferenceAsStringSelect(Fortran::lower::AbstractConverter &converter, 1298 mlir::Location loc, 1299 const Fortran::lower::SomeExpr &expr, 1300 mlir::Type strTy, mlir::Type lenTy, 1301 Fortran::lower::StatementContext &stmtCtx) { 1302 // Possible optimization TODO: Instead of inlining a selectOp every time there 1303 // is a variable reference to a format statement, a function with the selectOp 1304 // could be generated to reduce code size. It is not clear if such an 1305 // optimization would be deployed very often or improve the object code 1306 // beyond, say, what GVN/GCM might produce. 1307 1308 // Create the requisite blocks to inline a selectOp. 1309 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1310 mlir::Block *startBlock = builder.getBlock(); 1311 mlir::Block *endBlock = startBlock->splitBlock(builder.getInsertionPoint()); 1312 mlir::Block *block = startBlock->splitBlock(builder.getInsertionPoint()); 1313 builder.setInsertionPointToEnd(block); 1314 1315 llvm::SmallVector<int64_t> indexList; 1316 llvm::SmallVector<mlir::Block *> blockList; 1317 1318 auto symbol = GetLastSymbol(&expr); 1319 Fortran::lower::pft::LabelSet labels; 1320 [[maybe_unused]] auto foundLabelSet = 1321 converter.lookupLabelSet(*symbol, labels); 1322 assert(foundLabelSet && "Label not found in map"); 1323 1324 for (auto label : labels) { 1325 indexList.push_back(label); 1326 auto *eval = converter.lookupLabel(label); 1327 assert(eval && "Label is missing from the table"); 1328 1329 llvm::StringRef text = toStringRef(eval->position); 1330 mlir::Value stringRef; 1331 mlir::Value stringLen; 1332 if (eval->isA<Fortran::parser::FormatStmt>()) { 1333 assert(text.find('(') != llvm::StringRef::npos && 1334 "FORMAT is unexpectedly ill-formed"); 1335 // This is a format statement, so extract the spec from the text. 1336 std::tuple<mlir::Value, mlir::Value, mlir::Value> stringLit = 1337 lowerSourceTextAsStringLit(converter, loc, text, strTy, lenTy); 1338 stringRef = std::get<0>(stringLit); 1339 stringLen = std::get<1>(stringLit); 1340 } else { 1341 // This is not a format statement, so use null. 1342 stringRef = builder.createConvert( 1343 loc, strTy, 1344 builder.createIntegerConstant(loc, builder.getIndexType(), 0)); 1345 stringLen = builder.createIntegerConstant(loc, lenTy, 0); 1346 } 1347 1348 // Pass the format string reference and the string length out of the select 1349 // statement. 1350 llvm::SmallVector<mlir::Value> args = {stringRef, stringLen}; 1351 builder.create<mlir::cf::BranchOp>(loc, endBlock, args); 1352 1353 // Add block to the list of cases and make a new one. 1354 blockList.push_back(block); 1355 block = block->splitBlock(builder.getInsertionPoint()); 1356 builder.setInsertionPointToEnd(block); 1357 } 1358 1359 // Create the unit case which should result in an error. 1360 auto *unitBlock = block->splitBlock(builder.getInsertionPoint()); 1361 builder.setInsertionPointToEnd(unitBlock); 1362 1363 // Crash the program. 1364 builder.create<fir::UnreachableOp>(loc); 1365 1366 // Add unit case to the select statement. 1367 blockList.push_back(unitBlock); 1368 1369 // Lower the selectOp. 1370 builder.setInsertionPointToEnd(startBlock); 1371 auto label = fir::getBase(converter.genExprValue(&expr, stmtCtx, loc)); 1372 builder.create<fir::SelectOp>(loc, label, indexList, blockList); 1373 1374 builder.setInsertionPointToEnd(endBlock); 1375 endBlock->addArgument(strTy, loc); 1376 endBlock->addArgument(lenTy, loc); 1377 1378 // Handle and return the string reference and length selected by the selectOp. 1379 auto buff = endBlock->getArgument(0); 1380 auto len = endBlock->getArgument(1); 1381 1382 return {buff, len, mlir::Value{}}; 1383 } 1384 1385 /// Generate a reference to a format string. There are four cases - a format 1386 /// statement label, a character format expression, an integer that holds the 1387 /// label of a format statement, and the * case. The first three are done here. 1388 /// The * case is done elsewhere. 1389 static std::tuple<mlir::Value, mlir::Value, mlir::Value> 1390 genFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1391 const Fortran::parser::Format &format, mlir::Type strTy, 1392 mlir::Type lenTy, Fortran::lower::StatementContext &stmtCtx) { 1393 if (const auto *label = std::get_if<Fortran::parser::Label>(&format.u)) { 1394 // format statement label 1395 auto eval = converter.lookupLabel(*label); 1396 assert(eval && "FORMAT not found in PROCEDURE"); 1397 return lowerSourceTextAsStringLit( 1398 converter, loc, toStringRef(eval->position), strTy, lenTy); 1399 } 1400 const auto *pExpr = std::get_if<Fortran::parser::Expr>(&format.u); 1401 assert(pExpr && "missing format expression"); 1402 auto e = Fortran::semantics::GetExpr(*pExpr); 1403 if (Fortran::semantics::ExprHasTypeCategory( 1404 *e, Fortran::common::TypeCategory::Character)) 1405 // character expression 1406 return lowerStringLit(converter, loc, stmtCtx, *pExpr, strTy, lenTy); 1407 1408 if (Fortran::semantics::ExprHasTypeCategory( 1409 *e, Fortran::common::TypeCategory::Integer) && 1410 e->Rank() == 0 && Fortran::evaluate::UnwrapWholeSymbolDataRef(*e)) { 1411 // Treat as a scalar integer variable containing an ASSIGN label. 1412 return lowerReferenceAsStringSelect(converter, loc, *e, strTy, lenTy, 1413 stmtCtx); 1414 } 1415 1416 // Legacy extension: it is possible that `*e` is not a scalar INTEGER 1417 // variable containing a label value. The output appears to be the source text 1418 // that initialized the variable? Needs more investigatation. 1419 TODO(loc, "io-control-spec contains a reference to a non-integer, " 1420 "non-scalar, or non-variable"); 1421 } 1422 1423 template <typename A> 1424 std::tuple<mlir::Value, mlir::Value, mlir::Value> 1425 getFormat(Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1426 const A &stmt, mlir::Type strTy, mlir::Type lenTy, 1427 Fortran ::lower::StatementContext &stmtCtx) { 1428 if (stmt.format && !formatIsActuallyNamelist(*stmt.format)) 1429 return genFormat(converter, loc, *stmt.format, strTy, lenTy, stmtCtx); 1430 return genFormat(converter, loc, *getIOControl<Fortran::parser::Format>(stmt), 1431 strTy, lenTy, stmtCtx); 1432 } 1433 template <> 1434 std::tuple<mlir::Value, mlir::Value, mlir::Value> 1435 getFormat<Fortran::parser::PrintStmt>( 1436 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1437 const Fortran::parser::PrintStmt &stmt, mlir::Type strTy, mlir::Type lenTy, 1438 Fortran::lower::StatementContext &stmtCtx) { 1439 return genFormat(converter, loc, std::get<Fortran::parser::Format>(stmt.t), 1440 strTy, lenTy, stmtCtx); 1441 } 1442 1443 /// Get a buffer for an internal file data transfer. 1444 template <typename A> 1445 std::tuple<mlir::Value, mlir::Value> 1446 getBuffer(Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1447 const A &stmt, mlir::Type strTy, mlir::Type lenTy, 1448 Fortran::lower::StatementContext &stmtCtx) { 1449 const Fortran::parser::IoUnit *iounit = 1450 stmt.iounit ? &*stmt.iounit : getIOControl<Fortran::parser::IoUnit>(stmt); 1451 if (iounit) 1452 if (auto *var = std::get_if<Fortran::parser::Variable>(&iounit->u)) 1453 if (auto *expr = Fortran::semantics::GetExpr(*var)) 1454 return genBuffer(converter, loc, *expr, strTy, lenTy, stmtCtx); 1455 llvm::report_fatal_error("failed to get IoUnit expr in lowering"); 1456 } 1457 1458 static mlir::Value genIOUnit(Fortran::lower::AbstractConverter &converter, 1459 mlir::Location loc, 1460 const Fortran::parser::IoUnit &iounit, 1461 mlir::Type ty, 1462 Fortran::lower::StatementContext &stmtCtx) { 1463 auto &builder = converter.getFirOpBuilder(); 1464 if (auto *e = std::get_if<Fortran::parser::FileUnitNumber>(&iounit.u)) { 1465 auto ex = fir::getBase( 1466 converter.genExprValue(Fortran::semantics::GetExpr(*e), stmtCtx, loc)); 1467 return builder.createConvert(loc, ty, ex); 1468 } 1469 return builder.create<mlir::arith::ConstantOp>( 1470 loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit)); 1471 } 1472 1473 template <typename A> 1474 mlir::Value getIOUnit(Fortran::lower::AbstractConverter &converter, 1475 mlir::Location loc, const A &stmt, mlir::Type ty, 1476 Fortran::lower::StatementContext &stmtCtx) { 1477 if (stmt.iounit) 1478 return genIOUnit(converter, loc, *stmt.iounit, ty, stmtCtx); 1479 if (auto *iounit = getIOControl<Fortran::parser::IoUnit>(stmt)) 1480 return genIOUnit(converter, loc, *iounit, ty, stmtCtx); 1481 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1482 return builder.create<mlir::arith::ConstantOp>( 1483 loc, builder.getIntegerAttr(ty, Fortran::runtime::io::DefaultUnit)); 1484 } 1485 1486 //===----------------------------------------------------------------------===// 1487 // Generators for each IO statement type. 1488 //===----------------------------------------------------------------------===// 1489 1490 template <typename K, typename S> 1491 static mlir::Value genBasicIOStmt(Fortran::lower::AbstractConverter &converter, 1492 const S &stmt) { 1493 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1494 Fortran::lower::StatementContext stmtCtx; 1495 mlir::Location loc = converter.getCurrentLocation(); 1496 mlir::FuncOp beginFunc = getIORuntimeFunc<K>(loc, builder); 1497 mlir::FunctionType beginFuncTy = beginFunc.getType(); 1498 mlir::Value unit = fir::getBase(converter.genExprValue( 1499 getExpr<Fortran::parser::FileUnitNumber>(stmt), stmtCtx, loc)); 1500 mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit); 1501 mlir::Value file = locToFilename(converter, loc, beginFuncTy.getInput(1)); 1502 mlir::Value line = locToLineNo(converter, loc, beginFuncTy.getInput(2)); 1503 auto call = builder.create<fir::CallOp>(loc, beginFunc, 1504 mlir::ValueRange{un, file, line}); 1505 mlir::Value cookie = call.getResult(0); 1506 ConditionSpecInfo csi; 1507 genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); 1508 mlir::Value ok; 1509 auto insertPt = builder.saveInsertionPoint(); 1510 threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok); 1511 builder.restoreInsertionPoint(insertPt); 1512 return genEndIO(converter, converter.getCurrentLocation(), cookie, csi, 1513 stmtCtx); 1514 } 1515 1516 mlir::Value Fortran::lower::genBackspaceStatement( 1517 Fortran::lower::AbstractConverter &converter, 1518 const Fortran::parser::BackspaceStmt &stmt) { 1519 return genBasicIOStmt<mkIOKey(BeginBackspace)>(converter, stmt); 1520 } 1521 1522 mlir::Value Fortran::lower::genEndfileStatement( 1523 Fortran::lower::AbstractConverter &converter, 1524 const Fortran::parser::EndfileStmt &stmt) { 1525 return genBasicIOStmt<mkIOKey(BeginEndfile)>(converter, stmt); 1526 } 1527 1528 mlir::Value 1529 Fortran::lower::genFlushStatement(Fortran::lower::AbstractConverter &converter, 1530 const Fortran::parser::FlushStmt &stmt) { 1531 return genBasicIOStmt<mkIOKey(BeginFlush)>(converter, stmt); 1532 } 1533 1534 mlir::Value 1535 Fortran::lower::genRewindStatement(Fortran::lower::AbstractConverter &converter, 1536 const Fortran::parser::RewindStmt &stmt) { 1537 return genBasicIOStmt<mkIOKey(BeginRewind)>(converter, stmt); 1538 } 1539 1540 mlir::Value 1541 Fortran::lower::genOpenStatement(Fortran::lower::AbstractConverter &converter, 1542 const Fortran::parser::OpenStmt &stmt) { 1543 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1544 Fortran::lower::StatementContext stmtCtx; 1545 mlir::FuncOp beginFunc; 1546 llvm::SmallVector<mlir::Value> beginArgs; 1547 mlir::Location loc = converter.getCurrentLocation(); 1548 if (hasMem<Fortran::parser::FileUnitNumber>(stmt)) { 1549 beginFunc = getIORuntimeFunc<mkIOKey(BeginOpenUnit)>(loc, builder); 1550 mlir::FunctionType beginFuncTy = beginFunc.getType(); 1551 mlir::Value unit = fir::getBase(converter.genExprValue( 1552 getExpr<Fortran::parser::FileUnitNumber>(stmt), stmtCtx, loc)); 1553 beginArgs.push_back( 1554 builder.createConvert(loc, beginFuncTy.getInput(0), unit)); 1555 beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(1))); 1556 beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(2))); 1557 } else { 1558 assert(hasMem<Fortran::parser::ConnectSpec::Newunit>(stmt)); 1559 beginFunc = getIORuntimeFunc<mkIOKey(BeginOpenNewUnit)>(loc, builder); 1560 mlir::FunctionType beginFuncTy = beginFunc.getType(); 1561 beginArgs.push_back(locToFilename(converter, loc, beginFuncTy.getInput(0))); 1562 beginArgs.push_back(locToLineNo(converter, loc, beginFuncTy.getInput(1))); 1563 } 1564 auto cookie = 1565 builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0); 1566 ConditionSpecInfo csi; 1567 genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); 1568 mlir::Value ok; 1569 auto insertPt = builder.saveInsertionPoint(); 1570 threadSpecs(converter, loc, cookie, stmt.v, csi.hasErrorConditionSpec(), ok); 1571 builder.restoreInsertionPoint(insertPt); 1572 return genEndIO(converter, loc, cookie, csi, stmtCtx); 1573 } 1574 1575 mlir::Value 1576 Fortran::lower::genCloseStatement(Fortran::lower::AbstractConverter &converter, 1577 const Fortran::parser::CloseStmt &stmt) { 1578 return genBasicIOStmt<mkIOKey(BeginClose)>(converter, stmt); 1579 } 1580 1581 mlir::Value 1582 Fortran::lower::genWaitStatement(Fortran::lower::AbstractConverter &converter, 1583 const Fortran::parser::WaitStmt &stmt) { 1584 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1585 Fortran::lower::StatementContext stmtCtx; 1586 mlir::Location loc = converter.getCurrentLocation(); 1587 bool hasId = hasMem<Fortran::parser::IdExpr>(stmt); 1588 mlir::FuncOp beginFunc = 1589 hasId ? getIORuntimeFunc<mkIOKey(BeginWait)>(loc, builder) 1590 : getIORuntimeFunc<mkIOKey(BeginWaitAll)>(loc, builder); 1591 mlir::FunctionType beginFuncTy = beginFunc.getType(); 1592 mlir::Value unit = fir::getBase(converter.genExprValue( 1593 getExpr<Fortran::parser::FileUnitNumber>(stmt), stmtCtx, loc)); 1594 mlir::Value un = builder.createConvert(loc, beginFuncTy.getInput(0), unit); 1595 llvm::SmallVector<mlir::Value> args{un}; 1596 if (hasId) { 1597 mlir::Value id = fir::getBase(converter.genExprValue( 1598 getExpr<Fortran::parser::IdExpr>(stmt), stmtCtx, loc)); 1599 args.push_back(builder.createConvert(loc, beginFuncTy.getInput(1), id)); 1600 } 1601 auto cookie = builder.create<fir::CallOp>(loc, beginFunc, args).getResult(0); 1602 ConditionSpecInfo csi; 1603 genConditionHandlerCall(converter, loc, cookie, stmt.v, csi); 1604 return genEndIO(converter, converter.getCurrentLocation(), cookie, csi, 1605 stmtCtx); 1606 } 1607 1608 //===----------------------------------------------------------------------===// 1609 // Data transfer statements. 1610 // 1611 // There are several dimensions to the API with regard to data transfer 1612 // statements that need to be considered. 1613 // 1614 // - input (READ) vs. output (WRITE, PRINT) 1615 // - unformatted vs. formatted vs. list vs. namelist 1616 // - synchronous vs. asynchronous 1617 // - external vs. internal 1618 //===----------------------------------------------------------------------===// 1619 1620 // Get the begin data transfer IO function to call for the given values. 1621 template <bool isInput> 1622 mlir::FuncOp 1623 getBeginDataTransferFunc(mlir::Location loc, fir::FirOpBuilder &builder, 1624 bool isFormatted, bool isListOrNml, bool isInternal, 1625 bool isInternalWithDesc, bool isAsync) { 1626 if constexpr (isInput) { 1627 if (isAsync) 1628 return getIORuntimeFunc<mkIOKey(BeginAsynchronousInput)>(loc, builder); 1629 if (isFormatted || isListOrNml) { 1630 if (isInternal) { 1631 if (isInternalWithDesc) { 1632 if (isListOrNml) 1633 return getIORuntimeFunc<mkIOKey(BeginInternalArrayListInput)>( 1634 loc, builder); 1635 return getIORuntimeFunc<mkIOKey(BeginInternalArrayFormattedInput)>( 1636 loc, builder); 1637 } 1638 if (isListOrNml) 1639 return getIORuntimeFunc<mkIOKey(BeginInternalListInput)>(loc, 1640 builder); 1641 return getIORuntimeFunc<mkIOKey(BeginInternalFormattedInput)>(loc, 1642 builder); 1643 } 1644 if (isListOrNml) 1645 return getIORuntimeFunc<mkIOKey(BeginExternalListInput)>(loc, builder); 1646 return getIORuntimeFunc<mkIOKey(BeginExternalFormattedInput)>(loc, 1647 builder); 1648 } 1649 return getIORuntimeFunc<mkIOKey(BeginUnformattedInput)>(loc, builder); 1650 } else { 1651 if (isAsync) 1652 return getIORuntimeFunc<mkIOKey(BeginAsynchronousOutput)>(loc, builder); 1653 if (isFormatted || isListOrNml) { 1654 if (isInternal) { 1655 if (isInternalWithDesc) { 1656 if (isListOrNml) 1657 return getIORuntimeFunc<mkIOKey(BeginInternalArrayListOutput)>( 1658 loc, builder); 1659 return getIORuntimeFunc<mkIOKey(BeginInternalArrayFormattedOutput)>( 1660 loc, builder); 1661 } 1662 if (isListOrNml) 1663 return getIORuntimeFunc<mkIOKey(BeginInternalListOutput)>(loc, 1664 builder); 1665 return getIORuntimeFunc<mkIOKey(BeginInternalFormattedOutput)>(loc, 1666 builder); 1667 } 1668 if (isListOrNml) 1669 return getIORuntimeFunc<mkIOKey(BeginExternalListOutput)>(loc, builder); 1670 return getIORuntimeFunc<mkIOKey(BeginExternalFormattedOutput)>(loc, 1671 builder); 1672 } 1673 return getIORuntimeFunc<mkIOKey(BeginUnformattedOutput)>(loc, builder); 1674 } 1675 } 1676 1677 /// Generate the arguments of a begin data transfer statement call. 1678 template <bool hasIOCtrl, typename A> 1679 void genBeginDataTransferCallArgs( 1680 llvm::SmallVectorImpl<mlir::Value> &ioArgs, 1681 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1682 const A &stmt, mlir::FunctionType ioFuncTy, bool isFormatted, 1683 bool isListOrNml, [[maybe_unused]] bool isInternal, 1684 [[maybe_unused]] bool isAsync, 1685 const llvm::Optional<fir::ExtendedValue> &descRef, 1686 Fortran::lower::StatementContext &stmtCtx) { 1687 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1688 auto maybeGetFormatArgs = [&]() { 1689 if (!isFormatted || isListOrNml) 1690 return; 1691 auto pair = 1692 getFormat(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()), 1693 ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx); 1694 ioArgs.push_back(std::get<0>(pair)); // format character string 1695 ioArgs.push_back(std::get<1>(pair)); // format length 1696 }; 1697 if constexpr (hasIOCtrl) { // READ or WRITE 1698 if (isInternal) { 1699 // descriptor or scalar variable; maybe explicit format; scratch area 1700 if (descRef.hasValue()) { 1701 mlir::Value desc = builder.createBox(loc, *descRef); 1702 ioArgs.push_back( 1703 builder.createConvert(loc, ioFuncTy.getInput(ioArgs.size()), desc)); 1704 } else { 1705 std::tuple<mlir::Value, mlir::Value> pair = 1706 getBuffer(converter, loc, stmt, ioFuncTy.getInput(ioArgs.size()), 1707 ioFuncTy.getInput(ioArgs.size() + 1), stmtCtx); 1708 ioArgs.push_back(std::get<0>(pair)); // scalar character variable 1709 ioArgs.push_back(std::get<1>(pair)); // character length 1710 } 1711 maybeGetFormatArgs(); 1712 ioArgs.push_back( // internal scratch area buffer 1713 getDefaultScratch(builder, loc, ioFuncTy.getInput(ioArgs.size()))); 1714 ioArgs.push_back( // buffer length 1715 getDefaultScratchLen(builder, loc, ioFuncTy.getInput(ioArgs.size()))); 1716 } else if (isAsync) { // unit; REC; buffer and length 1717 ioArgs.push_back(getIOUnit(converter, loc, stmt, 1718 ioFuncTy.getInput(ioArgs.size()), stmtCtx)); 1719 TODO(loc, "asynchronous"); 1720 } else { // external IO - maybe explicit format; unit 1721 maybeGetFormatArgs(); 1722 ioArgs.push_back(getIOUnit(converter, loc, stmt, 1723 ioFuncTy.getInput(ioArgs.size()), stmtCtx)); 1724 } 1725 } else { // PRINT - maybe explicit format; default unit 1726 maybeGetFormatArgs(); 1727 ioArgs.push_back(builder.create<mlir::arith::ConstantOp>( 1728 loc, builder.getIntegerAttr(ioFuncTy.getInput(ioArgs.size()), 1729 Fortran::runtime::io::DefaultUnit))); 1730 } 1731 // File name and line number are always the last two arguments. 1732 ioArgs.push_back( 1733 locToFilename(converter, loc, ioFuncTy.getInput(ioArgs.size()))); 1734 ioArgs.push_back( 1735 locToLineNo(converter, loc, ioFuncTy.getInput(ioArgs.size()))); 1736 } 1737 1738 template <bool isInput, bool hasIOCtrl = true, typename A> 1739 static mlir::Value 1740 genDataTransferStmt(Fortran::lower::AbstractConverter &converter, 1741 const A &stmt) { 1742 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1743 Fortran::lower::StatementContext stmtCtx; 1744 mlir::Location loc = converter.getCurrentLocation(); 1745 const bool isFormatted = isDataTransferFormatted(stmt); 1746 const bool isList = isFormatted ? isDataTransferList(stmt) : false; 1747 const bool isInternal = isDataTransferInternal(stmt); 1748 llvm::Optional<fir::ExtendedValue> descRef = 1749 isInternal ? maybeGetInternalIODescriptor(converter, stmt, stmtCtx) 1750 : llvm::None; 1751 const bool isInternalWithDesc = descRef.hasValue(); 1752 const bool isAsync = isDataTransferAsynchronous(loc, stmt); 1753 const bool isNml = isDataTransferNamelist(stmt); 1754 1755 // Generate the begin data transfer function call. 1756 mlir::FuncOp ioFunc = getBeginDataTransferFunc<isInput>( 1757 loc, builder, isFormatted, isList || isNml, isInternal, 1758 isInternalWithDesc, isAsync); 1759 llvm::SmallVector<mlir::Value> ioArgs; 1760 genBeginDataTransferCallArgs<hasIOCtrl>( 1761 ioArgs, converter, loc, stmt, ioFunc.getType(), isFormatted, 1762 isList || isNml, isInternal, isAsync, descRef, stmtCtx); 1763 mlir::Value cookie = 1764 builder.create<fir::CallOp>(loc, ioFunc, ioArgs).getResult(0); 1765 1766 // Generate an EnableHandlers call and remaining specifier calls. 1767 ConditionSpecInfo csi; 1768 auto insertPt = builder.saveInsertionPoint(); 1769 mlir::Value ok; 1770 if constexpr (hasIOCtrl) { 1771 genConditionHandlerCall(converter, loc, cookie, stmt.controls, csi); 1772 threadSpecs(converter, loc, cookie, stmt.controls, 1773 csi.hasErrorConditionSpec(), ok); 1774 } 1775 1776 // Generate data transfer list calls. 1777 if constexpr (isInput) { // READ 1778 if (isNml) 1779 genNamelistIO(converter, cookie, 1780 getIORuntimeFunc<mkIOKey(InputNamelist)>(loc, builder), 1781 *getIOControl<Fortran::parser::Name>(stmt)->symbol, 1782 csi.hasTransferConditionSpec(), ok, stmtCtx); 1783 else 1784 genInputItemList(converter, cookie, stmt.items, isFormatted, 1785 csi.hasTransferConditionSpec(), ok, /*inLoop=*/false, 1786 stmtCtx); 1787 } else if constexpr (std::is_same_v<A, Fortran::parser::WriteStmt>) { 1788 if (isNml) 1789 genNamelistIO(converter, cookie, 1790 getIORuntimeFunc<mkIOKey(OutputNamelist)>(loc, builder), 1791 *getIOControl<Fortran::parser::Name>(stmt)->symbol, 1792 csi.hasTransferConditionSpec(), ok, stmtCtx); 1793 else 1794 genOutputItemList(converter, cookie, stmt.items, isFormatted, 1795 csi.hasTransferConditionSpec(), ok, 1796 /*inLoop=*/false, stmtCtx); 1797 } else { // PRINT 1798 genOutputItemList(converter, cookie, std::get<1>(stmt.t), isFormatted, 1799 csi.hasTransferConditionSpec(), ok, 1800 /*inLoop=*/false, stmtCtx); 1801 } 1802 stmtCtx.finalize(); 1803 1804 builder.restoreInsertionPoint(insertPt); 1805 if constexpr (hasIOCtrl) { 1806 genIOReadSize(converter, loc, cookie, stmt.controls, 1807 csi.hasErrorConditionSpec()); 1808 } 1809 // Generate end statement call/s. 1810 return genEndIO(converter, loc, cookie, csi, stmtCtx); 1811 } 1812 1813 void Fortran::lower::genPrintStatement( 1814 Fortran::lower::AbstractConverter &converter, 1815 const Fortran::parser::PrintStmt &stmt) { 1816 // PRINT does not take an io-control-spec. It only has a format specifier, so 1817 // it is a simplified case of WRITE. 1818 genDataTransferStmt</*isInput=*/false, /*ioCtrl=*/false>(converter, stmt); 1819 } 1820 1821 mlir::Value 1822 Fortran::lower::genWriteStatement(Fortran::lower::AbstractConverter &converter, 1823 const Fortran::parser::WriteStmt &stmt) { 1824 return genDataTransferStmt</*isInput=*/false>(converter, stmt); 1825 } 1826 1827 mlir::Value 1828 Fortran::lower::genReadStatement(Fortran::lower::AbstractConverter &converter, 1829 const Fortran::parser::ReadStmt &stmt) { 1830 return genDataTransferStmt</*isInput=*/true>(converter, stmt); 1831 } 1832 1833 /// Get the file expression from the inquire spec list. Also return if the 1834 /// expression is a file name. 1835 static std::pair<const Fortran::lower::SomeExpr *, bool> 1836 getInquireFileExpr(const std::list<Fortran::parser::InquireSpec> *stmt) { 1837 if (!stmt) 1838 return {nullptr, /*filename?=*/false}; 1839 for (const Fortran::parser::InquireSpec &spec : *stmt) { 1840 if (auto *f = std::get_if<Fortran::parser::FileUnitNumber>(&spec.u)) 1841 return {Fortran::semantics::GetExpr(*f), /*filename?=*/false}; 1842 if (auto *f = std::get_if<Fortran::parser::FileNameExpr>(&spec.u)) 1843 return {Fortran::semantics::GetExpr(*f), /*filename?=*/true}; 1844 } 1845 // semantics should have already caught this condition 1846 llvm::report_fatal_error("inquire spec must have a file"); 1847 } 1848 1849 /// Generate calls to the four distinct INQUIRE subhandlers. An INQUIRE may 1850 /// return values of type CHARACTER, INTEGER, or LOGICAL. There is one 1851 /// additional special case for INQUIRE with both PENDING and ID specifiers. 1852 template <typename A> 1853 static mlir::Value genInquireSpec(Fortran::lower::AbstractConverter &converter, 1854 mlir::Location loc, mlir::Value cookie, 1855 mlir::Value idExpr, const A &var, 1856 Fortran::lower::StatementContext &stmtCtx) { 1857 // default case: do nothing 1858 return {}; 1859 } 1860 /// Specialization for CHARACTER. 1861 template <> 1862 mlir::Value genInquireSpec<Fortran::parser::InquireSpec::CharVar>( 1863 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1864 mlir::Value cookie, mlir::Value idExpr, 1865 const Fortran::parser::InquireSpec::CharVar &var, 1866 Fortran::lower::StatementContext &stmtCtx) { 1867 // IOMSG is handled with exception conditions 1868 if (std::get<Fortran::parser::InquireSpec::CharVar::Kind>(var.t) == 1869 Fortran::parser::InquireSpec::CharVar::Kind::Iomsg) 1870 return {}; 1871 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1872 mlir::FuncOp specFunc = 1873 getIORuntimeFunc<mkIOKey(InquireCharacter)>(loc, builder); 1874 mlir::FunctionType specFuncTy = specFunc.getType(); 1875 const auto *varExpr = Fortran::semantics::GetExpr( 1876 std::get<Fortran::parser::ScalarDefaultCharVariable>(var.t)); 1877 fir::ExtendedValue str = converter.genExprAddr(varExpr, stmtCtx, loc); 1878 llvm::SmallVector<mlir::Value> args = { 1879 builder.createConvert(loc, specFuncTy.getInput(0), cookie), 1880 builder.createIntegerConstant( 1881 loc, specFuncTy.getInput(1), 1882 Fortran::runtime::io::HashInquiryKeyword( 1883 Fortran::parser::InquireSpec::CharVar::EnumToString( 1884 std::get<Fortran::parser::InquireSpec::CharVar::Kind>(var.t)) 1885 .c_str())), 1886 builder.createConvert(loc, specFuncTy.getInput(2), fir::getBase(str)), 1887 builder.createConvert(loc, specFuncTy.getInput(3), fir::getLen(str))}; 1888 return builder.create<fir::CallOp>(loc, specFunc, args).getResult(0); 1889 } 1890 /// Specialization for INTEGER. 1891 template <> 1892 mlir::Value genInquireSpec<Fortran::parser::InquireSpec::IntVar>( 1893 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1894 mlir::Value cookie, mlir::Value idExpr, 1895 const Fortran::parser::InquireSpec::IntVar &var, 1896 Fortran::lower::StatementContext &stmtCtx) { 1897 // IOSTAT is handled with exception conditions 1898 if (std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t) == 1899 Fortran::parser::InquireSpec::IntVar::Kind::Iostat) 1900 return {}; 1901 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1902 mlir::FuncOp specFunc = 1903 getIORuntimeFunc<mkIOKey(InquireInteger64)>(loc, builder); 1904 mlir::FunctionType specFuncTy = specFunc.getType(); 1905 const auto *varExpr = Fortran::semantics::GetExpr( 1906 std::get<Fortran::parser::ScalarIntVariable>(var.t)); 1907 mlir::Value addr = fir::getBase(converter.genExprAddr(varExpr, stmtCtx, loc)); 1908 mlir::Type eleTy = fir::dyn_cast_ptrEleTy(addr.getType()); 1909 if (!eleTy) 1910 fir::emitFatalError(loc, 1911 "internal error: expected a memory reference type"); 1912 auto bitWidth = eleTy.cast<mlir::IntegerType>().getWidth(); 1913 mlir::IndexType idxTy = builder.getIndexType(); 1914 mlir::Value kind = builder.createIntegerConstant(loc, idxTy, bitWidth / 8); 1915 llvm::SmallVector<mlir::Value> args = { 1916 builder.createConvert(loc, specFuncTy.getInput(0), cookie), 1917 builder.createIntegerConstant( 1918 loc, specFuncTy.getInput(1), 1919 Fortran::runtime::io::HashInquiryKeyword( 1920 Fortran::parser::InquireSpec::IntVar::EnumToString( 1921 std::get<Fortran::parser::InquireSpec::IntVar::Kind>(var.t)) 1922 .c_str())), 1923 builder.createConvert(loc, specFuncTy.getInput(2), addr), 1924 builder.createConvert(loc, specFuncTy.getInput(3), kind)}; 1925 return builder.create<fir::CallOp>(loc, specFunc, args).getResult(0); 1926 } 1927 /// Specialization for LOGICAL and (PENDING + ID). 1928 template <> 1929 mlir::Value genInquireSpec<Fortran::parser::InquireSpec::LogVar>( 1930 Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1931 mlir::Value cookie, mlir::Value idExpr, 1932 const Fortran::parser::InquireSpec::LogVar &var, 1933 Fortran::lower::StatementContext &stmtCtx) { 1934 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1935 auto logVarKind = std::get<Fortran::parser::InquireSpec::LogVar::Kind>(var.t); 1936 bool pendId = 1937 idExpr && 1938 logVarKind == Fortran::parser::InquireSpec::LogVar::Kind::Pending; 1939 mlir::FuncOp specFunc = 1940 pendId ? getIORuntimeFunc<mkIOKey(InquirePendingId)>(loc, builder) 1941 : getIORuntimeFunc<mkIOKey(InquireLogical)>(loc, builder); 1942 mlir::FunctionType specFuncTy = specFunc.getType(); 1943 mlir::Value addr = fir::getBase(converter.genExprAddr( 1944 Fortran::semantics::GetExpr( 1945 std::get<Fortran::parser::Scalar< 1946 Fortran::parser::Logical<Fortran::parser::Variable>>>(var.t)), 1947 stmtCtx, loc)); 1948 llvm::SmallVector<mlir::Value> args = { 1949 builder.createConvert(loc, specFuncTy.getInput(0), cookie)}; 1950 if (pendId) 1951 args.push_back(builder.createConvert(loc, specFuncTy.getInput(1), idExpr)); 1952 else 1953 args.push_back(builder.createIntegerConstant( 1954 loc, specFuncTy.getInput(1), 1955 Fortran::runtime::io::HashInquiryKeyword( 1956 Fortran::parser::InquireSpec::LogVar::EnumToString(logVarKind) 1957 .c_str()))); 1958 args.push_back(builder.createConvert(loc, specFuncTy.getInput(2), addr)); 1959 return builder.create<fir::CallOp>(loc, specFunc, args).getResult(0); 1960 } 1961 1962 /// If there is an IdExpr in the list of inquire-specs, then lower it and return 1963 /// the resulting Value. Otherwise, return null. 1964 static mlir::Value 1965 lowerIdExpr(Fortran::lower::AbstractConverter &converter, mlir::Location loc, 1966 const std::list<Fortran::parser::InquireSpec> &ispecs, 1967 Fortran::lower::StatementContext &stmtCtx) { 1968 for (const Fortran::parser::InquireSpec &spec : ispecs) 1969 if (mlir::Value v = std::visit( 1970 Fortran::common::visitors{ 1971 [&](const Fortran::parser::IdExpr &idExpr) { 1972 return fir::getBase(converter.genExprValue( 1973 Fortran::semantics::GetExpr(idExpr), stmtCtx, loc)); 1974 }, 1975 [](const auto &) { return mlir::Value{}; }}, 1976 spec.u)) 1977 return v; 1978 return {}; 1979 } 1980 1981 /// For each inquire-spec, build the appropriate call, threading the cookie. 1982 static void threadInquire(Fortran::lower::AbstractConverter &converter, 1983 mlir::Location loc, mlir::Value cookie, 1984 const std::list<Fortran::parser::InquireSpec> &ispecs, 1985 bool checkResult, mlir::Value &ok, 1986 Fortran::lower::StatementContext &stmtCtx) { 1987 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 1988 mlir::Value idExpr = lowerIdExpr(converter, loc, ispecs, stmtCtx); 1989 for (const Fortran::parser::InquireSpec &spec : ispecs) { 1990 makeNextConditionalOn(builder, loc, checkResult, ok); 1991 ok = std::visit(Fortran::common::visitors{[&](const auto &x) { 1992 return genInquireSpec(converter, loc, cookie, idExpr, x, 1993 stmtCtx); 1994 }}, 1995 spec.u); 1996 } 1997 } 1998 1999 mlir::Value Fortran::lower::genInquireStatement( 2000 Fortran::lower::AbstractConverter &converter, 2001 const Fortran::parser::InquireStmt &stmt) { 2002 fir::FirOpBuilder &builder = converter.getFirOpBuilder(); 2003 Fortran::lower::StatementContext stmtCtx; 2004 mlir::Location loc = converter.getCurrentLocation(); 2005 mlir::FuncOp beginFunc; 2006 ConditionSpecInfo csi; 2007 llvm::SmallVector<mlir::Value> beginArgs; 2008 const auto *list = 2009 std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u); 2010 auto exprPair = getInquireFileExpr(list); 2011 auto inquireFileUnit = [&]() -> bool { 2012 return exprPair.first && !exprPair.second; 2013 }; 2014 auto inquireFileName = [&]() -> bool { 2015 return exprPair.first && exprPair.second; 2016 }; 2017 2018 // Make one of three BeginInquire calls. 2019 if (inquireFileUnit()) { 2020 // Inquire by unit -- [UNIT=]file-unit-number. 2021 beginFunc = getIORuntimeFunc<mkIOKey(BeginInquireUnit)>(loc, builder); 2022 mlir::FunctionType beginFuncTy = beginFunc.getType(); 2023 beginArgs = {builder.createConvert(loc, beginFuncTy.getInput(0), 2024 fir::getBase(converter.genExprValue( 2025 exprPair.first, stmtCtx, loc))), 2026 locToFilename(converter, loc, beginFuncTy.getInput(1)), 2027 locToLineNo(converter, loc, beginFuncTy.getInput(2))}; 2028 } else if (inquireFileName()) { 2029 // Inquire by file -- FILE=file-name-expr. 2030 beginFunc = getIORuntimeFunc<mkIOKey(BeginInquireFile)>(loc, builder); 2031 mlir::FunctionType beginFuncTy = beginFunc.getType(); 2032 fir::ExtendedValue file = 2033 converter.genExprAddr(exprPair.first, stmtCtx, loc); 2034 beginArgs = { 2035 builder.createConvert(loc, beginFuncTy.getInput(0), fir::getBase(file)), 2036 builder.createConvert(loc, beginFuncTy.getInput(1), fir::getLen(file)), 2037 locToFilename(converter, loc, beginFuncTy.getInput(2)), 2038 locToLineNo(converter, loc, beginFuncTy.getInput(3))}; 2039 } else { 2040 // Inquire by output list -- IOLENGTH=scalar-int-variable. 2041 const auto *ioLength = 2042 std::get_if<Fortran::parser::InquireStmt::Iolength>(&stmt.u); 2043 assert(ioLength && "must have an IOLENGTH specifier"); 2044 beginFunc = getIORuntimeFunc<mkIOKey(BeginInquireIoLength)>(loc, builder); 2045 mlir::FunctionType beginFuncTy = beginFunc.getType(); 2046 beginArgs = {locToFilename(converter, loc, beginFuncTy.getInput(0)), 2047 locToLineNo(converter, loc, beginFuncTy.getInput(1))}; 2048 auto cookie = 2049 builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0); 2050 mlir::Value ok; 2051 genOutputItemList( 2052 converter, cookie, 2053 std::get<std::list<Fortran::parser::OutputItem>>(ioLength->t), 2054 /*isFormatted=*/false, /*checkResult=*/false, ok, /*inLoop=*/false, 2055 stmtCtx); 2056 auto *ioLengthVar = Fortran::semantics::GetExpr( 2057 std::get<Fortran::parser::ScalarIntVariable>(ioLength->t)); 2058 mlir::Value ioLengthVarAddr = 2059 fir::getBase(converter.genExprAddr(ioLengthVar, stmtCtx, loc)); 2060 llvm::SmallVector<mlir::Value> args = {cookie}; 2061 mlir::Value length = 2062 builder 2063 .create<fir::CallOp>( 2064 loc, getIORuntimeFunc<mkIOKey(GetIoLength)>(loc, builder), args) 2065 .getResult(0); 2066 mlir::Value length1 = 2067 builder.createConvert(loc, converter.genType(*ioLengthVar), length); 2068 builder.create<fir::StoreOp>(loc, length1, ioLengthVarAddr); 2069 return genEndIO(converter, loc, cookie, csi, stmtCtx); 2070 } 2071 2072 // Common handling for inquire by unit or file. 2073 assert(list && "inquire-spec list must be present"); 2074 auto cookie = 2075 builder.create<fir::CallOp>(loc, beginFunc, beginArgs).getResult(0); 2076 genConditionHandlerCall(converter, loc, cookie, *list, csi); 2077 // Handle remaining arguments in specifier list. 2078 mlir::Value ok; 2079 auto insertPt = builder.saveInsertionPoint(); 2080 threadInquire(converter, loc, cookie, *list, csi.hasErrorConditionSpec(), ok, 2081 stmtCtx); 2082 builder.restoreInsertionPoint(insertPt); 2083 // Generate end statement call. 2084 return genEndIO(converter, loc, cookie, csi, stmtCtx); 2085 } 2086