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