diff --git a/flang/include/flang/Lower/IntrinsicCall.h b/flang/include/flang/Lower/IntrinsicCall.h --- a/flang/include/flang/Lower/IntrinsicCall.h +++ b/flang/include/flang/Lower/IntrinsicCall.h @@ -82,6 +82,14 @@ /// Return place-holder for absent intrinsic arguments. fir::ExtendedValue getAbsentIntrinsicArgument(); +/// Get SymbolRefAttr of runtime (or wrapper function containing inlined +// implementation) of an unrestricted intrinsic (defined by its signature +// and generic name) +mlir::SymbolRefAttr +getUnrestrictedIntrinsicSymbolRefAttr(fir::FirOpBuilder &, mlir::Location, + llvm::StringRef name, + mlir::FunctionType signature); + //===----------------------------------------------------------------------===// // Direct access to intrinsics that may be used by lowering outside // of intrinsic call lowering. diff --git a/flang/include/flang/Optimizer/Dialect/CanonicalizationPatterns.td b/flang/include/flang/Optimizer/Dialect/CanonicalizationPatterns.td --- a/flang/include/flang/Optimizer/Dialect/CanonicalizationPatterns.td +++ b/flang/include/flang/Optimizer/Dialect/CanonicalizationPatterns.td @@ -23,28 +23,80 @@ def IntegerTypePred : Constraint>; def IndexTypePred : Constraint()">>; -def SmallerWidthPred - : Constraint>; +// Widths are monotonic. +// $0.bits >= $1.bits >= $2.bits or $0.bits <= $1.bits <= $2.bits +def MonotonicTypePred + : Constraint() && " + " $1.getType().isa() && " + " $2.getType().isa()) || " + " ($0.getType().isa() && " + " $1.getType().isa() && " + " $2.getType().isa())) && " + "(($0.getType().getIntOrFloatBitWidth() <= " + " $1.getType().getIntOrFloatBitWidth() && " + " $1.getType().getIntOrFloatBitWidth() <= " + " $2.getType().getIntOrFloatBitWidth()) || " + " ($0.getType().getIntOrFloatBitWidth() >= " + " $1.getType().getIntOrFloatBitWidth() && " + " $1.getType().getIntOrFloatBitWidth() >= " + " $2.getType().getIntOrFloatBitWidth()))">>; +def IntPred : Constraint() && " + "$1.getType().isa()">>; + +// If both are int type and the first is smaller than the second. +// $0.bits <= $1.bits +def SmallerWidthPred : Constraint>; +def StrictSmallerWidthPred : Constraint>; + +// floats or ints that undergo successive extensions or successive truncations. def ConvertConvertOptPattern - : Pat<(fir_ConvertOp (fir_ConvertOp $arg)), + : Pat<(fir_ConvertOp:$res (fir_ConvertOp:$irm $arg)), + (fir_ConvertOp $arg), + [(MonotonicTypePred $res, $irm, $arg)]>; + +// Widths are increasingly monotonic to type index, so there is no +// possibility of a truncation before the conversion to index. +// $res == index && $irm.bits >= $arg.bits +def ConvertAscendingIndexOptPattern + : Pat<(fir_ConvertOp:$res (fir_ConvertOp:$irm $arg)), + (fir_ConvertOp $arg), + [(IndexTypePred $res), (IntPred $irm, $arg), + (SmallerWidthPred $arg, $irm)]>; + +// Widths are decreasingly monotonic from type index, so the truncations +// continue to lop off more bits. +// $arg == index && $res.bits < $irm.bits +def ConvertDescendingIndexOptPattern + : Pat<(fir_ConvertOp:$res (fir_ConvertOp:$irm $arg)), (fir_ConvertOp $arg), - [(IntegerTypePred $arg)]>; + [(IndexTypePred $arg), (IntPred $irm, $res), + (SmallerWidthPred $res, $irm)]>; +// Useless convert to exact same type. def RedundantConvertOptPattern : Pat<(fir_ConvertOp:$res $arg), (replaceWithValue $arg), - [(IdenticalTypePred $res, $arg) - ,(IntegerTypePred $arg)]>; + [(IdenticalTypePred $res, $arg)]>; +// Useless extension followed by truncation to get same width integer. def CombineConvertOptPattern : Pat<(fir_ConvertOp:$res(fir_ConvertOp:$irm $arg)), (replaceWithValue $arg), - [(IdenticalTypePred $res, $arg) - ,(IntegerTypePred $arg) - ,(IntegerTypePred $irm) - ,(SmallerWidthPred $arg, $irm)]>; + [(IntPred $res, $arg), (IdenticalTypePred $res, $arg), + (IntPred $arg, $irm), (SmallerWidthPred $arg, $irm)]>; + +// Useless extension followed by truncation to get smaller width integer. +def CombineConvertTruncOptPattern + : Pat<(fir_ConvertOp:$res(fir_ConvertOp:$irm $arg)), + (fir_ConvertOp $arg), + [(IntPred $res, $arg), (StrictSmallerWidthPred $res, $arg), + (IntPred $arg, $irm), (SmallerWidthPred $arg, $irm)]>; def createConstantOp : NativeCodeCall<"$_builder.create" @@ -55,7 +107,6 @@ def ForwardConstantConvertPattern : Pat<(fir_ConvertOp:$res (Arith_ConstantOp:$cnt $attr)), (createConstantOp $res, $attr), - [(IndexTypePred $res) - ,(IntegerTypePred $cnt)]>; + [(IndexTypePred $res), (IntegerTypePred $cnt)]>; #endif // FORTRAN_FIR_REWRITE_PATTERNS diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -330,6 +330,16 @@ } } +/// Does \p expr only refer to symbols that are mapped to IR values in \p symMap +/// ? +static bool allSymbolsInExprPresentInMap(const Fortran::lower::SomeExpr &expr, + Fortran::lower::SymMap &symMap) { + for (const auto &sym : Fortran::evaluate::CollectSymbols(expr)) + if (!symMap.lookupSymbol(sym)) + return false; + return true; +} + /// Generate a load of a value from an address. Beware that this will lose /// any dynamic type information for polymorphic entities (note that unlimited /// polymorphic cannot be loaded and must not be provided here). @@ -743,11 +753,69 @@ /// The type of the function indirection is not guaranteed to match the one /// of the ProcedureDesignator due to Fortran implicit typing rules. ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) { - TODO(getLoc(), "genval ProcedureDesignator"); + mlir::Location loc = getLoc(); + if (const Fortran::evaluate::SpecificIntrinsic *intrinsic = + proc.GetSpecificIntrinsic()) { + mlir::FunctionType signature = + Fortran::lower::translateSignature(proc, converter); + // Intrinsic lowering is based on the generic name, so retrieve it here in + // case it is different from the specific name. The type of the specific + // intrinsic is retained in the signature. + std::string genericName = + converter.getFoldingContext().intrinsics().GetGenericIntrinsicName( + intrinsic->name); + mlir::SymbolRefAttr symbolRefAttr = + Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr( + builder, loc, genericName, signature); + mlir::Value funcPtr = + builder.create(loc, signature, symbolRefAttr); + return funcPtr; + } + const Fortran::semantics::Symbol *symbol = proc.GetSymbol(); + assert(symbol && "expected symbol in ProcedureDesignator"); + mlir::Value funcPtr; + mlir::Value funcPtrResultLength; + if (Fortran::semantics::IsDummy(*symbol)) { + Fortran::lower::SymbolBox val = symMap.lookupSymbol(*symbol); + assert(val && "Dummy procedure not in symbol map"); + funcPtr = val.getAddr(); + if (fir::isCharacterProcedureTuple(funcPtr.getType(), + /*acceptRawFunc=*/false)) + std::tie(funcPtr, funcPtrResultLength) = + fir::factory::extractCharacterProcedureTuple(builder, loc, funcPtr); + } else { + std::string name = converter.mangleName(*symbol); + mlir::FuncOp func = + Fortran::lower::getOrDeclareFunction(name, proc, converter); + funcPtr = builder.create(loc, func.getFunctionType(), + builder.getSymbolRefAttr(name)); + } + if (Fortran::lower::mustPassLengthWithDummyProcedure(proc, converter)) { + // The result length, if available here, must be propagated along the + // procedure address so that call sites where the result length is assumed + // can retrieve the length. + Fortran::evaluate::DynamicType resultType = proc.GetType().value(); + if (const auto &lengthExpr = resultType.GetCharLength()) { + // The length expression may refer to dummy argument symbols that are + // meaningless without any actual arguments. Leave the length as + // unknown in that case, it be resolved on the call site + // with the actual arguments. + if (allSymbolsInExprPresentInMap(toEvExpr(*lengthExpr), symMap)) { + mlir::Value rawLen = fir::getBase(genval(*lengthExpr)); + // F2018 7.4.4.2 point 5. + funcPtrResultLength = + Fortran::lower::genMaxWithZero(builder, getLoc(), rawLen); + } + } + if (!funcPtrResultLength) + funcPtrResultLength = builder.createIntegerConstant( + loc, builder.getCharacterLengthType(), -1); + return fir::CharBoxValue{funcPtr, funcPtrResultLength}; + } + return funcPtr; } - ExtValue genval(const Fortran::evaluate::NullPointer &) { - TODO(getLoc(), "genval NullPointer"); + return builder.createNullConstant(getLoc()); } static bool diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -574,6 +574,12 @@ mlir::Value invokeGenerator(SubroutineGenerator generator, llvm::ArrayRef args); + /// Get pointer to unrestricted intrinsic. Generate the related unrestricted + /// intrinsic if it is not defined yet. + mlir::SymbolRefAttr + getUnrestrictedIntrinsicSymbolRefAttr(llvm::StringRef name, + mlir::FunctionType signature); + /// Add clean-up for \p temp to the current statement context; void addCleanUpForTemp(mlir::Location loc, mlir::Value temp); /// Helper function for generating code clean-up for result descriptors @@ -1608,6 +1614,39 @@ }; } +mlir::SymbolRefAttr IntrinsicLibrary::getUnrestrictedIntrinsicSymbolRefAttr( + llvm::StringRef name, mlir::FunctionType signature) { + // Unrestricted intrinsics signature follows implicit rules: argument + // are passed by references. But the runtime versions expect values. + // So instead of duplicating the runtime, just have the wrappers loading + // this before calling the code generators. + bool loadRefArguments = true; + mlir::FuncOp funcOp; + if (const IntrinsicHandler *handler = findIntrinsicHandler(name)) + funcOp = std::visit( + [&](auto generator) { + return getWrapper(generator, name, signature, loadRefArguments); + }, + handler->generator); + + if (!funcOp) { + llvm::SmallVector argTypes; + for (mlir::Type type : signature.getInputs()) { + if (auto refType = type.dyn_cast()) + argTypes.push_back(refType.getEleTy()); + else + argTypes.push_back(type); + } + mlir::FunctionType soughtFuncType = + builder.getFunctionType(argTypes, signature.getResults()); + IntrinsicLibrary::RuntimeCallGenerator rtCallGenerator = + getRuntimeCallGenerator(name, soughtFuncType); + funcOp = getWrapper(rtCallGenerator, name, signature, loadRefArguments); + } + + return mlir::SymbolRefAttr::get(funcOp); +} + void IntrinsicLibrary::addCleanUpForTemp(mlir::Location loc, mlir::Value temp) { assert(stmtCtx); fir::FirOpBuilder *bldr = &builder; @@ -3611,3 +3650,10 @@ mlir::Value x, mlir::Value y) { return IntrinsicLibrary{builder, loc}.genRuntimeCall("pow", type, {x, y}); } + +mlir::SymbolRefAttr Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr( + fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name, + mlir::FunctionType signature) { + return IntrinsicLibrary{builder, loc}.getUnrestrictedIntrinsicSymbolRefAttr( + name, signature); +} diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -820,9 +820,10 @@ void fir::ConvertOp::getCanonicalizationPatterns(RewritePatternSet &results, MLIRContext *context) { - results.insert( - context); + results.insert(context); } mlir::OpFoldResult fir::ConvertOp::fold(llvm::ArrayRef opnds) { @@ -875,6 +876,7 @@ (isIntegerCompatible(inType) && isPointerCompatible(outType)) || (isPointerCompatible(inType) && isIntegerCompatible(outType)) || (inType.isa() && outType.isa()) || + (inType.isa() && outType.isa()) || (fir::isa_complex(inType) && fir::isa_complex(outType))) return mlir::success(); return emitOpError("invalid type conversion"); diff --git a/flang/test/Fir/peephole.fir b/flang/test/Fir/peephole.fir new file mode 100644 --- /dev/null +++ b/flang/test/Fir/peephole.fir @@ -0,0 +1,126 @@ +// RUN: tco %s | FileCheck %s + +// Test peephole optimizations + +// CHECK-LABEL: define i8 @test_trunc( +// CHECK-SAME: i256 %[[arg:.*]]) +// CHECK-NEXT: = trunc i256 %[[arg]] to i8 +// CHECK-NEXT: ret i8 +func @test_trunc(%0 : i256) -> i8 { + %1 = fir.convert %0 : (i256) -> i128 + %2 = fir.convert %1 : (i128) -> i64 + %3 = fir.convert %2 : (i64) -> i32 + %4 = fir.convert %3 : (i32) -> i16 + %5 = fir.convert %4 : (i16) -> i8 + return %5 : i8 +} + +// CHECK-LABEL: define i256 @test_sext( +// CHECK-SAME: i8 %[[arg:.*]]) +// CHECK-NEXT: = sext i8 %[[arg]] to i256 +// CHECK-NEXT: ret i256 +func @test_sext(%0 : i8) -> i256 { + %1 = fir.convert %0 : (i8) -> i16 + %2 = fir.convert %1 : (i16) -> i32 + %3 = fir.convert %2 : (i32) -> i64 + %4 = fir.convert %3 : (i64) -> i128 + %5 = fir.convert %4 : (i128) -> i256 + return %5 : i256 +} + +// CHECK-LABEL: define half @test_fptrunc( +// CHECK-SAME: fp128 %[[arg:.*]]) +// CHECK-NEXT: %[[res:.*]] = fptrunc fp128 %[[arg]] to half +// CHECK-NEXT: ret half %[[res]] +func @test_fptrunc(%0 : f128) -> f16 { + %2 = fir.convert %0 : (f128) -> f64 + %3 = fir.convert %2 : (f64) -> f32 + %4 = fir.convert %3 : (f32) -> f16 + return %4 : f16 +} + +// CHECK-LABEL: define x86_fp80 @test_fpext( +// CHECK-SAME: bfloat %[[arg:.*]]) +// CHECK-NEXT: = fpext bfloat %[[arg]] to x86_fp80 +// CHECK-NEXT: ret x86_fp80 +func @test_fpext(%0 : bf16) -> f80 { + %2 = fir.convert %0 : (bf16) -> f32 + %3 = fir.convert %2 : (f32) -> f64 + %4 = fir.convert %3 : (f64) -> f80 + return %4 : f80 +} + +// CHECK-LABEL: define i64 @test_ascending( +// CHECK-SAME: i8 %[[arg:.*]]) +// CHECK-NEXT: = sext i8 %[[arg]] to i64 +// CHECK-NEXT: ret i64 +func @test_ascending(%0 : i8) -> index { + %1 = fir.convert %0 : (i8) -> i16 + %2 = fir.convert %1 : (i16) -> i32 + %3 = fir.convert %2 : (i32) -> i64 + %5 = fir.convert %3 : (i64) -> index + return %5 : index +} + +// CHECK-LABEL: define i8 @test_descending( +// CHECK-SAME: i64 %[[arg:.*]]) +// CHECK-NEXT: = trunc i64 %[[arg]] to i8 +// CHECK-NEXT: ret i8 +func @test_descending(%0 : index) -> i8 { + %2 = fir.convert %0 : (index) -> i64 + %3 = fir.convert %2 : (i64) -> i32 + %4 = fir.convert %3 : (i32) -> i16 + %5 = fir.convert %4 : (i16) -> i8 + return %5 : i8 +} + +// CHECK-LABEL: define float @test_useless( +// CHECK-SAME: float %[[arg:.*]]) +// CHECK-NEXT: ret float %[[arg]] +func @test_useless(%0 : f32) -> f32 { + %1 = fir.convert %0 : (f32) -> f32 + return %1 : f32 +} + +// CHECK-LABEL: define float @test_useless_sext( +// CHECK-SAME: i32 %[[arg:.*]]) +// CHECK-NEXT: %[[res:.*]] = sitofp i32 %[[arg]] to float +// CHECK-NEXT: ret float %[[res]] +func @test_useless_sext(%0 : i32) -> f32 { + %1 = fir.convert %0 : (i32) -> i64 + %2 = fir.convert %1 : (i64) -> i32 + %3 = fir.convert %2 : (i32) -> f32 + return %3 : f32 +} + +// CHECK-LABEL: define i16 @test_hump( +// CHECK-SAME: i32 %[[arg:.*]]) +// CHECK-NEXT: trunc i32 %[[arg]] to i16 +// CHECK-NEXT: ret i16 +func @test_hump(%0 : i32) -> i16 { + %1 = fir.convert %0 : (i32) -> i64 + %2 = fir.convert %1 : (i64) -> i16 + return %2 : i16 +} + +// CHECK-LABEL: define i16 @test_slump( +// CHECK-SAME: i32 %[[arg:.*]]) +// CHECK-NEXT: %[[i:.*]] = trunc i32 %[[arg]] to i8 +// CHECK-NEXT: sext i8 %[[i]] to i16 +// CHECK-NEXT: ret i16 +func @test_slump(%0 : i32) -> i16 { + %1 = fir.convert %0 : (i32) -> i8 + %2 = fir.convert %1 : (i8) -> i16 + return %2 : i16 +} + +// CHECK-LABEL: define i64 @test_slump2( +// CHECK-SAME: i64 %[[arg:.*]]) +// CHECK-NEXT: %[[i:.*]] = trunc i64 %[[arg]] to i16 +// CHECK-NEXT: sext i16 %[[i]] to i64 +// CHECK-NEXT: ret i64 +func @test_slump2(%0 : index) -> index { + %1 = fir.convert %0 : (index) -> i16 + %2 = fir.convert %1 : (i16) -> index + return %2 : index +} diff --git a/flang/test/Lower/procedure-declarations.f90 b/flang/test/Lower/procedure-declarations.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/procedure-declarations.f90 @@ -0,0 +1,142 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test procedure declarations. Change appearance order of definition and usages +! (passing a procedure and calling it), with and without definitions. +! Check that the definition type prevail if available and that casts are inserted to +! accommodate for the signature mismatch in the different location due to implicit +! typing rules and Fortran loose interface compatibility rule history. + + +! Note: all the cases where their is a definition are exactly the same, +! since definition should be processed first regardless. + +! pass, call, define +! CHECK-LABEL: func @_QPcall_foo( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo(i) + integer :: i(10) + ! %[[argconvert:*]] = fir.convert %arg0 : + ! fir.call @_QPfoo(%[[argconvert]]) : (!fir.ref>) -> () + call foo(i) +end subroutine +! CHECK-LABEL: func @_QPfoo( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine foo(i) + integer :: i(2, 5) + call do_something(i) +end subroutine + +! call, pass, define +! CHECK-LABEL: func @_QPcall_foo2( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo2(i) + integer :: i(10) + ! %[[argconvert:*]] = fir.convert %arg0 : + ! fir.call @_QPfoo2(%[[argconvert]]) : (!fir.ref>) -> () + call foo2(i) +end subroutine +! CHECK-LABEL: func @_QPfoo2( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine foo2(i) + integer :: i(2, 5) + call do_something(i) +end subroutine + +! call, define, pass +! CHECK-LABEL: func @_QPcall_foo3( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo3(i) + integer :: i(10) + ! %[[argconvert:*]] = fir.convert %arg0 : + ! fir.call @_QPfoo3(%[[argconvert]]) : (!fir.ref>) -> () + call foo3(i) +end subroutine +! CHECK-LABEL: func @_QPfoo3( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine foo3(i) + integer :: i(2, 5) + call do_something(i) +end subroutine + +! define, call, pass +! CHECK-LABEL: func @_QPfoo4( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine foo4(i) + integer :: i(2, 5) + call do_something(i) +end subroutine +! CHECK-LABEL: func @_QPcall_foo4( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo4(i) + integer :: i(10) + ! %[[argconvert:*]] = fir.convert %arg0 : + ! fir.call @_QPfoo4(%[[argconvert]]) : (!fir.ref>) -> () + call foo4(i) +end subroutine + +! define, pass, call +! CHECK-LABEL: func @_QPfoo5( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine foo5(i) + integer :: i(2, 5) + call do_something(i) +end subroutine +! CHECK-LABEL: func @_QPcall_foo5( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo5(i) + integer :: i(10) + ! %[[argconvert:*]] = fir.convert %arg0 : + ! fir.call @_QPfoo5(%[[argconvert]]) : (!fir.ref>) -> () + call foo5(i) +end subroutine + + +! Test when there is no definition (declaration at the end of the mlir module) +! First use gives the function type + +! call, pass +! CHECK-LABEL: func @_QPcall_foo6( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo6(i) + integer :: i(10) + ! CHECK-NOT: convert + call foo6(i) +end subroutine + + +! call, call with different type +! CHECK-LABEL: func @_QPcall_foo8( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo8(i) + integer :: i(10) + ! CHECK-NOT: convert + call foo8(i) +end subroutine +! CHECK-LABEL: func @_QPcall_foo8_2( +! CHECK-SAME: %{{.*}}: !fir.ref>{{.*}}) { +subroutine call_foo8_2(i) + integer :: i(2, 5) + ! %[[argconvert:*]] = fir.convert %arg0 : + call foo8(i) +end subroutine + +! Test that target attribute is lowered in declaration of functions that are +! not defined in this file. +! CHECK-LABEL:func @_QPtest_target_in_iface +subroutine test_target_in_iface() + interface + subroutine test_target(i, x) + integer, target :: i + real, target :: x(:) + end subroutine + end interface + integer :: i + real :: x(10) + ! CHECK: fir.call @_QPtest_target + call test_target(i, x) +end subroutine + +! CHECK: func private @_QPfoo6(!fir.ref>) + +! Test declaration from test_target_in_iface +! CHECK-LABEL: func private @_QPtest_target(!fir.ref {fir.target}, !fir.box> {fir.target}) diff --git a/flang/test/Lower/program-units-fir-mangling.f90 b/flang/test/Lower/program-units-fir-mangling.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/program-units-fir-mangling.f90 @@ -0,0 +1,154 @@ +! RUN: bbc %s -o "-" -emit-fir | FileCheck %s + +! CHECK-LABEL: func @_QPsub() { +subroutine sub() +! CHECK: } +end subroutine + +! CHECK-LABEL: func @_QPasubroutine() { +subroutine AsUbRoUtInE() +! CHECK: } +end subroutine + +! CHECK-LABEL: func @_QPfoo() -> f32 { +function foo() + real(4) :: foo + real :: pi = 3.14159 +! CHECK: } +end function + + +! CHECK-LABEL: func @_QPfunctn() -> f32 { +function functn + real, parameter :: pi = 3.14 +! CHECK: } +end function + + +module testMod +contains + ! CHECK-LABEL: func @_QMtestmodPsub() { + subroutine sub() + ! CHECK: } + end subroutine + + ! CHECK-LABEL: func @_QMtestmodPfoo() -> f32 { + function foo() + real(4) :: foo + ! CHECK: } + end function +end module + + +! CHECK-LABEL: func @_QPfoo2() +function foo2() + real(4) :: foo2 +contains + ! CHECK-LABEL: func @_QFfoo2Psub() { + subroutine sub() + ! CHECK: } + end subroutine + + ! CHECK-LABEL: func @_QFfoo2Pfoo() { + subroutine foo() + ! CHECK: } + end subroutine +end function + +! CHECK-LABEL: func @_QPsub2() +subroutine sUb2() +contains + ! CHECK-LABEL: func @_QFsub2Psub() { + subroutine sub() + ! CHECK: } + end subroutine + + ! CHECK-LABEL: func @_QFsub2Pfoo() { + subroutine Foo() + ! CHECK: } + end subroutine +end subroutine + +module testMod2 +contains + ! CHECK-LABEL: func @_QMtestmod2Psub() + subroutine sub() + contains + ! CHECK-LABEL: func @_QMtestmod2FsubPsubsub() { + subroutine subSub() + ! CHECK: } + end subroutine + end subroutine +end module + + +module color_points + interface + module subroutine draw() + end subroutine + module function erase() + integer(4) :: erase + end function + end interface +end module color_points + +! We don't handle lowering of submodules yet. The following tests are +! commented out and "CHECK" is changed to "xHECK" to not trigger FileCheck. +!submodule (color_points) color_points_a +!contains +! ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aPsub() { +! subroutine sub +! end subroutine +! ! xHECK: } +!end submodule +! +!submodule (color_points:color_points_a) impl +!contains +! ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplPfoo() +! subroutine foo +! contains +! ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplFfooPbar() { +! subroutine bar +! ! xHECK: } +! end subroutine +! end subroutine +! ! xHECK-LABEL: func @_QMcolor_pointsPdraw() { +! module subroutine draw() +! end subroutine +! !FIXME func @_QMcolor_pointsPerase() -> i32 { +! module procedure erase +! ! xHECK: } +! end procedure +!end submodule + +! CHECK-LABEL: func @_QPshould_not_collide() { +subroutine should_not_collide() +! CHECK: } +end subroutine + +! CHECK-LABEL: func @_QQmain() { +program test +! CHECK: } +contains +! CHECK-LABEL: func @_QFPshould_not_collide() { +subroutine should_not_collide() +! CHECK: } +end subroutine +end program + +! CHECK-LABEL: func @omp_get_num_threads() -> f32 attributes {fir.sym_name = "_QPomp_get_num_threads"} { +function omp_get_num_threads() bind(c) +! CHECK: } +end function + +! CHECK-LABEL: func @get_threads() -> f32 attributes {fir.sym_name = "_QPomp_get_num_threads_1"} { +function omp_get_num_threads_1() bind(c, name ="get_threads") +! CHECK: } +end function + +! CHECK-LABEL: func @bEtA() -> f32 attributes {fir.sym_name = "_QPalpha"} { +function alpha() bind(c, name =" bEtA ") +! CHECK: } +end function + +! CHECK-LABEL: fir.global internal @_QFfooEpi : f32 { diff --git a/flang/test/Lower/read-write-buffer.f90 b/flang/test/Lower/read-write-buffer.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/read-write-buffer.f90 @@ -0,0 +1,35 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test that we are passing the correct length when using character array as +! Format (Fortran 2018 12.6.2.2 point 3) +! CHECK-LABEL: func @_QPtest_array_format +subroutine test_array_format + ! CHECK-DAG: %[[c2:.*]] = arith.constant 2 : index + ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 : index + ! CHECK-DAG: %[[mem:.*]] = fir.alloca !fir.array<2x!fir.char<1,10>> + character(10) :: array(2) + array(1) ="(15HThis i" + array(2) ="s a test.)" + ! CHECK-DAG: %[[fmtLen:.*]] = arith.muli %[[c10]], %[[c2]] : index + ! CHECK-DAG: %[[scalarFmt:.*]] = fir.convert %[[mem]] : (!fir.ref>>) -> !fir.ref> + ! CHECK-DAG: %[[fmtArg:.*]] = fir.convert %[[scalarFmt]] : (!fir.ref>) -> !fir.ref + ! CHECK-DAG: %[[fmtLenArg:.*]] = fir.convert %[[fmtLen]] : (index) -> i64 + ! CHECK: fir.call @_FortranAioBeginExternalFormattedOutput(%[[fmtArg]], %[[fmtLenArg]], {{.*}}) + write(*, array) + end subroutine + + ! A test to check the buffer and it's length. + ! CHECK-LABEL: @_QPsome + subroutine some() + character(LEN=255):: buffer + character(LEN=255):: greeting + 10 format (A255) + ! CHECK: fir.address_of(@_QQcl.636F6D70696C6572) : + write (buffer, 10) "compiler" + read (buffer, 10) greeting + end + ! CHECK-LABEL: fir.global linkonce @_QQcl.636F6D70696C6572 + ! CHECK: %[[lit:.*]] = fir.string_lit "compiler"(8) : !fir.char<1,8> + ! CHECK: fir.has_value %[[lit]] : !fir.char<1,8> + ! CHECK: } + \ No newline at end of file