[flang-commits] [flang] [Flang][HLFIR] Lower PACK(array, .TRUE.) to hlfir.reshape (PR #213603)
via flang-commits
flang-commits at lists.llvm.org
Fri Aug 7 04:27:58 PDT 2026
https://github.com/ejose02 updated https://github.com/llvm/llvm-project/pull/213603
>From 66cb398f78412156bce5fdde9dbde64eed0eb7b2 Mon Sep 17 00:00:00 2001
From: ejose <ejose at amd.com>
Date: Mon, 3 Aug 2026 06:36:01 +0000
Subject: [PATCH 1/2] [Flang][HLFIR] Lower PACK(array, .TRUE.) to hlfir.reshape
When the PACK mask is the compile-time scalar .TRUE., the result is equivalent to RESHAPE(array, [SIZE(array)]). Detect this case during HLFIR intrinsic lowering and emit hlfir.reshape, reusing the same operation as the RESHAPE intrinsic rather than calling _FortranAPack.
This allows later optimization passes to handle the operation as a reshape instead of going through the general PACK runtime. Variable or array masks, VECTOR, and non-trivial or polymorphic operands continue to use the existing runtime PACK path.
---
flang/include/flang/Lower/HlfirIntrinsics.h | 6 +++
flang/lib/Lower/ConvertCall.cpp | 31 ++++++++++++
flang/lib/Lower/HlfirIntrinsics.cpp | 54 +++++++++++++++++++++
flang/test/Lower/HLFIR/pack_scalar_true.f90 | 46 ++++++++++++++++++
4 files changed, 137 insertions(+)
create mode 100644 flang/test/Lower/HLFIR/pack_scalar_true.f90
diff --git a/flang/include/flang/Lower/HlfirIntrinsics.h b/flang/include/flang/Lower/HlfirIntrinsics.h
index 930bbeb6fb452..98e088afc4051 100644
--- a/flang/include/flang/Lower/HlfirIntrinsics.h
+++ b/flang/include/flang/Lower/HlfirIntrinsics.h
@@ -160,5 +160,11 @@ std::optional<hlfir::EntityWithAttributes> lowerHlfirIntrinsic(
const fir::IntrinsicArgumentLoweringRules *argLowering,
mlir::Type stmtResultType);
+std::optional<hlfir::EntityWithAttributes>
+lowerPackAsReshape(fir::FirOpBuilder &builder, mlir::Location loc,
+ const PreparedActualArguments &loweredActuals,
+ const fir::IntrinsicArgumentLoweringRules *argLowering,
+ mlir::Type stmtResultType);
+
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_HLFIRINTRINSICS_H
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 19678e429249b..2466844e81c9b 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -2372,6 +2372,29 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals,
/// Lower calls to intrinsic procedures with actual arguments that have been
/// pre-lowered but have not yet been prepared according to the interface.
+static bool
+isPackWithScalarTrueMask(const Fortran::evaluate::ProcedureRef &procRef,
+ Fortran::lower::AbstractConverter &converter) {
+ if (procRef.arguments().size() < 2 || !procRef.arguments()[1])
+ return false;
+ if (procRef.arguments().size() >= 3 && procRef.arguments()[2])
+ return false;
+ const auto *maskExpr = procRef.UnwrapArgExpr(1);
+ if (!maskExpr)
+ return false;
+ const auto *logExpr = Fortran::evaluate::UnwrapExpr<
+ Fortran::evaluate::Expr<Fortran::evaluate::SomeLogical>>(*maskExpr);
+ if (!logExpr || logExpr->Rank() != 0)
+ return false;
+ auto &ctx = converter.getFoldingContext();
+ auto asDefault = Fortran::evaluate::Fold(
+ ctx, Fortran::evaluate::ConvertToType<Fortran::evaluate::LogicalResult>(
+ Fortran::evaluate::Fold(
+ ctx, Fortran::evaluate::Expr<Fortran::evaluate::SomeLogical>(
+ *logExpr))));
+ return Fortran::evaluate::ToLogical(asDefault).value_or(false);
+}
+
static std::optional<hlfir::EntityWithAttributes> genHLFIRIntrinsicRefCore(
Fortran::lower::PreparedActualArguments &loweredActuals,
const Fortran::evaluate::SpecificIntrinsic *intrinsic,
@@ -2398,6 +2421,14 @@ static std::optional<hlfir::EntityWithAttributes> genHLFIRIntrinsicRefCore(
? hlfir::getFortranElementType(*callContext.resultType)
: *callContext.resultType;
+ if (intrinsicName == "pack" &&
+ isPackWithScalarTrueMask(callContext.procRef, callContext.converter)) {
+ if (std::optional<hlfir::EntityWithAttributes> res =
+ Fortran::lower::lowerPackAsReshape(builder, loc, loweredActuals,
+ argLowering, resultType))
+ return res;
+ }
+
std::optional<hlfir::EntityWithAttributes> res =
Fortran::lower::lowerHlfirIntrinsic(builder, loc, intrinsicName,
loweredActuals, argLowering,
diff --git a/flang/lib/Lower/HlfirIntrinsics.cpp b/flang/lib/Lower/HlfirIntrinsics.cpp
index 9ee30e52af697..c1dbc7f24747a 100644
--- a/flang/lib/Lower/HlfirIntrinsics.cpp
+++ b/flang/lib/Lower/HlfirIntrinsics.cpp
@@ -17,6 +17,7 @@
#include "flang/Optimizer/Builder/HLFIRTools.h"
#include "flang/Optimizer/Builder/IntrinsicCall.h"
#include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Optimizer/Builder/Runtime/Inquiry.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIRType.h"
#include "flang/Optimizer/HLFIR/HLFIRDialect.h"
@@ -209,6 +210,45 @@ class HlfirReshapeLowering : public HlfirTransformationalIntrinsic {
mlir::Type stmtResultType) override;
};
+class HlfirPackAsReshapeLowering : public HlfirTransformationalIntrinsic {
+public:
+ using HlfirTransformationalIntrinsic::HlfirTransformationalIntrinsic;
+
+protected:
+ mlir::Value
+ lowerImpl(const Fortran::lower::PreparedActualArguments &loweredActuals,
+ const fir::IntrinsicArgumentLoweringRules *argLowering,
+ mlir::Type stmtResultType) override {
+ auto operands = getOperandVector(loweredActuals, argLowering);
+ assert(operands.size() >= 2);
+ mlir::Value array = operands[0];
+ mlir::Type resultType = computeResultType(array, stmtResultType);
+ mlir::Value sizeArray = array;
+ if (!fir::isa_box_type(array.getType())) {
+ hlfir::Entity arrayEntity = loweredActuals[0]->getActual(loc, builder);
+ auto [exv, cleanup] =
+ hlfir::translateToExtendedValue(loc, builder, arrayEntity);
+ addCleanup(cleanup);
+ sizeArray = builder.createBox(loc, exv);
+ }
+ mlir::Value totalSize = fir::runtime::genSize(builder, loc, sizeArray);
+ mlir::Type indexType = builder.getIndexType();
+ mlir::Type extentType = builder.getDefaultIntegerType();
+ mlir::Type shapeSeqType = fir::SequenceType::get({1}, extentType);
+ mlir::Value shapeStorage =
+ builder.createTemporary(loc, shapeSeqType, ".pack.shape");
+ totalSize = builder.createConvert(loc, extentType, totalSize);
+ mlir::Type shapeAddrType = builder.getRefType(extentType);
+ mlir::Value zero = builder.createIntegerConstant(loc, indexType, 0);
+ mlir::Value shapeAddr = fir::CoordinateOp::create(
+ builder, loc, shapeAddrType, shapeStorage, zero);
+ fir::StoreOp::create(builder, loc, totalSize, shapeAddr);
+ return createOp<hlfir::ReshapeOp>(resultType, array, shapeStorage,
+ /*pad=*/mlir::Value{},
+ /*order=*/mlir::Value{});
+ }
+};
+
class HlfirIndexLowering : public HlfirTransformationalIntrinsic {
public:
using HlfirTransformationalIntrinsic::HlfirTransformationalIntrinsic;
@@ -671,3 +711,17 @@ std::optional<hlfir::EntityWithAttributes> Fortran::lower::lowerHlfirIntrinsic(
}
return std::nullopt;
}
+
+std::optional<hlfir::EntityWithAttributes> Fortran::lower::lowerPackAsReshape(
+ fir::FirOpBuilder &builder, mlir::Location loc,
+ const Fortran::lower::PreparedActualArguments &loweredActuals,
+ const fir::IntrinsicArgumentLoweringRules *argLowering,
+ mlir::Type stmtResultType) {
+ if (!loweredActuals[0])
+ return std::nullopt;
+ hlfir::Entity array = loweredActuals[0]->getActual(loc, builder);
+ if (!fir::isa_trivial(array.getFortranElementType()) || array.isPolymorphic())
+ return std::nullopt;
+ return HlfirPackAsReshapeLowering{builder, loc}.lower(
+ loweredActuals, argLowering, stmtResultType);
+}
diff --git a/flang/test/Lower/HLFIR/pack_scalar_true.f90 b/flang/test/Lower/HLFIR/pack_scalar_true.f90
new file mode 100644
index 0000000000000..bf5b29254acaf
--- /dev/null
+++ b/flang/test/Lower/HLFIR/pack_scalar_true.f90
@@ -0,0 +1,46 @@
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 %s -o %t.o
+
+! PACK with scalar .TRUE. mask lowers to hlfir.reshape (not _FortranAPack).
+subroutine pack_scalar_true(a, r)
+ integer :: a(:, :, :)
+ integer :: r(:)
+ r = pack(a(:, :, 1), .true.)
+end subroutine pack_scalar_true
+
+! CHECK-LABEL: func.func @_QPpack_scalar_true
+! CHECK-NOT: _FortranAPack
+! CHECK: hlfir.reshape
+
+! Static explicit-shape array (gfortran torture intrinsic_pack.f90 pattern).
+subroutine pack_static_scalar_true
+ integer, dimension(3, 3) :: a
+ integer, dimension(9) :: r
+ r = pack(a, .true.)
+end subroutine pack_static_scalar_true
+
+! CHECK-LABEL: func.func @_QPpack_static_scalar_true
+! CHECK-NOT: _FortranAPack
+! CHECK: hlfir.reshape
+
+! Scalar logical variable mask still uses runtime PACK.
+subroutine pack_scalar_var_mask(a, m, r)
+ integer :: a(:)
+ logical :: m
+ integer :: r(:)
+ r = pack(a, m)
+end subroutine pack_scalar_var_mask
+
+! CHECK-LABEL: func.func @_QPpack_scalar_var_mask
+! CHECK: fir.call @_FortranAPack
+
+! Array mask uses the runtime PACK path.
+subroutine pack_array_mask(a, m, r)
+ integer :: a(:)
+ logical :: m(:)
+ integer :: r(:)
+ r = pack(a, m)
+end subroutine pack_array_mask
+
+! CHECK-LABEL: func.func @_QPpack_array_mask
+! CHECK: fir.call @_FortranAPack
>From 2662f5fb1fcdf902be0f341c1abbfdd80128b835 Mon Sep 17 00:00:00 2001
From: ejose <ejose at amd.com>
Date: Fri, 7 Aug 2026 11:25:42 +0000
Subject: [PATCH 2/2] Route all PACK through hlfir.pack with runtime fallback;
rewrite pack(array, .true.) to reshape in SimplifyHLFIRIntrinsics so the fast
path can apply after constprop. Build SHAPE from extent product as default
INTEGER. Added tests for the .true. case of PACK.
---
flang/include/flang/Lower/HlfirIntrinsics.h | 6 --
.../include/flang/Optimizer/HLFIR/HLFIROps.td | 21 +++++
flang/lib/Lower/ConvertCall.cpp | 33 --------
flang/lib/Lower/HlfirIntrinsics.cpp | 61 ++++-----------
flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp | 28 +++++++
.../HLFIR/Transforms/LowerHLFIRIntrinsics.cpp | 36 ++++++++-
.../Transforms/SimplifyHLFIRIntrinsics.cpp | 76 ++++++++++++++++---
.../HLFIR/simplify-hlfir-intrinsics-pack.fir | 30 ++++++++
flang/test/Lower/HLFIR/pack_scalar_true.f90 | 22 +++---
flang/test/Lower/Intrinsics/pack.f90 | 21 +----
10 files changed, 210 insertions(+), 124 deletions(-)
create mode 100644 flang/test/HLFIR/simplify-hlfir-intrinsics-pack.fir
diff --git a/flang/include/flang/Lower/HlfirIntrinsics.h b/flang/include/flang/Lower/HlfirIntrinsics.h
index 98e088afc4051..930bbeb6fb452 100644
--- a/flang/include/flang/Lower/HlfirIntrinsics.h
+++ b/flang/include/flang/Lower/HlfirIntrinsics.h
@@ -160,11 +160,5 @@ std::optional<hlfir::EntityWithAttributes> lowerHlfirIntrinsic(
const fir::IntrinsicArgumentLoweringRules *argLowering,
mlir::Type stmtResultType);
-std::optional<hlfir::EntityWithAttributes>
-lowerPackAsReshape(fir::FirOpBuilder &builder, mlir::Location loc,
- const PreparedActualArguments &loweredActuals,
- const fir::IntrinsicArgumentLoweringRules *argLowering,
- mlir::Type stmtResultType);
-
} // namespace Fortran::lower
#endif // FORTRAN_LOWER_HLFIRINTRINSICS_H
diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIROps.td b/flang/include/flang/Optimizer/HLFIR/HLFIROps.td
index f05554079816c..bc65a8f4a7998 100644
--- a/flang/include/flang/Optimizer/HLFIR/HLFIROps.td
+++ b/flang/include/flang/Optimizer/HLFIR/HLFIROps.td
@@ -831,6 +831,27 @@ def hlfir_EOShiftOp
let hasVerifier = 1;
}
+def hlfir_PackOp
+ : hlfir_Op<
+ "pack", [DeclareOpInterfaceMethods<MemoryEffectsOpInterface>]> {
+ let summary = "PACK transformational intrinsic";
+ let description = [{
+ Selects elements from an array according to a mask.
+ }];
+
+ let arguments = (ins AnyFortranArrayObject:$array,
+ AnyFortranLogicalOrI1ArrayObject:$mask,
+ Optional<AnyFortranArrayObject>:$vector);
+
+ let results = (outs hlfir_ExprType);
+
+ let assemblyFormat = [{
+ $array $mask (`vector` $vector^)? attr-dict `:` functional-type(operands, results)
+ }];
+
+ let hasVerifier = 1;
+}
+
def hlfir_ReshapeOp
: hlfir_Op<
"reshape", [AttrSizedOperandSegments,
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 2466844e81c9b..de50660479f81 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -2370,31 +2370,6 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals,
return resultEntity;
}
-/// Lower calls to intrinsic procedures with actual arguments that have been
-/// pre-lowered but have not yet been prepared according to the interface.
-static bool
-isPackWithScalarTrueMask(const Fortran::evaluate::ProcedureRef &procRef,
- Fortran::lower::AbstractConverter &converter) {
- if (procRef.arguments().size() < 2 || !procRef.arguments()[1])
- return false;
- if (procRef.arguments().size() >= 3 && procRef.arguments()[2])
- return false;
- const auto *maskExpr = procRef.UnwrapArgExpr(1);
- if (!maskExpr)
- return false;
- const auto *logExpr = Fortran::evaluate::UnwrapExpr<
- Fortran::evaluate::Expr<Fortran::evaluate::SomeLogical>>(*maskExpr);
- if (!logExpr || logExpr->Rank() != 0)
- return false;
- auto &ctx = converter.getFoldingContext();
- auto asDefault = Fortran::evaluate::Fold(
- ctx, Fortran::evaluate::ConvertToType<Fortran::evaluate::LogicalResult>(
- Fortran::evaluate::Fold(
- ctx, Fortran::evaluate::Expr<Fortran::evaluate::SomeLogical>(
- *logExpr))));
- return Fortran::evaluate::ToLogical(asDefault).value_or(false);
-}
-
static std::optional<hlfir::EntityWithAttributes> genHLFIRIntrinsicRefCore(
Fortran::lower::PreparedActualArguments &loweredActuals,
const Fortran::evaluate::SpecificIntrinsic *intrinsic,
@@ -2421,14 +2396,6 @@ static std::optional<hlfir::EntityWithAttributes> genHLFIRIntrinsicRefCore(
? hlfir::getFortranElementType(*callContext.resultType)
: *callContext.resultType;
- if (intrinsicName == "pack" &&
- isPackWithScalarTrueMask(callContext.procRef, callContext.converter)) {
- if (std::optional<hlfir::EntityWithAttributes> res =
- Fortran::lower::lowerPackAsReshape(builder, loc, loweredActuals,
- argLowering, resultType))
- return res;
- }
-
std::optional<hlfir::EntityWithAttributes> res =
Fortran::lower::lowerHlfirIntrinsic(builder, loc, intrinsicName,
loweredActuals, argLowering,
diff --git a/flang/lib/Lower/HlfirIntrinsics.cpp b/flang/lib/Lower/HlfirIntrinsics.cpp
index c1dbc7f24747a..f839c869d236b 100644
--- a/flang/lib/Lower/HlfirIntrinsics.cpp
+++ b/flang/lib/Lower/HlfirIntrinsics.cpp
@@ -17,7 +17,6 @@
#include "flang/Optimizer/Builder/HLFIRTools.h"
#include "flang/Optimizer/Builder/IntrinsicCall.h"
#include "flang/Optimizer/Builder/MutableBox.h"
-#include "flang/Optimizer/Builder/Runtime/Inquiry.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIRType.h"
#include "flang/Optimizer/HLFIR/HLFIRDialect.h"
@@ -210,7 +209,7 @@ class HlfirReshapeLowering : public HlfirTransformationalIntrinsic {
mlir::Type stmtResultType) override;
};
-class HlfirPackAsReshapeLowering : public HlfirTransformationalIntrinsic {
+class HlfirPackLowering : public HlfirTransformationalIntrinsic {
public:
using HlfirTransformationalIntrinsic::HlfirTransformationalIntrinsic;
@@ -218,35 +217,7 @@ class HlfirPackAsReshapeLowering : public HlfirTransformationalIntrinsic {
mlir::Value
lowerImpl(const Fortran::lower::PreparedActualArguments &loweredActuals,
const fir::IntrinsicArgumentLoweringRules *argLowering,
- mlir::Type stmtResultType) override {
- auto operands = getOperandVector(loweredActuals, argLowering);
- assert(operands.size() >= 2);
- mlir::Value array = operands[0];
- mlir::Type resultType = computeResultType(array, stmtResultType);
- mlir::Value sizeArray = array;
- if (!fir::isa_box_type(array.getType())) {
- hlfir::Entity arrayEntity = loweredActuals[0]->getActual(loc, builder);
- auto [exv, cleanup] =
- hlfir::translateToExtendedValue(loc, builder, arrayEntity);
- addCleanup(cleanup);
- sizeArray = builder.createBox(loc, exv);
- }
- mlir::Value totalSize = fir::runtime::genSize(builder, loc, sizeArray);
- mlir::Type indexType = builder.getIndexType();
- mlir::Type extentType = builder.getDefaultIntegerType();
- mlir::Type shapeSeqType = fir::SequenceType::get({1}, extentType);
- mlir::Value shapeStorage =
- builder.createTemporary(loc, shapeSeqType, ".pack.shape");
- totalSize = builder.createConvert(loc, extentType, totalSize);
- mlir::Type shapeAddrType = builder.getRefType(extentType);
- mlir::Value zero = builder.createIntegerConstant(loc, indexType, 0);
- mlir::Value shapeAddr = fir::CoordinateOp::create(
- builder, loc, shapeAddrType, shapeStorage, zero);
- fir::StoreOp::create(builder, loc, totalSize, shapeAddr);
- return createOp<hlfir::ReshapeOp>(resultType, array, shapeStorage,
- /*pad=*/mlir::Value{},
- /*order=*/mlir::Value{});
- }
+ mlir::Type stmtResultType) override;
};
class HlfirIndexLowering : public HlfirTransformationalIntrinsic {
@@ -606,6 +577,17 @@ mlir::Value HlfirReshapeLowering::lowerImpl(
operands[2], operands[3]);
}
+mlir::Value HlfirPackLowering::lowerImpl(
+ const Fortran::lower::PreparedActualArguments &loweredActuals,
+ const fir::IntrinsicArgumentLoweringRules *argLowering,
+ mlir::Type stmtResultType) {
+ auto operands = getOperandVector(loweredActuals, argLowering);
+ assert(operands.size() >= 2);
+ mlir::Type resultType = computeResultType(operands[0], stmtResultType);
+ mlir::Value vector = operands.size() >= 3 ? operands[2] : mlir::Value{};
+ return createOp<hlfir::PackOp>(resultType, operands[0], operands[1], vector);
+}
+
mlir::Value HlfirIndexLowering::lowerImpl(
const Fortran::lower::PreparedActualArguments &loweredActuals,
const fir::IntrinsicArgumentLoweringRules *argLowering,
@@ -689,6 +671,9 @@ std::optional<hlfir::EntityWithAttributes> Fortran::lower::lowerHlfirIntrinsic(
if (name == "reshape")
return HlfirReshapeLowering{builder, loc}.lower(loweredActuals, argLowering,
stmtResultType);
+ if (name == "pack")
+ return HlfirPackLowering{builder, loc}.lower(loweredActuals, argLowering,
+ stmtResultType);
if (name == "index")
return HlfirIndexLowering{builder, loc}.lower(loweredActuals, argLowering,
stmtResultType);
@@ -711,17 +696,3 @@ std::optional<hlfir::EntityWithAttributes> Fortran::lower::lowerHlfirIntrinsic(
}
return std::nullopt;
}
-
-std::optional<hlfir::EntityWithAttributes> Fortran::lower::lowerPackAsReshape(
- fir::FirOpBuilder &builder, mlir::Location loc,
- const Fortran::lower::PreparedActualArguments &loweredActuals,
- const fir::IntrinsicArgumentLoweringRules *argLowering,
- mlir::Type stmtResultType) {
- if (!loweredActuals[0])
- return std::nullopt;
- hlfir::Entity array = loweredActuals[0]->getActual(loc, builder);
- if (!fir::isa_trivial(array.getFortranElementType()) || array.isPolymorphic())
- return std::nullopt;
- return HlfirPackAsReshapeLowering{builder, loc}.lower(
- loweredActuals, argLowering, stmtResultType);
-}
diff --git a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp
index 53c9b6f500d05..f13edcf8aadc9 100644
--- a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp
+++ b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp
@@ -1682,6 +1682,34 @@ void hlfir::EOShiftOp::getEffects(
getIntrinsicEffects(getOperation(), effects);
}
+//===----------------------------------------------------------------------===//
+// PackOp
+//===----------------------------------------------------------------------===//
+
+llvm::LogicalResult hlfir::PackOp::verify() {
+ hlfir::ExprType resultType = mlir::cast<hlfir::ExprType>(getType());
+ mlir::Value array = getArray();
+ if (auto match = areMatchingTypes(
+ *this, hlfir::getFortranElementType(resultType),
+ hlfir::getFortranElementType(array.getType()),
+ /*allowCharacterLenMismatch=*/!useStrictIntrinsicVerifier);
+ match.failed())
+ return emitOpError("ARRAY and the result must have the same element type");
+ if (hlfir::isPolymorphicType(resultType) !=
+ hlfir::isPolymorphicType(array.getType()))
+ return emitOpError("ARRAY must be polymorphic iff result is polymorphic");
+ if (!hlfir::isMaskArgument(getMask().getType()))
+ return emitOpError("MASK must be of logical type");
+ return mlir::success();
+}
+
+void hlfir::PackOp::getEffects(
+ llvm::SmallVectorImpl<
+ mlir::SideEffects::EffectInstance<mlir::MemoryEffects::Effect>>
+ &effects) {
+ getIntrinsicEffects(getOperation(), effects);
+}
+
//===----------------------------------------------------------------------===//
// ReshapeOp
//===----------------------------------------------------------------------===//
diff --git a/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIRIntrinsics.cpp b/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIRIntrinsics.cpp
index 6ef52f4b4033c..f83db72c77672 100644
--- a/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIRIntrinsics.cpp
+++ b/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIRIntrinsics.cpp
@@ -512,6 +512,39 @@ class ArrayShiftOpConversion : public HlfirIntrinsicConversion<T> {
}
};
+class PackOpConversion : public HlfirIntrinsicConversion<hlfir::PackOp> {
+ using HlfirIntrinsicConversion<hlfir::PackOp>::HlfirIntrinsicConversion;
+
+ llvm::LogicalResult
+ matchAndRewrite(hlfir::PackOp pack,
+ mlir::PatternRewriter &rewriter) const override {
+ fir::FirOpBuilder builder{rewriter, pack.getOperation()};
+ const mlir::Location &loc = pack->getLoc();
+
+ llvm::SmallVector<IntrinsicArgument, 3> inArgs;
+ mlir::Value array = pack.getArray();
+ inArgs.push_back({array, array.getType()});
+ mlir::Value mask = pack.getMask();
+ inArgs.push_back({mask, mask.getType()});
+ mlir::Type noneType = builder.getNoneType();
+ mlir::Value vector = pack.getVector();
+ inArgs.push_back({vector, vector ? vector.getType() : noneType});
+
+ auto *argLowering = fir::getIntrinsicArgumentLowering("pack");
+ llvm::SmallVector<fir::ExtendedValue, 3> args =
+ lowerArguments(pack, inArgs, rewriter, argLowering);
+
+ mlir::Type scalarResultType =
+ hlfir::getFortranElementType(pack.getType());
+
+ auto [resultExv, mustBeFreed] =
+ fir::genIntrinsicCall(builder, loc, "pack", scalarResultType, args);
+
+ processReturnValue(pack, resultExv, mustBeFreed, builder, rewriter);
+ return mlir::success();
+ }
+};
+
class ReshapeOpConversion : public HlfirIntrinsicConversion<hlfir::ReshapeOp> {
using HlfirIntrinsicConversion<hlfir::ReshapeOp>::HlfirIntrinsicConversion;
@@ -661,7 +694,8 @@ class LowerHLFIRIntrinsics
TransposeOpConversion, CountOpConversion, DotProductOpConversion,
MaxvalOpConversion, MinvalOpConversion, MinlocOpConversion,
MaxlocOpConversion, ArrayShiftOpConversion<hlfir::CShiftOp>,
- ArrayShiftOpConversion<hlfir::EOShiftOp>, ReshapeOpConversion,
+ ArrayShiftOpConversion<hlfir::EOShiftOp>, PackOpConversion,
+ ReshapeOpConversion,
CmpCharOpConversion, CharTrimOpConversion, IndexOpConversion>(context);
// While conceptually this pass is performing dialect conversion, we use
diff --git a/flang/lib/Optimizer/HLFIR/Transforms/SimplifyHLFIRIntrinsics.cpp b/flang/lib/Optimizer/HLFIR/Transforms/SimplifyHLFIRIntrinsics.cpp
index 716737bb80ff4..0aac7ca7f4b2c 100644
--- a/flang/lib/Optimizer/HLFIR/Transforms/SimplifyHLFIRIntrinsics.cpp
+++ b/flang/lib/Optimizer/HLFIR/Transforms/SimplifyHLFIRIntrinsics.cpp
@@ -15,6 +15,7 @@
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/HLFIRTools.h"
#include "flang/Optimizer/Builder/IntrinsicCall.h"
+#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Optimizer/HLFIR/HLFIRDialect.h"
#include "flang/Optimizer/HLFIR/HLFIROps.h"
#include "flang/Optimizer/HLFIR/Passes.h"
@@ -3068,6 +3069,68 @@ class DotProductConversion
}
};
+static mlir::Value computeArraySize(mlir::Location loc,
+ fir::FirOpBuilder &builder,
+ mlir::ValueRange extents) {
+ mlir::Type indexType = builder.getIndexType();
+ mlir::Value size = builder.createIntegerConstant(loc, indexType, 1);
+ for (mlir::Value extent : extents)
+ size = mlir::arith::MulIOp::create(
+ builder, loc, size, builder.createConvert(loc, indexType, extent));
+ return size;
+}
+
+static std::optional<bool> getLogicalConstant(mlir::Value value) {
+ if (auto convertOp = value.getDefiningOp<fir::ConvertOp>())
+ value = convertOp.getValue();
+ if (auto cst = fir::getIntIfConstant(value))
+ return *cst != 0;
+ return std::nullopt;
+}
+
+class PackAsReshapeConversion
+ : public mlir::OpRewritePattern<hlfir::PackOp> {
+public:
+ using mlir::OpRewritePattern<hlfir::PackOp>::OpRewritePattern;
+
+ llvm::LogicalResult
+ matchAndRewrite(hlfir::PackOp pack,
+ mlir::PatternRewriter &rewriter) const override {
+ if (pack.getVector())
+ return rewriter.notifyMatchFailure(pack, "PACK with VECTOR");
+ hlfir::Entity mask{pack.getMask()};
+ if (mask.getRank() != 0)
+ return rewriter.notifyMatchFailure(pack, "non-scalar mask");
+ if (!getLogicalConstant(pack.getMask()).value_or(false))
+ return rewriter.notifyMatchFailure(pack, "mask is not .TRUE.");
+ hlfir::Entity array{pack.getArray()};
+ if (!fir::isa_trivial(array.getFortranElementType()) ||
+ array.isPolymorphic())
+ return rewriter.notifyMatchFailure(pack, "unsupported array type");
+
+ mlir::Location loc = pack.getLoc();
+ fir::FirOpBuilder builder{rewriter, pack.getOperation()};
+ llvm::SmallVector<mlir::Value, Fortran::common::maxRank> extents =
+ hlfir::genExtentsVector(loc, builder, array);
+ mlir::Value totalSize = computeArraySize(loc, builder, extents);
+ mlir::Type extentType = builder.getDefaultIntegerType();
+ mlir::Type shapeSeqType = fir::SequenceType::get({1}, extentType);
+ mlir::Value shapeStorage =
+ builder.createTemporary(loc, shapeSeqType, ".pack.shape");
+ totalSize = builder.createConvert(loc, extentType, totalSize);
+ mlir::Type indexType = builder.getIndexType();
+ mlir::Value zero = builder.createIntegerConstant(loc, indexType, 0);
+ mlir::Value shapeAddr = fir::CoordinateOp::create(
+ builder, loc, builder.getRefType(extentType), shapeStorage, zero);
+ fir::StoreOp::create(builder, loc, totalSize, shapeAddr);
+ auto reshape = hlfir::ReshapeOp::create(
+ builder, loc, pack.getType(), array, shapeStorage,
+ /*pad=*/mlir::Value{}, /*order=*/mlir::Value{});
+ rewriter.replaceOp(pack, reshape);
+ return mlir::success();
+ }
+};
+
class ReshapeAsElementalConversion
: public mlir::OpRewritePattern<hlfir::ReshapeOp> {
public:
@@ -3268,18 +3331,6 @@ class ReshapeAsElementalConversion
}
return indices;
}
-
- /// Return size of an array given its extents.
- static mlir::Value computeArraySize(mlir::Location loc,
- fir::FirOpBuilder &builder,
- mlir::ValueRange extents) {
- mlir::Type indexType = builder.getIndexType();
- mlir::Value size = builder.createIntegerConstant(loc, indexType, 1);
- for (auto extent : extents)
- size = mlir::arith::MulIOp::create(
- builder, loc, size, builder.createConvert(loc, indexType, extent));
- return size;
- }
};
class SimplifyHLFIRIntrinsics
@@ -3333,6 +3384,7 @@ class SimplifyHLFIRIntrinsics
patterns.insert<MatmulConversion<hlfir::MatmulOp>>(context);
patterns.insert<DotProductConversion>(context);
+ patterns.insert<PackAsReshapeConversion>(context);
patterns.insert<ReshapeAsElementalConversion>(context);
if (mlir::failed(mlir::applyPatternsGreedily(
diff --git a/flang/test/HLFIR/simplify-hlfir-intrinsics-pack.fir b/flang/test/HLFIR/simplify-hlfir-intrinsics-pack.fir
new file mode 100644
index 0000000000000..80fcc18c44a7e
--- /dev/null
+++ b/flang/test/HLFIR/simplify-hlfir-intrinsics-pack.fir
@@ -0,0 +1,30 @@
+// RUN: fir-opt --simplify-hlfir-intrinsics %s | FileCheck %s
+
+func.func @pack_scalar_true_mask(%arg0: !fir.box<!fir.array<?xi32>>) -> !hlfir.expr<?xi32> {
+ %true = arith.constant 1 : i1
+ %mask = fir.convert %true : (i1) -> !fir.logical<4>
+ %res = hlfir.pack %arg0 %mask : (!fir.box<!fir.array<?xi32>>, !fir.logical<4>) -> !hlfir.expr<?xi32>
+ return %res : !hlfir.expr<?xi32>
+}
+// CHECK-LABEL: func.func @pack_scalar_true_mask
+// CHECK-NOT: hlfir.pack
+// CHECK: hlfir.elemental
+
+func.func @pack_var_mask(%arg0: !fir.box<!fir.array<?xi32>>, %arg1: !fir.ref<!fir.logical<4>>) -> !hlfir.expr<?xi32> {
+ %mask = fir.load %arg1 : !fir.ref<!fir.logical<4>>
+ %res = hlfir.pack %arg0 %mask : (!fir.box<!fir.array<?xi32>>, !fir.logical<4>) -> !hlfir.expr<?xi32>
+ return %res : !hlfir.expr<?xi32>
+}
+// CHECK-LABEL: func.func @pack_var_mask
+// CHECK: hlfir.pack
+// CHECK-NOT: hlfir.reshape
+
+func.func @pack_with_vector(%arg0: !fir.box<!fir.array<?xi32>>, %arg1: !fir.box<!fir.array<?xi32>>) -> !hlfir.expr<?xi32> {
+ %true = arith.constant 1 : i1
+ %mask = fir.convert %true : (i1) -> !fir.logical<4>
+ %res = hlfir.pack %arg0 %mask vector %arg1 : (!fir.box<!fir.array<?xi32>>, !fir.logical<4>, !fir.box<!fir.array<?xi32>>) -> !hlfir.expr<?xi32>
+ return %res : !hlfir.expr<?xi32>
+}
+// CHECK-LABEL: func.func @pack_with_vector
+// CHECK: hlfir.pack
+// CHECK-NOT: hlfir.reshape
diff --git a/flang/test/Lower/HLFIR/pack_scalar_true.f90 b/flang/test/Lower/HLFIR/pack_scalar_true.f90
index bf5b29254acaf..01eef03105a04 100644
--- a/flang/test/Lower/HLFIR/pack_scalar_true.f90
+++ b/flang/test/Lower/HLFIR/pack_scalar_true.f90
@@ -1,7 +1,7 @@
! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -O2 -S %s -o - | FileCheck %s --check-prefix=OPT
! RUN: %flang_fc1 %s -o %t.o
-! PACK with scalar .TRUE. mask lowers to hlfir.reshape (not _FortranAPack).
subroutine pack_scalar_true(a, r)
integer :: a(:, :, :)
integer :: r(:)
@@ -9,10 +9,11 @@ subroutine pack_scalar_true(a, r)
end subroutine pack_scalar_true
! CHECK-LABEL: func.func @_QPpack_scalar_true
-! CHECK-NOT: _FortranAPack
-! CHECK: hlfir.reshape
+! CHECK: hlfir.pack
+! CHECK-NOT: hlfir.reshape
+! OPT-LABEL: pack_scalar_true_
+! OPT-NOT: _FortranAPack
-! Static explicit-shape array (gfortran torture intrinsic_pack.f90 pattern).
subroutine pack_static_scalar_true
integer, dimension(3, 3) :: a
integer, dimension(9) :: r
@@ -20,10 +21,10 @@ subroutine pack_static_scalar_true
end subroutine pack_static_scalar_true
! CHECK-LABEL: func.func @_QPpack_static_scalar_true
-! CHECK-NOT: _FortranAPack
-! CHECK: hlfir.reshape
+! CHECK: hlfir.pack
+! CHECK-NOT: hlfir.reshape
+! OPT-LABEL: pack_static_scalar_true_
-! Scalar logical variable mask still uses runtime PACK.
subroutine pack_scalar_var_mask(a, m, r)
integer :: a(:)
logical :: m
@@ -32,9 +33,9 @@ subroutine pack_scalar_var_mask(a, m, r)
end subroutine pack_scalar_var_mask
! CHECK-LABEL: func.func @_QPpack_scalar_var_mask
-! CHECK: fir.call @_FortranAPack
+! CHECK: hlfir.pack
+! CHECK-NOT: hlfir.reshape
-! Array mask uses the runtime PACK path.
subroutine pack_array_mask(a, m, r)
integer :: a(:)
logical :: m(:)
@@ -43,4 +44,5 @@ subroutine pack_array_mask(a, m, r)
end subroutine pack_array_mask
! CHECK-LABEL: func.func @_QPpack_array_mask
-! CHECK: fir.call @_FortranAPack
+! CHECK: hlfir.pack
+! CHECK-NOT: hlfir.reshape
diff --git a/flang/test/Lower/Intrinsics/pack.f90 b/flang/test/Lower/Intrinsics/pack.f90
index 777b5e65ebbd9..65f8b74153bb6 100644
--- a/flang/test/Lower/Intrinsics/pack.f90
+++ b/flang/test/Lower/Intrinsics/pack.f90
@@ -10,16 +10,12 @@ subroutine pack_test(a,m,v,r)
logical :: m(:)
integer :: v(:)
integer :: r(:)
-! CHECK-DAG: %[[a0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
! CHECK-DAG: %[[A:.*]]:2 = hlfir.declare %[[arg0]]
! CHECK-DAG: %[[M:.*]]:2 = hlfir.declare %[[arg1]]
! CHECK-DAG: %[[V:.*]]:2 = hlfir.declare %[[arg2]]
r = pack(a,m,v)
-! CHECK: %[[a5:.*]] = fir.convert %[[a0]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
-! CHECK: %[[a6:.*]] = fir.convert %[[A]]#1 : (!fir.box<!fir.array<?xi32>>) -> !fir.box<none>
-! CHECK: %[[a7:.*]] = fir.convert %[[M]]#1 : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.box<none>
-! CHECK: %[[a8:.*]] = fir.convert %[[V]]#1 : (!fir.box<!fir.array<?xi32>>) -> !fir.box<none>
-! CHECK: fir.call @_FortranAPack(%[[a5]], %[[a6]], %[[a7]], %[[a8]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> ()
+! CHECK: hlfir.pack
+! CHECK-NOT: fir.call @_FortranAPack
end subroutine
! CHECK-LABEL: func.func @_QPtest_pack_optional(
@@ -29,15 +25,6 @@ subroutine test_pack_optional(vector, array, mask)
integer :: array(:, :)
logical :: mask(:, :)
print *, pack(array, mask, vector)
- ! CHECK: %[[VDECL:.*]]:2 = hlfir.declare %[[VAL_0]]
- ! CHECK: %[[VAL_9:.*]] = fir.load %[[VDECL]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
- ! CHECK: %[[VAL_10:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box<!fir.ptr<!fir.array<?xi32>>>) -> !fir.ptr<!fir.array<?xi32>>
- ! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.ptr<!fir.array<?xi32>>) -> i64
- ! CHECK: %[[VAL_12:.*]] = arith.constant 0 : i64
- ! CHECK: %[[VAL_13:.*]] = arith.cmpi ne, %[[VAL_11]], %[[VAL_12]] : i64
- ! CHECK: %[[VAL_14:.*]] = fir.load %[[VDECL]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
- ! CHECK: %[[VAL_15:.*]] = fir.absent !fir.box<!fir.ptr<!fir.array<?xi32>>>
- ! CHECK: %[[VAL_16:.*]] = arith.select %[[VAL_13]], %[[VAL_14]], %[[VAL_15]] : !fir.box<!fir.ptr<!fir.array<?xi32>>>
- ! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_16]] : (!fir.box<!fir.ptr<!fir.array<?xi32>>>) -> !fir.box<none>
- ! CHECK: fir.call @_FortranAPack(%{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_26]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> ()
+ ! CHECK: hlfir.pack
+ ! CHECK-NOT: fir.call @_FortranAPack
end subroutine
More information about the flang-commits
mailing list