[flang] Lower F08 parity intrinsic

Lower F08 parity intrinsic. This largely follows the implementation of the ANY
and ALL intrinsics which are related.

Differential Revision: https://reviews.llvm.org/D129788

flang/include/flang/Optimizer/Builder/Runtime/Reduction.h

@@ -39,6 +39,13 @@ void genAnyDescriptor(fir::FirOpBuilder &builder, mlir::Location loc,
                       mlir::Value resultBox, mlir::Value maskBox,
                       mlir::Value dim);
 
+/// Generate call to `ParityDim` runtime routine.
+/// This calls the descriptor based runtime call implementation of the `parity`
+/// intrinsic.
+void genParityDescriptor(fir::FirOpBuilder &builder, mlir::Location loc,
+                         mlir::Value resultBox, mlir::Value maskBox,
+                         mlir::Value dim);
+
 /// Generate call to `All` runtime routine. This version of `all` is specialized
 /// for rank 1 mask arguments.
 /// This calls the version that returns a scalar logical value.
@@ -128,6 +135,12 @@ void genMinvalDim(fir::FirOpBuilder &builder, mlir::Location loc,
                   mlir::Value resultBox, mlir::Value arrayBox, mlir::Value dim,
                   mlir::Value maskBox);
 
+/// Generate call to `Parity` runtime routine. This version of `parity` is
+/// specialized for rank 1 mask arguments.
+/// This calls the version that returns a scalar logical value.
+mlir::Value genParity(fir::FirOpBuilder &builder, mlir::Location loc,
+                      mlir::Value maskBox, mlir::Value dim);
+
 /// Generate call to `Product` intrinsic runtime routine. This is the version
 /// that does not take a dim argument.
 mlir::Value genProduct(fir::FirOpBuilder &builder, mlir::Location loc,

flang/lib/Lower/IntrinsicCall.cpp

@@ -535,6 +535,7 @@ struct IntrinsicLibrary {
   mlir::Value genNot(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genPack(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genParity(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genPopcnt(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genPoppar(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genPresent(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
@@ -882,6 +883,10 @@ static constexpr IntrinsicHandler handlers[]{
        {"mask", asBox},
        {"vector", asBox, handleDynamicOptional}}},
      /*isElemental=*/false},
+    {"parity",
+     &I::genParity,
+     {{{"mask", asBox}, {"dim", asValue}}},
+     /*isElemental=*/false},
     {"popcnt", &I::genPopcnt},
     {"poppar", &I::genPoppar},
     {"present",
@@ -3631,6 +3636,52 @@ IntrinsicLibrary::genPack(mlir::Type resultType,
                            "unexpected result for PACK");
 }
 
+// PARITY
+fir::ExtendedValue
+IntrinsicLibrary::genParity(mlir::Type resultType,
+                            llvm::ArrayRef<fir::ExtendedValue> args) {
+
+  assert(args.size() == 2);
+  // Handle required mask argument
+  mlir::Value mask = builder.createBox(loc, args[0]);
+
+  fir::BoxValue maskArry = builder.createBox(loc, args[0]);
+  int rank = maskArry.rank();
+  assert(rank >= 1);
+
+  // Handle optional dim argument
+  bool absentDim = isStaticallyAbsent(args[1]);
+  mlir::Value dim =
+      absentDim ? builder.createIntegerConstant(loc, builder.getIndexType(), 1)
+                : fir::getBase(args[1]);
+
+  if (rank == 1 || absentDim)
+    return builder.createConvert(
+        loc, resultType, fir::runtime::genParity(builder, loc, mask, dim));
+
+  // else use the result descriptor ParityDim() intrinsic
+
+  // Create mutable fir.box to be passed to the runtime for the result.
+
+  mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, rank - 1);
+  fir::MutableBoxValue resultMutableBox =
+      fir::factory::createTempMutableBox(builder, loc, resultArrayType);
+  mlir::Value resultIrBox =
+      fir::factory::getMutableIRBox(builder, loc, resultMutableBox);
+
+  // Call runtime. The runtime is allocating the result.
+  fir::runtime::genParityDescriptor(builder, loc, resultIrBox, mask, dim);
+  return fir::factory::genMutableBoxRead(builder, loc, resultMutableBox)
+      .match(
+          [&](const fir::ArrayBoxValue &box) -> fir::ExtendedValue {
+            addCleanUpForTemp(loc, box.getAddr());
+            return box;
+          },
+          [&](const auto &) -> fir::ExtendedValue {
+            fir::emitFatalError(loc, "Invalid result for PARITY");
+          });
+}
+
 // POPCNT
 mlir::Value IntrinsicLibrary::genPopcnt(mlir::Type resultType,
                                         llvm::ArrayRef<mlir::Value> args) {

flang/lib/Optimizer/Builder/Runtime/Reduction.cpp

@@ -471,6 +471,18 @@ void fir::runtime::genAnyDescriptor(fir::FirOpBuilder &builder,
   genReduction2Args(anyFunc, builder, loc, resultBox, maskBox, dim);
 }
 
+/// Generate call to `ParityDim` runtime routine.
+/// This calls the descriptor based runtime call implementation of the `parity`
+/// intrinsic.
+void fir::runtime::genParityDescriptor(fir::FirOpBuilder &builder,
+                                       mlir::Location loc,
+                                       mlir::Value resultBox,
+                                       mlir::Value maskBox, mlir::Value dim) {
+  auto parityFunc =
+      fir::runtime::getRuntimeFunc<mkRTKey(ParityDim)>(loc, builder);
+  genReduction2Args(parityFunc, builder, loc, resultBox, maskBox, dim);
+}
+
 /// Generate call to `All` intrinsic runtime routine. This routine is
 /// specialized for mask arguments with rank == 1.
 mlir::Value fir::runtime::genAll(fir::FirOpBuilder &builder, mlir::Location loc,
@@ -694,6 +706,15 @@ mlir::Value fir::runtime::genMinval(fir::FirOpBuilder &builder,
   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
 }
 
+/// Generate call to `Parity` intrinsic runtime routine. This routine is
+/// specialized for mask arguments with rank == 1.
+mlir::Value fir::runtime::genParity(fir::FirOpBuilder &builder,
+                                    mlir::Location loc, mlir::Value maskBox,
+                                    mlir::Value dim) {
+  auto parityFunc = fir::runtime::getRuntimeFunc<mkRTKey(Parity)>(loc, builder);
+  return genSpecial2Args(parityFunc, builder, loc, maskBox, dim);
+}
+
 /// Generate call to `ProductDim` intrinsic runtime routine. This is the version
 /// that handles any rank array with the dim argument specified.
 void fir::runtime::genProductDim(fir::FirOpBuilder &builder, mlir::Location loc,

flang/test/Lower/Intrinsics/parity.f90

@@ -0,0 +1,32 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: parity_test
+! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>{{.*}}) -> !fir.logical<4>
+logical function parity_test(mask)
+  logical :: mask(:)
+  ! CHECK: %[[c1:.*]] = arith.constant 1 : index
+  ! CHECK: %[[a1:.*]] = fir.convert %[[arg0]] : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
+  ! CHECK: %[[a2:.*]] = fir.convert %[[c1]] : (index) -> i32
+  parity_test = parity(mask)
+  ! CHECK:  %[[a3:.*]] = fir.call @_FortranAParity(%[[a1]], %{{.*}},  %{{.*}}, %[[a2]]) : (!fir.box<none>, !fir.ref<i8>, i32, i32) -> i1
+end function parity_test
+
+! CHECK-LABEL: parity_test2
+! CHECK-SAME: %[[arg0:.*]]: !fir.box<!fir.array<?x?x!fir.logical<4>>>
+! CHECK-SAME: %[[arg1:.*]]: !fir.ref<i32>
+! CHECK-SAME: %[[arg2:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>>
+subroutine parity_test2(mask, d, rslt)
+  logical :: mask(:,:)
+  integer :: d
+  logical :: rslt(:)
+  ! CHECK-DAG:  %[[a0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>
+  ! CHECK-DAG:  %[[a1:.*]] = fir.load %[[arg1:.*]] : !fir.ref<i32>
+  ! CHECK-DAG:  %[[a6:.*]] = fir.convert %[[a0:.*]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>>) -> !fir.ref<!fir.box<none>>
+  ! CHECK-DAG:  %[[a7:.*]] = fir.convert %[[arg0:.*]]: (!fir.box<!fir.array<?x?x!fir.logical<4>>>) -> !fir.box<none>
+  rslt = parity(mask, d)
+  ! CHECK:  %[[r1:.*]] = fir.call @_FortranAParityDim(%[[a6:.*]], %[[a7:.*]], %[[a1:.*]], %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, i32, !fir.ref<i8>, i32) -> none
+  ! CHECK-DAG:  %[[a10:.*]] = fir.load %[[a0:.*]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>>
+  ! CHECK-DAG:  %[[a12:.*]] = fir.box_addr %[[a10:.*]] : (!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>) -> !fir.heap<!fir.array<?x!fir.logical<4>>>
+  ! CHECK-DAG  fir.freemem %[[a12:.*]]
+end subroutine parity_test2

flang/unittests/Optimizer/Builder/Runtime/ReductionTest.cpp

@@ -112,6 +112,23 @@ TEST_F(RuntimeCallTest, genMinValTest) {
   testGenMinVal(*firBuilder, i128Ty, "_FortranAMinvalInteger16");
 }
 
+TEST_F(RuntimeCallTest, genParityTest) {
+  mlir::Location loc = firBuilder->getUnknownLoc();
+  mlir::Value undef = firBuilder->create<fir::UndefOp>(loc, seqTy10);
+  mlir::Value dim = firBuilder->createIntegerConstant(loc, i32Ty, 1);
+  mlir::Value parity = fir::runtime::genParity(*firBuilder, loc, undef, dim);
+  checkCallOp(parity.getDefiningOp(), "_FortranAParity", 2);
+}
+
+TEST_F(RuntimeCallTest, genParityDescriptorTest) {
+  mlir::Location loc = firBuilder->getUnknownLoc();
+  mlir::Value result = firBuilder->create<fir::UndefOp>(loc, seqTy10);
+  mlir::Value mask = firBuilder->create<fir::UndefOp>(loc, seqTy10);
+  mlir::Value dim = firBuilder->createIntegerConstant(loc, i32Ty, 1);
+  fir::runtime::genParityDescriptor(*firBuilder, loc, result, mask, dim);
+  checkCallOpFromResultBox(result, "_FortranAParityDim", 3);
+}
+
 void testGenSum(
     fir::FirOpBuilder &builder, mlir::Type eleTy, llvm::StringRef fctName) {
   mlir::Location loc = builder.getUnknownLoc();