[flang] Lower procedure designator

[clementval]

Summary

This patch adds lowering for procedure designator.

This patch is part of the upstreaming effort from fir-dev branch.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Lower/IntrinsicCall.h

 /// intrinsic function. The argument names are the one defined by the standard.
 ArgLoweringRule lowerIntrinsicArgumentAs(mlir::Location,
                                          const IntrinsicArgumentLoweringRules &,
                                          llvm::StringRef argName);
 
 /// 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.
 //===----------------------------------------------------------------------===//
 
 /// Generate maximum. There must be at least one argument and all arguments
 /// must have the same type.
 mlir::Value genMax(fir::FirOpBuilder &, mlir::Location,

flang/include/flang/Optimizer/Dialect/CanonicalizationPatterns.td

 include "mlir/IR/PatternBase.td"
 include "mlir/Dialect/Arithmetic/IR/ArithmeticOps.td"
 include "flang/Optimizer/Dialect/FIROps.td"
 
 def IdenticalTypePred : Constraint<CPred<"$0.getType() == $1.getType()">>;
 def IntegerTypePred : Constraint<CPred<"fir::isa_integer($0.getType())">>;
 def IndexTypePred : Constraint<CPred<"$0.getType().isa<mlir::IndexType>()">>;
 
-def SmallerWidthPred
-    : Constraint<CPred<"$0.getType().getIntOrFloatBitWidth() "
-                       "<= $1.getType().getIntOrFloatBitWidth()">>;
+// Widths are monotonic.
+//   $0.bits >= $1.bits >= $2.bits or $0.bits <= $1.bits <= $2.bits
+def MonotonicTypePred
+    : Constraint<CPred<"(($0.getType().isa<mlir::IntegerType>() && "
+                       "  $1.getType().isa<mlir::IntegerType>() && "
+                       "  $2.getType().isa<mlir::IntegerType>()) || "
+                       " ($0.getType().isa<mlir::FloatType>() && "
+                       "  $1.getType().isa<mlir::FloatType>() && "
+                       "  $2.getType().isa<mlir::FloatType>())) && "
+                       "(($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<CPred<
+                       "$0.getType().isa<mlir::IntegerType>() && "
+                       "$1.getType().isa<mlir::IntegerType>()">>;
+                       
+// If both are int type and the first is smaller than the second.
+//   $0.bits <= $1.bits
+def SmallerWidthPred : Constraint<CPred<
+                       "$0.getType().getIntOrFloatBitWidth() <= "
+                       "$1.getType().getIntOrFloatBitWidth()">>;
+def StrictSmallerWidthPred : Constraint<CPred<
+                       "$0.getType().getIntOrFloatBitWidth() < "
+                       "$1.getType().getIntOrFloatBitWidth()">>;
 
+// 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<mlir::arith::ConstantOp>"
                      "($_loc, $_builder.getIndexType(), "
                      "rewriter.getIndexAttr($1.dyn_cast<mlir::IntegerAttr>()"
                      ".getInt()))">;
 
 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

flang/lib/Lower/ConvertExpr.cpp

if (const auto *parentheses = std::get_if<Parentheses>(&expr.u))
       return Fortran::evaluate::IsVariable(parentheses->left());
     return false;
   } else {
     return std::visit([&](const auto &x) { return isParenthesizedVariable(x); },
                       expr.u);
   }
 }
 
+/// 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).
 static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
                                   mlir::Location loc,
                                   const fir::ExtendedValue &addr) {
   return addr.match(
       [](const fir::CharBoxValue &box) -> fir::ExtendedValue { return box; },
public:
   ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) {
     TODO(getLoc(), "genval BOZ");
   }
 
   /// Return indirection to function designated in ProcedureDesignator.
   /// 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<fir::AddrOfOp>(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<fir::AddrOfOp>(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
   isDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) {
     if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
       if (const Fortran::semantics::DerivedTypeSpec *derived =
               declTy->AsDerived())
         return Fortran::semantics::CountLenParameters(*derived) > 0;

flang/lib/Lower/IntrinsicCall.cpp

mlir::Value invokeGenerator(RuntimeCallGenerator generator,
                               mlir::Type resultType,
                               llvm::ArrayRef<mlir::Value> args);
   mlir::Value invokeGenerator(ExtendedGenerator generator,
                               mlir::Type resultType,
                               llvm::ArrayRef<mlir::Value> args);
   mlir::Value invokeGenerator(SubroutineGenerator generator,
                               llvm::ArrayRef<mlir::Value> 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
   fir::ExtendedValue readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,
                                        mlir::Type resultType,
                                        llvm::StringRef errMsg);
 
   fir::FirOpBuilder &builder;
return [funcOp, actualFuncType,
     for (auto [fst, snd] : llvm::zip(actualFuncType.getInputs(), args))
       convertedArguments.push_back(builder.createConvert(loc, fst, snd));
     auto call = builder.create<fir::CallOp>(loc, funcOp, convertedArguments);
     mlir::Type soughtType = soughtFuncType.getResult(0);
     return builder.createConvert(loc, soughtType, call.getResult(0));
   };
 }
 
+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<mlir::Type> argTypes;
+    for (mlir::Type type : signature.getInputs()) {
+      if (auto refType = type.dyn_cast<fir::ReferenceType>())
+        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;
   stmtCtx->attachCleanup([=]() { bldr->create<fir::FreeMemOp>(loc, temp); });
 }
 
 fir::ExtendedValue
 IntrinsicLibrary::readAndAddCleanUp(fir::MutableBoxValue resultMutableBox,
return IntrinsicLibrary{builder, loc}
                                                               args);
 }
 
 mlir::Value Fortran::lower::genPow(fir::FirOpBuilder &builder,
                                    mlir::Location loc, mlir::Type type,
                                    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);
