[flang][hlfir] Evaluate actual args before impure elemental calls.

[vzakhari]

Summary

Actual argument expressions must be evaluated before the invocation
of the sequence of per-element calls of an impure elemental subprogram.
Otherwise, the side effects of the calls may affect the input for
the consequent elements.
The proposed changes are described by Jean in D154174.

[tblah]

Thanks for this, LGTM

flang/test/Lower/HLFIR/elemental-user-procedure-ref.f90

172

Nit: if I understand correctly, the hlfir.associate should be operating on VAL_5 (the elemental expr), not on a new value.

[vzakhari]

flang/test/Lower/HLFIR/elemental-user-procedure-ref.f90

172

You are right. Thanks for the catch! I will fix it before merging.

flang/lib/Lower/ConvertCall.cpp

if (!shape && optionalWithShape) {
           hlfir::genShape(loc, builder, optionalWithShape->getOriginalActual());
       // TODO: There is an opportunity to add a runtime check here that
       // this array is present as required. Also, the optionality of all actual
       // could be checked and reset given the Fortran requirement.
       optionalWithShape->resetOptionalAspect();
     }
     assert(shape &&
            "elemental array calls must have at least one array arguments");
+
+    // Evaluate the actual argument array expressions before the elemental
+    // call of an impure subprogram or a subprogram with intent(out) or
+    // intent(inout) arguments. Note that the scalar arguments are handled
+    // above.
+    if (mustBeOrdered) {
+      for (unsigned i = 0; i < numArgs; ++i) {
+        auto &preparedActual = loweredActuals[i];
+        if (preparedActual) {
+          hlfir::Entity actual = preparedActual->getOriginalActual();
+          if (!actual.isVariable() && actual.isArray()) {
+            mlir::Type storageType = actual.getType();
+            hlfir::AssociateOp associate = hlfir::genAssociateExpr(
+                loc, builder, actual, storageType, "adapt.impure_arg_eval");
+            preparedActual->setOriginalActual(hlfir::Entity{associate});
+
+            fir::FirOpBuilder *bldr = &builder;
+            callContext.stmtCtx.attachCleanup(
+                [=]() { bldr->create<hlfir::EndAssociateOp>(loc, associate); });
+          }
+        }
+      }
+    }
+
     // Push a new local scope so that any temps made inside the elemental
     // iterations are cleaned up inside the iterations.
     if (!callContext.resultType) {
       // Subroutine case. Generate call inside loop nest.
       hlfir::LoopNest loopNest =
           hlfir::genLoopNest(loc, builder, shape, !mustBeOrdered);
       mlir::ValueRange oneBasedIndices = loopNest.oneBasedIndices;
       auto insPt = builder.saveInsertionPoint();

flang/test/Lower/HLFIR/elemental-user-procedure-ref.f90

 ! CHECK:           fir.do_loop %[[VAL_6:.*]] = %[[VAL_5]] to %[[VAL_2]] step %[[VAL_5]] {
 ! CHECK:             fir.do_loop %[[VAL_7:.*]] = %[[VAL_5]] to %[[VAL_1]] step %[[VAL_5]] {
 ! CHECK:               %[[VAL_8:.*]] = hlfir.designate %[[VAL_4]]#0 (%[[VAL_7]], %[[VAL_6]])  : (!fir.ref<!fir.array<10x20xf32>>, index, index) -> !fir.ref<f32>
 ! CHECK:               fir.call @_QPordered_elem(%[[VAL_8]]) fastmath<contract> : (!fir.ref<f32>) -> ()
 ! CHECK:             }
 ! CHECK:           }
 ! CHECK:           return
 ! CHECK:         }
+
+subroutine impure_elemental_arg_eval(x)
+  real :: x(10, 20)
+  interface
+    impure elemental subroutine impure_elem(a)
+      real, intent(in) :: a
+    end subroutine
+  end interface
+  call impure_elem((x))
+end subroutine
+! CHECK-LABEL:   func.func @_QPimpure_elemental_arg_eval(
+! CHECK-SAME:      %[[VAL_0:.*]]: !fir.ref<!fir.array<10x20xf32>> {fir.bindc_name = "x"}) {
+! CHECK:           %[[VAL_1:.*]] = arith.constant 10 : index
+! CHECK:           %[[VAL_2:.*]] = arith.constant 20 : index
+! CHECK:           %[[VAL_3:.*]] = fir.shape %[[VAL_1]], %[[VAL_2]] : (index, index) -> !fir.shape<2>
+! CHECK:           %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_0]](%[[VAL_3]]) {uniq_name = "_QFimpure_elemental_arg_evalEx"} : (!fir.ref<!fir.array<10x20xf32>>, !fir.shape<2>) -> (!fir.ref<!fir.array<10x20xf32>>, !fir.ref<!fir.array<10x20xf32>>)
+! CHECK:           %[[VAL_5:.*]] = hlfir.elemental %[[VAL_3]] unordered : (!fir.shape<2>) -> !hlfir.expr<10x20xf32> {
+! CHECK:           ^bb0(%[[VAL_6:.*]]: index, %[[VAL_7:.*]]: index):
+! CHECK:             %[[VAL_8:.*]] = hlfir.designate %[[VAL_4]]#0 (%[[VAL_6]], %[[VAL_7]])  : (!fir.ref<!fir.array<10x20xf32>>, index, index) -> !fir.ref<f32>
+! CHECK:             %[[VAL_9:.*]] = fir.load %[[VAL_8]] : !fir.ref<f32>
+! CHECK:             %[[VAL_10:.*]] = hlfir.no_reassoc %[[VAL_9]] : f32
+! CHECK:             hlfir.yield_element %[[VAL_10]] : f32
+! CHECK:           }
+! CHECK:           %[[VAL_11:.*]]:3 = hlfir.associate %[[VAL_5]](%[[VAL_3]]) {uniq_name = "adapt.impure_arg_eval"} : (!hlfir.expr<10x20xf32>, !fir.shape<2>) -> (!fir.ref<!fir.array<10x20xf32>>, !fir.ref<!fir.array<10x20xf32>>, i1)
+! CHECK:           %[[VAL_13:.*]] = arith.constant 1 : index
+! CHECK:           fir.do_loop %[[VAL_14:.*]] = %[[VAL_13]] to %[[VAL_2]] step %[[VAL_13]] {
+! CHECK:             fir.do_loop %[[VAL_15:.*]] = %[[VAL_13]] to %[[VAL_1]] step %[[VAL_13]] {
+! CHECK:               %[[VAL_16:.*]] = hlfir.designate %[[VAL_11]]#0 (%[[VAL_15]], %[[VAL_14]])  : (!fir.ref<!fir.array<10x20xf32>>, index, index) -> !fir.ref<f32>
+! CHECK:               fir.call @_QPimpure_elem(%[[VAL_16]]) fastmath<contract> : (!fir.ref<f32>) -> ()
+! CHECK:             }
+! CHECK:           }
+! CHECK:           hlfir.end_associate %[[VAL_11]]#1, %[[VAL_11]]#2 : !fir.ref<!fir.array<10x20xf32>>, i1
+! CHECK:           hlfir.destroy %[[VAL_5]] : !hlfir.expr<10x20xf32>
+! CHECK:           return
+! CHECK:         }