[Flang] Wrap array constructors within a hlfir.exactly_once op

flang/lib/Lower/ConvertArrayConstructor.cpp

@@ -20,6 +20,18 @@
 #include "flang/Optimizer/Builder/Todo.h"
 #include "flang/Optimizer/HLFIR/HLFIROps.h"
 
+namespace {
+/// Check if we are inside a WHERE construct's masked expression region.
+/// Array constructors inside WHERE statements must be evaluated exactly once
+/// without mask control, similar to non-elemental function calls.
+
+static bool isInWhereMaskedExpression(fir::FirOpBuilder &builder) {
+  mlir::Operation *op = builder.getRegion().getParentOp();
+  return op && op->getParentOfType<hlfir::WhereOp>();
+}
+
+} // namespace
+
 // Array constructors are lowered with three different strategies.
 // All strategies are not possible with all array constructors.
 //
@@ -780,6 +792,41 @@ hlfir::EntityWithAttributes Fortran::lower::ArrayConstructorBuilder<T>::gen(
     const Fortran::evaluate::ArrayConstructor<T> &arrayCtorExpr,
     Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+
+  // Array constructors inside a where-assignment-stmt must be executed
+  // exactly once without mask control, per Fortran 2023 section 10.2.3.2.
+  // Lower them in a special region so that this can be enforced when
+  // scheduling forall/where expression evaluations.
+  if (isInWhereMaskedExpression(builder) &&
+      !builder.getRegion().getParentOfType<hlfir::ExactlyOnceOp>()) {
+    Fortran::lower::StatementContext localStmtCtx;
+    mlir::Type bogusType = builder.getIndexType();
+    auto exactlyOnce = hlfir::ExactlyOnceOp::create(builder, loc, bogusType);
+    mlir::Block *block = builder.createBlock(&exactlyOnce.getBody());
+    builder.setInsertionPointToStart(block);
+
+    // Recursively generate the array constructor inside the exactly_once region
+    hlfir::EntityWithAttributes res = ArrayConstructorBuilder<T>::gen(
+        loc, converter, arrayCtorExpr, symMap, localStmtCtx);
+
+    auto yield = hlfir::YieldOp::create(builder, loc, res);
+    Fortran::lower::genCleanUpInRegionIfAny(loc, builder, yield.getCleanup(),
+                                            localStmtCtx);
+    builder.setInsertionPointAfter(exactlyOnce);
+    exactlyOnce->getResult(0).setType(res.getType());
+
+    if (hlfir::isFortranValue(exactlyOnce.getResult()))
+      return hlfir::EntityWithAttributes{exactlyOnce.getResult()};
+
+    // Create hlfir.declare for the result to satisfy
+    // hlfir::EntityWithAttributes requirements.
+    auto [exv, cleanup] = hlfir::translateToExtendedValue(
+        loc, builder, hlfir::Entity{exactlyOnce});
+    assert(!cleanup && "result is a variable");
+    return hlfir::genDeclare(loc, builder, exv, ".arrayctor.result",
+                             fir::FortranVariableFlagsAttr{});
+  }
+
   // Select the lowering strategy given the array constructor.
   auto arrayBuilder = selectArrayCtorLoweringStrategy(
       loc, converter, arrayCtorExpr, symMap, stmtCtx);

flang/test/Lower/array-constructor-exactly-once.f90

@@ -0,0 +1,20 @@
+! RUN: flang -fc1 -emit-hlfir %s -o - | FileCheck %s
+
+program main
+  call test06()
+  print *,'pass'
+end program main
+
+subroutine test06()
+  type ty1
+     integer ,allocatable :: a(:,:,:)
+  end type ty1
+  type(ty1) :: str(1)
+  integer ,allocatable :: b(:,:,:)
+  allocate(str(1)%a(1,1,1),b(1,1,1))
+  b=1
+  write(6,*) "b                                 = ", b
+  write(6,*) "reshape((/(b,jj=1,1)/),(/1,1,1/)) = ", reshape((/(b,jj=1,1)/),(/1,1,1/))
+  where ((/.true./)) str=(/(ty1(reshape((/(b,jj=1,1)/),(/1,1,1/))),ii=1,1)/)
+  ! CHECK: hlfir.exactly_once : !hlfir.expr<1x!fir.type<_QFtest06Tty1{a:!fir.box<!fir.heap<!fir.array<?x?x?xi32>>>}>>
+end subroutine test06