+}

flang/lib/Optimizer/Dialect/FIROps.cpp

 }
 
 //===----------------------------------------------------------------------===//
 // ConvertOp
 //===----------------------------------------------------------------------===//
 
 void fir::ConvertOp::getCanonicalizationPatterns(RewritePatternSet &results,
                                                  MLIRContext *context) {
-  results.insert<ConvertConvertOptPattern, RedundantConvertOptPattern,
-                 CombineConvertOptPattern, ForwardConstantConvertPattern>(
-      context);
+  results.insert<ConvertConvertOptPattern, ConvertAscendingIndexOptPattern,
+                 ConvertDescendingIndexOptPattern, RedundantConvertOptPattern,
+                 CombineConvertOptPattern, CombineConvertTruncOptPattern,
+                 ForwardConstantConvertPattern>(context);
 }
 
 mlir::OpFoldResult fir::ConvertOp::fold(llvm::ArrayRef<mlir::Attribute> opnds) {
   if (getValue().getType() == getType())
     return getValue();
   if (matchPattern(getValue(), m_Op<fir::ConvertOp>())) {
     auto inner = cast<fir::ConvertOp>(getValue().getDefiningOp());
     // (convert (convert 'a : logical -> i1) : i1 -> logical) ==> forward 'a
mlir::LogicalResult ConvertOp::verify() {
   if ((isPointerCompatible(inType) && isPointerCompatible(outType)) ||
       (isIntegerCompatible(inType) && isIntegerCompatible(outType)) ||
       (isIntegerCompatible(inType) && isFloatCompatible(outType)) ||
       (isFloatCompatible(inType) && isIntegerCompatible(outType)) ||
       (isFloatCompatible(inType) && isFloatCompatible(outType)) ||
       (isIntegerCompatible(inType) && isPointerCompatible(outType)) ||
       (isPointerCompatible(inType) && isIntegerCompatible(outType)) ||
       (inType.isa<fir::BoxType>() && outType.isa<fir::BoxType>()) ||
+      (inType.isa<fir::BoxProcType>() && outType.isa<fir::BoxProcType>()) ||
       (fir::isa_complex(inType) && fir::isa_complex(outType)))
     return mlir::success();
   return emitOpError("invalid type conversion");
 }
 
 //===----------------------------------------------------------------------===//
 // CoordinateOp
 //===----------------------------------------------------------------------===//

flang/test/Fir/peephole.fir

+// 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
+}

flang/test/Lower/procedure-declarations.f90

+! 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<!fir.array<10xi32>>{{.*}}) {
+subroutine call_foo(i)
+  integer :: i(10)
+  ! %[[argconvert:*]] = fir.convert %arg0 :
+  ! fir.call @_QPfoo(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
+  call foo(i)
+end subroutine 
+! CHECK-LABEL: func @_QPfoo(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
+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<!fir.array<10xi32>>{{.*}}) {
+subroutine call_foo2(i)
+  integer :: i(10)
+  ! %[[argconvert:*]] = fir.convert %arg0 :
+  ! fir.call @_QPfoo2(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
+  call foo2(i)
+end subroutine 
+! CHECK-LABEL: func @_QPfoo2(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
+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<!fir.array<10xi32>>{{.*}}) {
+subroutine call_foo3(i)
+  integer :: i(10)
+  ! %[[argconvert:*]] = fir.convert %arg0 :
+  ! fir.call @_QPfoo3(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
+  call foo3(i)
+end subroutine 
+! CHECK-LABEL: func @_QPfoo3(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
+subroutine foo3(i)
+  integer :: i(2, 5)
+  call do_something(i)
+end subroutine
+
+! define, call, pass
+! CHECK-LABEL: func @_QPfoo4(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
+subroutine foo4(i)
+  integer :: i(2, 5)
+  call do_something(i)
+end subroutine
+! CHECK-LABEL: func @_QPcall_foo4(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
+subroutine call_foo4(i)
+  integer :: i(10)
+  ! %[[argconvert:*]] = fir.convert %arg0 :
+  ! fir.call @_QPfoo4(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
+  call foo4(i)
+end subroutine 
+
+! define, pass, call
+! CHECK-LABEL: func @_QPfoo5(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
+subroutine foo5(i)
+  integer :: i(2, 5)
+  call do_something(i)
+end subroutine
+! CHECK-LABEL: func @_QPcall_foo5(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
+subroutine call_foo5(i)
+  integer :: i(10)
+  ! %[[argconvert:*]] = fir.convert %arg0 :
+  ! fir.call @_QPfoo5(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
+  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<!fir.array<10xi32>>{{.*}}) {
+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<!fir.array<10xi32>>{{.*}}) {
+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<!fir.array<2x5xi32>>{{.*}}) {
+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<!fir.array<10xi32>>)
+
+! Test declaration from test_target_in_iface
+! CHECK-LABEL: func private @_QPtest_target(!fir.ref<i32> {fir.target}, !fir.box<!fir.array<?xf32>> {fir.target})

flang/test/Lower/program-units-fir-mangling.f90

+! 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 {

flang/test/Lower/read-write-buffer.f90

+! 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.array<2x!fir.char<1,10>>>) -> !fir.ref<!fir.char<1,?>>
+    ! CHECK-DAG: %[[fmtArg:.*]] = fir.convert %[[scalarFmt]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+    ! 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