diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h index 3eec7b4d016ff..8f23c066d24ae 100644 --- a/flang/include/flang/Lower/Runtime.h +++ b/flang/include/flang/Lower/Runtime.h @@ -81,6 +81,16 @@ void genRandomNumber(fir::FirOpBuilder &, mlir::Location, mlir::Value harvest); void genRandomSeed(fir::FirOpBuilder &, mlir::Location, int argIndex, mlir::Value argBox); +/// generate runtime call to transfer intrinsic with no size argument +void genTransfer(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox, + mlir::Value moldBox); + +/// generate runtime call to transfer intrinsic with size argument +void genTransferSize(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox, + mlir::Value moldBox, mlir::Value size); + /// generate system_clock runtime call/s /// all intrinsic arguments are optional and may appear here as mlir::Value{} void genSystemClock(fir::FirOpBuilder &, mlir::Location, mlir::Value count, diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp index d884f9b16e344..cb05e61b0b377 100644 --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -464,6 +464,8 @@ struct IntrinsicLibrary { fir::ExtendedValue genSize(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef); void genSystemClock(llvm::ArrayRef); + fir::ExtendedValue genTransfer(mlir::Type, + llvm::ArrayRef); fir::ExtendedValue genUbound(mlir::Type, llvm::ArrayRef); /// Define the different FIR generators that can be mapped to intrinsic to @@ -659,6 +661,10 @@ static constexpr IntrinsicHandler handlers[]{ &I::genSystemClock, {{{"count", asAddr}, {"count_rate", asAddr}, {"count_max", asAddr}}}, /*isElemental=*/false}, + {"transfer", + &I::genTransfer, + {{{"source", asAddr}, {"mold", asAddr}, {"size", asValue}}}, + /*isElemental=*/false}, {"ubound", &I::genUbound, {{{"array", asBox}, {"dim", asValue}, {"kind", asValue}}}, @@ -1949,6 +1955,53 @@ IntrinsicLibrary::genSize(mlir::Type resultType, .getResults()[0]; } +// TRANSFER +fir::ExtendedValue +IntrinsicLibrary::genTransfer(mlir::Type resultType, + llvm::ArrayRef args) { + + assert(args.size() >= 2); // args.size() == 2 when size argument is omitted. + + // Handle source argument + mlir::Value source = builder.createBox(loc, args[0]); + + // Handle mold argument + mlir::Value mold = builder.createBox(loc, args[1]); + fir::BoxValue moldTmp = mold; + unsigned moldRank = moldTmp.rank(); + + bool absentSize = (args.size() == 2); + + // Create mutable fir.box to be passed to the runtime for the result. + mlir::Type type = (moldRank == 0 && absentSize) + ? resultType + : builder.getVarLenSeqTy(resultType, 1); + fir::MutableBoxValue resultMutableBox = + fir::factory::createTempMutableBox(builder, loc, type); + + if (moldRank == 0 && absentSize) { + // This result is a scalar in this case. + mlir::Value resultIrBox = + fir::factory::getMutableIRBox(builder, loc, resultMutableBox); + + Fortran::lower::genTransfer(builder, loc, resultIrBox, source, mold); + } else { + // The result is a rank one array in this case. + mlir::Value resultIrBox = + fir::factory::getMutableIRBox(builder, loc, resultMutableBox); + + if (absentSize) { + Fortran::lower::genTransfer(builder, loc, resultIrBox, source, mold); + } else { + mlir::Value sizeArg = fir::getBase(args[2]); + Fortran::lower::genTransferSize(builder, loc, resultIrBox, source, mold, + sizeArg); + } + } + return readAndAddCleanUp(resultMutableBox, resultType, + "unexpected result for TRANSFER"); +} + // LBOUND fir::ExtendedValue IntrinsicLibrary::genLbound(mlir::Type resultType, diff --git a/flang/lib/Lower/Runtime.cpp b/flang/lib/Lower/Runtime.cpp index 8b97a5125c8ca..a6c5bb105744a 100644 --- a/flang/lib/Lower/Runtime.cpp +++ b/flang/lib/Lower/Runtime.cpp @@ -13,6 +13,7 @@ #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" #include "flang/Parser/parse-tree.h" +#include "flang/Runtime/misc-intrinsic.h" #include "flang/Runtime/pointer.h" #include "flang/Runtime/random.h" #include "flang/Runtime/stop.h" @@ -234,6 +235,39 @@ void Fortran::lower::genRandomSeed(fir::FirOpBuilder &builder, builder.create(loc, func, args); } +/// generate runtime call to transfer intrinsic with no size argument +void Fortran::lower::genTransfer(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value resultBox, mlir::Value sourceBox, + mlir::Value moldBox) { + + mlir::FuncOp func = + fir::runtime::getRuntimeFunc(loc, builder); + mlir::FunctionType fTy = func.getType(); + mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc); + mlir::Value sourceLine = + fir::factory::locationToLineNo(builder, loc, fTy.getInput(4)); + llvm::SmallVector args = fir::runtime::createArguments( + builder, loc, fTy, resultBox, sourceBox, moldBox, sourceFile, sourceLine); + builder.create(loc, func, args); +} + +/// generate runtime call to transfer intrinsic with size argument +void Fortran::lower::genTransferSize(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value resultBox, + mlir::Value sourceBox, mlir::Value moldBox, + mlir::Value size) { + mlir::FuncOp func = + fir::runtime::getRuntimeFunc(loc, builder); + mlir::FunctionType fTy = func.getType(); + mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc); + mlir::Value sourceLine = + fir::factory::locationToLineNo(builder, loc, fTy.getInput(4)); + llvm::SmallVector args = + fir::runtime::createArguments(builder, loc, fTy, resultBox, sourceBox, + moldBox, sourceFile, sourceLine, size); + builder.create(loc, func, args); +} + /// generate system_clock runtime call/s /// all intrinsic arguments are optional and may appear here as mlir::Value{} void Fortran::lower::genSystemClock(fir::FirOpBuilder &builder, diff --git a/flang/test/Lower/Intrinsics/transfer.f90 b/flang/test/Lower/Intrinsics/transfer.f90 new file mode 100644 index 0000000000000..58bdfd872e691 --- /dev/null +++ b/flang/test/Lower/Intrinsics/transfer.f90 @@ -0,0 +1,123 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +subroutine trans_test(store, word) + ! CHECK-LABEL: func @_QPtrans_test( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref{{.*}}, %[[VAL_1:.*]]: !fir.ref{{.*}}) { + ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box> + ! CHECK: %[[VAL_3:.*]] = fir.embox %[[VAL_1]] : (!fir.ref) -> !fir.box + ! CHECK: %[[VAL_4:.*]] = fir.embox %[[VAL_0]] : (!fir.ref) -> !fir.box + ! CHECK: %[[VAL_5:.*]] = fir.zero_bits !fir.heap + ! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_5]] : (!fir.heap) -> !fir.box> + ! CHECK: fir.store %[[VAL_6]] to %[[VAL_2]] : !fir.ref>> + ! CHECK: %[[VAL_7:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref> + ! CHECK: %[[VAL_8:.*]] = arith.constant {{.*}} : i32 + ! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>) -> !fir.ref> + ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_3]] : (!fir.box) -> !fir.box + ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_4]] : (!fir.box) -> !fir.box + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_7]] : (!fir.ref>) -> !fir.ref + ! CHECK: %[[VAL_13:.*]] = fir.call @_FortranATransfer(%[[VAL_9]], %[[VAL_10]], %[[VAL_11]], %[[VAL_12]], %[[VAL_8]]) : (!fir.ref>, !fir.box, !fir.box, !fir.ref, i32) -> none + ! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_2]] : !fir.ref>> + ! CHECK: %[[VAL_15:.*]] = fir.box_addr %[[VAL_14]] : (!fir.box>) -> !fir.heap + ! CHECK: %[[VAL_16:.*]] = fir.load %[[VAL_15]] : !fir.heap + ! CHECK: fir.store %[[VAL_16]] to %[[VAL_0]] : !fir.ref + ! CHECK: fir.freemem %[[VAL_15]] + ! CHECK: return + ! CHECK: } + integer :: store + real :: word + store = transfer(word, store) + end subroutine + + ! CHECK-LABEL: func @_QPtrans_test2( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>{{.*}}, %[[VAL_1:.*]]: !fir.ref{{.*}}) { + ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[VAL_3:.*]] = arith.constant 3 : index + ! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_5:.*]] = fir.array_load %[[VAL_0]](%[[VAL_4]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<3xi32> + ! CHECK: %[[VAL_6:.*]] = arith.constant 3 : i32 + ! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_1]] : (!fir.ref) -> !fir.box + ! CHECK: %[[VAL_8:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_0]](%[[VAL_8]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> + ! CHECK: %[[VAL_10:.*]] = fir.zero_bits !fir.heap> + ! CHECK: %[[VAL_11:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_12:.*]] = fir.shape %[[VAL_11]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_13:.*]] = fir.embox %[[VAL_10]](%[[VAL_12]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_13]] to %[[VAL_2]] : !fir.ref>>> + ! CHECK: %[[VAL_14:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref>>>) -> !fir.ref> + ! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_7]] : (!fir.box) -> !fir.box + ! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_9]] : (!fir.box>) -> !fir.box + ! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_14]] : (!fir.ref>) -> !fir.ref + ! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_6]] : (i32) -> i64 + ! CHECK: %[[VAL_21:.*]] = fir.call @_FortranATransferSize(%[[VAL_16]], %[[VAL_17]], %[[VAL_18]], %[[VAL_19]], %[[VAL_15]], %[[VAL_20]]) : (!fir.ref>, !fir.box, !fir.box, !fir.ref, i32, i64) -> none + ! CHECK: %[[VAL_22:.*]] = fir.load %[[VAL_2]] : !fir.ref>>> + ! CHECK: %[[VAL_23:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_24:.*]]:3 = fir.box_dims %[[VAL_22]], %[[VAL_23]] : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[VAL_25:.*]] = fir.box_addr %[[VAL_22]] : (!fir.box>>) -> !fir.heap> + ! CHECK: %[[VAL_26:.*]] = fir.shape_shift %[[VAL_24]]#0, %[[VAL_24]]#1 : (index, index) -> !fir.shapeshift<1> + ! CHECK: %[[VAL_27:.*]] = fir.array_load %[[VAL_25]](%[[VAL_26]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.array + ! CHECK: %[[VAL_28:.*]] = arith.constant 1 : index + ! CHECK: %[[VAL_29:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_30:.*]] = arith.subi %[[VAL_3]], %[[VAL_28]] : index + ! CHECK: %[[VAL_31:.*]] = fir.do_loop %[[VAL_32:.*]] = %[[VAL_29]] to %[[VAL_30]] step %[[VAL_28]] unordered iter_args(%[[VAL_33:.*]] = %[[VAL_5]]) -> (!fir.array<3xi32>) { + ! CHECK: %[[VAL_34:.*]] = fir.array_fetch %[[VAL_27]], %[[VAL_32]] : (!fir.array, index) -> i32 + ! CHECK: %[[VAL_35:.*]] = fir.array_update %[[VAL_33]], %[[VAL_34]], %[[VAL_32]] : (!fir.array<3xi32>, i32, index) -> !fir.array<3xi32> + ! CHECK: fir.result %[[VAL_35]] : !fir.array<3xi32> + ! CHECK: } + ! CHECK: fir.array_merge_store %[[VAL_5]], %[[VAL_36:.*]] to %[[VAL_0]] : !fir.array<3xi32>, !fir.array<3xi32>, !fir.ref> + ! CHECK: fir.freemem %[[VAL_25]] + ! CHECK: return + ! CHECK: } + + subroutine trans_test2(store, word) + integer :: store(3) + real :: word + store = transfer(word, store, 3) + end subroutine + + integer function trans_test3(p) + ! CHECK-LABEL: func @_QPtrans_test3( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref{{.*}}) -> i32 { + ! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box> + ! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>> + ! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.type<_QFtrans_test3Tobj{x:i32}> {bindc_name = "t", uniq_name = "_QFtrans_test3Et"} + ! CHECK: %[[VAL_4:.*]] = fir.alloca i32 {bindc_name = "trans_test3", uniq_name = "_QFtrans_test3Etrans_test3"} + ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_0]] : (!fir.ref) -> !fir.box + ! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_3]] : (!fir.ref>) -> !fir.box> + ! CHECK: %[[VAL_7:.*]] = fir.zero_bits !fir.heap> + ! CHECK: %[[VAL_8:.*]] = fir.embox %[[VAL_7]] : (!fir.heap>) -> !fir.box>> + ! CHECK: fir.store %[[VAL_8]] to %[[VAL_2]] : !fir.ref>>> + ! CHECK: %[[VAL_9:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref> + ! CHECK: %[[VAL_10:.*]] = arith.constant {{.*}} : i32 + ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>) -> !fir.ref> + ! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_5]] : (!fir.box) -> !fir.box + ! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_6]] : (!fir.box>) -> !fir.box + ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_9]] : (!fir.ref>) -> !fir.ref + ! CHECK: %[[VAL_15:.*]] = fir.call @_FortranATransfer(%[[VAL_11]], %[[VAL_12]], %[[VAL_13]], %[[VAL_14]], %[[VAL_10]]) : (!fir.ref>, !fir.box, !fir.box, !fir.ref, i32) -> none + ! CHECK: %[[VAL_16:.*]] = fir.load %[[VAL_2]] : !fir.ref>>> + ! CHECK: %[[VAL_17:.*]] = fir.box_addr %[[VAL_16]] : (!fir.box>>) -> !fir.heap> + ! CHECK: %[[VAL_18:.*]] = fir.embox %[[VAL_3]] : (!fir.ref>) -> !fir.box> + ! CHECK: fir.store %[[VAL_18]] to %[[VAL_1]] : !fir.ref>> + ! CHECK: %[[VAL_19:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref> + ! CHECK: %[[VAL_20:.*]] = arith.constant {{.*}} : i32 + ! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>>) -> !fir.ref> + ! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_16]] : (!fir.box>>) -> !fir.box + ! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_19]] : (!fir.ref>) -> !fir.ref + ! CHECK: %[[VAL_24:.*]] = fir.call @_FortranAAssign(%[[VAL_21]], %[[VAL_22]], %[[VAL_23]], %[[VAL_20]]) : (!fir.ref>, !fir.box, !fir.ref, i32) -> none + ! CHECK: fir.freemem %[[VAL_17]] + ! CHECK: %[[VAL_25:.*]] = fir.field_index x, !fir.type<_QFtrans_test3Tobj{x:i32}> + ! CHECK: %[[VAL_26:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_25]] : (!fir.ref>, !fir.field) -> !fir.ref + ! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_26]] : !fir.ref + ! CHECK: fir.store %[[VAL_27]] to %[[VAL_4]] : !fir.ref + ! CHECK: %[[VAL_28:.*]] = fir.load %[[VAL_4]] : !fir.ref + ! CHECK: return %[[VAL_28]] : i32 + ! CHECK: } + type obj + integer :: x + end type + type (obj) :: t + integer :: p + t = transfer(p, t) + trans_test3 = t%x + end function