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