Merge pull request #1129 from schweitzpgi/ch-char1

Fix some CHARACTER related bugs.

Author: schweitzpgi

flang/include/flang/Lower/EvExprDumper.h

@@ -201,6 +201,11 @@ LLVM_DUMP_METHOD void dumpEvExpr(
     const Fortran::evaluate::Expr<
         Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 8>> &x);
 LLVM_DUMP_METHOD void dumpEvExpr(const Fortran::evaluate::ArrayRef &x);
+LLVM_DUMP_METHOD void dumpEvExpr(const Fortran::evaluate::DataRef &x);
+LLVM_DUMP_METHOD void dumpEvExpr(const Fortran::evaluate::Substring &x);
+LLVM_DUMP_METHOD void dumpEvExpr(
+    const Fortran::evaluate::Designator<
+        Fortran::evaluate::Type<Fortran::common::TypeCategory::Integer, 4>> &x);
 
 } // namespace Fortran::lower
 

flang/include/flang/Optimizer/Builder/Character.h

@@ -107,7 +107,15 @@ class CharacterExprHelper {
   /// Extract the kind of a character or array of character type.
   static fir::KindTy getCharacterOrSequenceKind(mlir::Type type);
 
-  /// Determine the base character type
+  // TODO: Do we really need all these flavors of unwrapping to get the fir.char
+  // type? Or can we merge these? It would be better to merge them and eliminate
+  // the confusion.
+
+  /// Determine the inner character type. Unwraps references, boxes, and
+  /// sequences to find the !fir.char element type.
+  static fir::CharacterType getCharType(mlir::Type type);
+
+  /// Get fir.char<kind> type with the same kind as inside str.
   static fir::CharacterType getCharacterType(mlir::Type type);
   static fir::CharacterType getCharacterType(const fir::CharBoxValue &box);
   static fir::CharacterType getCharacterType(mlir::Value str);

flang/include/flang/Optimizer/Builder/FIRBuilder.h

@@ -465,8 +465,19 @@ void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
                          const fir::ExtendedValue &lhs,
                          const fir::ExtendedValue &rhs);
 
+/// Builds and returns the type of a ragged array header used to cache mask
+/// evaluations.
 mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
 
+/// Generate the, possibly dynamic, LEN of a CHARACTER. \p arrLoad determines
+/// the base array. After applying \p path, the result must be a reference to a
+/// `!fir.char` type object. \p substring must have 0, 1, or 2 members. The
+/// first member is the starting offset. The second is the ending offset.
+mlir::Value genLenOfCharacter(fir::FirOpBuilder &builder, mlir::Location loc,
+                              fir::ArrayLoadOp arrLoad,
+                              llvm::ArrayRef<mlir::Value> path,
+                              llvm::ArrayRef<mlir::Value> substring);
+
 } // namespace fir::factory
 
 #endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H

flang/include/flang/Optimizer/Transforms/Factory.h renamed to flang/include/flang/Optimizer/Builder/Factory.h

@@ -1,4 +1,4 @@
-//===-- Optimizer/Transforms/Factory.h --------------------------*- C++ -*-===//
+//===-- Optimizer/Builder/Factory.h -----------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
@@ -12,8 +12,8 @@
 //
 //===----------------------------------------------------------------------===//
 
-#ifndef FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H
-#define FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H
+#ifndef FORTRAN_OPTIMIZER_BUILDER_FACTORY_H
+#define FORTRAN_OPTIMIZER_BUILDER_FACTORY_H
 
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Dialect/FIRType.h"
@@ -253,4 +253,4 @@ llvm::SmallVector<fir::DoLoopOp> createLoopNest(
 
 } // namespace fir::factory
 
-#endif // FORTRAN_OPTIMIZER_TRANSFORMS_FACTORY_H
+#endif // FORTRAN_OPTIMIZER_BUILDER_FACTORY_H

flang/include/flang/Optimizer/CodeGen/CGOps.td

@@ -42,6 +42,7 @@ def fircg_XEmboxOp : fircg_Op<"ext_embox", [AttrSizedOperandSegments]> {
          The default is a vector of the value 1.
        - slice: A vector of triples that describe an array slice.
        - subcomponent: A vector of indices for subobject slicing.
+       - substring: A substring operator (offset, length) for CHARACTER.
        - LEN type parameters: A vector of runtime LEN type parameters that
          describe an correspond to the elemental derived type.
 
@@ -54,14 +55,15 @@ def fircg_XEmboxOp : fircg_Op<"ext_embox", [AttrSizedOperandSegments]> {
     Variadic<AnyIntegerType>:$shift,
     Variadic<AnyIntegerType>:$slice,
     Variadic<AnyCoordinateType>:$subcomponent,
+    Variadic<AnyIntegerType>:$substr,
     Variadic<AnyIntegerType>:$lenParams
   );
   let results = (outs fir_BoxType);
 
   let assemblyFormat = [{
     $memref (`(`$shape^`)`)? (`origin` $shift^)? (`[`$slice^`]`)?
-      (`path` $subcomponent^)? (`typeparams` $lenParams^)? attr-dict
-      `:` functional-type(operands, results)
+      (`path` $subcomponent^)? (`substr` $substr^)? (`typeparams` $lenParams^)?
+      attr-dict `:` functional-type(operands, results)
   }];
 
   let extraClassDeclaration = [{
@@ -76,9 +78,10 @@ def fircg_XEmboxOp : fircg_Op<"ext_embox", [AttrSizedOperandSegments]> {
     unsigned shiftOffset() { return shapeOffset() + shape().size(); }
     unsigned sliceOffset() { return shiftOffset() + shift().size(); }
     unsigned subcomponentOffset() { return sliceOffset() + slice().size(); }
-    unsigned lenParamOffset() {
+    unsigned substrOffset() {
       return subcomponentOffset() + subcomponent().size();
     }
+    unsigned lenParamOffset() { return substrOffset() + substr().size(); }
   }];
 }
 
@@ -97,6 +100,7 @@ def fircg_XReboxOp : fircg_Op<"ext_rebox", [AttrSizedOperandSegments]> {
          The default is a vector of the value 1.
        - slice: A vector of triples that describe an array slice.
        - subcomponent: A vector of indices for subobject slicing.
+       - substring: A substring operator (offset, length) for CHARACTER.
 
     The box argument is mandatory, the other arguments are optional.
     There must not both be a shape and slice/subcomponent arguments
@@ -107,14 +111,15 @@ def fircg_XReboxOp : fircg_Op<"ext_rebox", [AttrSizedOperandSegments]> {
     Variadic<AnyIntegerType>:$shape,
     Variadic<AnyIntegerType>:$shift,
     Variadic<AnyIntegerType>:$slice,
-    Variadic<AnyCoordinateType>:$subcomponent
+    Variadic<AnyCoordinateType>:$subcomponent,
+    Variadic<AnyIntegerType>:$substr
   );
   let results = (outs fir_BoxType);
 
   let assemblyFormat = [{
     $box (`(`$shape^`)`)? (`origin` $shift^)? (`[`$slice^`]`)?
-      (`path` $subcomponent^) ? attr-dict
-      `:` functional-type(operands, results)
+      (`path` $subcomponent^)? (`substr` $substr^)? attr-dict `:`
+      functional-type(operands, results)
   }];
 
   let extraClassDeclaration = [{
@@ -127,6 +132,9 @@ def fircg_XReboxOp : fircg_Op<"ext_rebox", [AttrSizedOperandSegments]> {
     unsigned shiftOffset() { return shapeOffset() + shape().size(); }
     unsigned sliceOffset() { return shiftOffset() + shift().size(); }
     unsigned subcomponentOffset() { return sliceOffset() + slice().size(); }
+    unsigned substrOffset() {
+      return subcomponentOffset() + subcomponent().size();
+    }
   }];
 }
 

flang/include/flang/Optimizer/Dialect/FIROps.td

@@ -826,9 +826,9 @@ def fir_HasValueOp : fir_Op<"has_value", [Terminator, HasParent<"GlobalOp">]> {
   let assemblyFormat = "$resval attr-dict `:` type($resval)";
 }
 
-//===------------------------------------------------------------------------===//
+//===----------------------------------------------------------------------===//
 // Operations on !fir.box<T> type objects
-//===------------------------------------------------------------------------===//
+//===----------------------------------------------------------------------===//
 
 def fir_EmboxOp : fir_Op<"embox", [NoSideEffect, AttrSizedOperandSegments]> {
   let summary = "boxes a given reference and (optional) dimension information";
@@ -891,26 +891,27 @@ def fir_EmboxOp : fir_Op<"embox", [NoSideEffect, AttrSizedOperandSegments]> {
 }
 
 def fir_ReboxOp : fir_Op<"rebox", [NoSideEffect, AttrSizedOperandSegments]> {
-  let summary = "create a box given another box and (optional) dimension information";
+  let summary =
+    "create a box given another box and (optional) dimension information";
 
   let description = [{
-    Create a new boxed reference value from another box. This is meant to be used
-    when the taking a reference to part of a boxed value, or to an entire boxed value with
-    new shape or type information.
+    Create a new boxed reference value from another box. This is meant to be
+    used when the taking a reference to part of a boxed value, or to an entire
+    boxed value with new shape or type information.
 
     The new extra information can be:
       - new shape information (new lower bounds, new rank, or new extents.
         New rank/extents can only be provided if the original fir.box is
-        contiguous in all dimension but maybe the first one). The shape
+        contiguous in all dimension but maybe the first row). The shape
         operand must be provided to set new shape information.
-      - new type (only for derived types). It is possible to set the dynamic type
-        of the new box to one of the parent types of the input box dynamic type.
-        Type parameters cannot be changed. This change is reflected in the requested
-        result type of the new box.
+      - new type (only for derived types). It is possible to set the dynamic
+        type of the new box to one of the parent types of the input box dynamic
+        type. Type parameters cannot be changed. This change is reflected in
+        the requested result type of the new box.
 
-    A slice argument can be provided to build a reference to part of a boxed value.
-    In this case, the shape operand must be absent or be a fir.shift that can be
-    used to provide a non default origin for the slice.
+    A slice argument can be provided to build a reference to part of a boxed
+    value. In this case, the shape operand must be absent or be a fir.shift
+    that can be used to provide a non default origin for the slice.
 
     The following example illustrates creating a fir.box for x(10:33:2)
     where x is described by a fir.box and has non default lower bounds,
@@ -1342,6 +1343,16 @@ def fir_ArrayLoadOp : fir_Op<"array_load", [AttrSizedOperandSegments]> {
   let summary = "Load an array as a value.";
 
   let description = [{
+    This operation taken with array_merge_store captures Fortran's
+    copy-in/copy-out semantics. One way to think of this is that array_load
+    creates a snapshot copy of the entire array. This copy can then be used
+    as the "original value" of the array while the array's new value is
+    computed. The array_merge_store operation is the copy-out semantics, which
+    merge the updates with the original array value to produce the final array
+    result. This abstracts the copy operations as opposed to always creating
+    copies or requiring dependence analysis be performed on the syntax trees
+    and before lowering to the IR.
+
     Load an entire array as a single SSA value.
 
     ```fortran
@@ -1540,6 +1551,81 @@ def fir_ArrayModifyOp : fir_Op<"array_modify", [AttrSizedOperandSegments,
   let verifier = [{ return ::verify(*this); }];
 }
 
+def fir_ArrayAccessOp : fir_Op<"array_access", [AttrSizedOperandSegments,
+    NoSideEffect]> {
+  let summary = "Fetch the reference of an element of an array value";
+
+  let description = [{
+    Fetch the memory reference of an element in an array value.
+
+    ```fortran
+      real :: a(n,m)
+      ...
+      ... a ...
+      ... a(r,s+1) ...
+    ```
+
+    One can use `fir.array_access` to recover the implied memory reference to
+    the element `a(i,j)` in an array expression `a` as shown above. It can also
+    be used to recover the reference element `a(r,s+1)` in the second
+    expression.
+
+    ```mlir
+      %s = fir.shape %n, %m : (index, index) -> !fir.shape<2>
+      // load the entire array 'a'
+      %v = fir.array_load %a(%s) : (!fir.ref<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.array<?x?xf32>
+      // fetch the value of one of the array value's elements
+      %1 = fir.array_access %v, %i, %j : (!fir.array<?x?xf32>, index, index) -> !fir.ref<f32>
+    ```
+
+    It is only possible to use `array_access` on an `array_load` result value.
+  }];
+
+  let arguments = (ins
+    fir_SequenceType:$sequence,
+    Variadic<AnyCoordinateType>:$indices,
+    Variadic<AnyIntegerType>:$typeparams
+  );
+
+  let results = (outs fir_ReferenceType:$element);
+
+  let assemblyFormat = [{
+    $sequence `,` $indices (`typeparams` $typeparams^)? attr-dict `:`
+      functional-type(operands, results)
+  }];
+
+  let verifier = "return ::verify(*this);";
+}
+
+def fir_ArrayAmendOp : fir_Op<"array_amend", [NoSideEffect]> {
+  let summary = "Mark an array value as having been changed by reference.";
+
+  let description = [{
+    Marks an array value as having been changed via a reference. The reference
+    into the array value is obtained via an fir.array_access op.
+
+    ```mlir
+      // fetch the value of one of the array value's elements
+      %1 = fir.array_access %v, %i, %j : (!fir.array<?x?xT>, index, index) -> !fir.ref<T>
+      // modify the element by storing data using %1 as a reference
+      %2 = ... %1 ...
+      // mark the array value
+      %new_v = fir.array_amend %v, %2 : (!fir.array<?x?xT>, !fir.ref<T>) -> !fir.array<?x?xT>
+    ```
+  }];
+
+  let arguments = (ins
+    fir_SequenceType:$sequence,
+    fir_ReferenceType:$memref
+  );
+
+  let results = (outs fir_SequenceType);
+
+  let assemblyFormat = [{
+    $sequence `,` $memref attr-dict `:` functional-type(operands, results)
+  }];
+}
+
 def fir_ArrayMergeStoreOp : fir_Op<"array_merge_store",
     [AttrSizedOperandSegments]> {
   let summary = "Store merged array value to memory.";
@@ -1893,19 +1979,34 @@ def fir_SliceOp : fir_Op<"slice", [NoSideEffect, AttrSizedOperandSegments]> {
       %fld = fir.field_index component, !fir.type<t{...component:ct...}>
       %d = fir.slice %lo, %hi, %step path %fld : (index, index, index, !fir.field) -> !fir.slice<1>
     ```
+
+    Projections of `!fir.char` type can be further narrowed to invariant
+    substrings.
+
+    ```mlir
+      %d = fir.slice %lo, %hi, %step substr %offset, %width : (index, index, index, index, index) -> !fir.slice<1>
+    ```
   }];
 
   let arguments = (ins
-    Variadic<AnyCoordinateType>:$triples,
-    Variadic<AnyComponentType>:$fields
+    Variadic<AnyIntegerType>:$triples,
+    Variadic<AnyComponentType>:$fields,
+    Variadic<AnyIntegerType>:$substr
   );
 
   let results = (outs fir_SliceType);
 
   let assemblyFormat = [{
-    $triples (`path` $fields^)? attr-dict `:` functional-type(operands, results)
+    $triples (`path` $fields^)? (`substr` $substr^)? attr-dict `:`
+      functional-type(operands, results)
   }];
 
+  let builders = [
+    OpBuilder<(ins "mlir::ValueRange":$triples,
+      CArg<"mlir::ValueRange", "llvm::None">:$fields,
+      CArg<"mlir::ValueRange", "llvm::None">:$substr)>
+  ];
+
   let verifier = "return ::verify(*this);";
 
   let extraClassDeclaration = [{

flang/include/flang/Optimizer/Dialect/FIROpsSupport.h

@@ -15,31 +15,33 @@
 
 namespace fir {
 
-/// return true iff the Operation is a non-volatile LoadOp
+/// Return true iff the Operation is a non-volatile LoadOp or ArrayLoadOp.
 inline bool nonVolatileLoad(mlir::Operation *op) {
   if (auto load = dyn_cast<fir::LoadOp>(op))
     return !load->getAttr("volatile");
+  if (auto arrLoad = dyn_cast<fir::ArrayLoadOp>(op))
+    return !arrLoad->getAttr("volatile");
   return false;
 }
 
-/// return true iff the Operation is a call
+/// Return true iff the Operation is a call.
 inline bool isaCall(mlir::Operation *op) {
   return isa<fir::CallOp>(op) || isa<fir::DispatchOp>(op) ||
          isa<mlir::CallOp>(op) || isa<mlir::CallIndirectOp>(op);
 }
 
-/// return true iff the Operation is a fir::CallOp, fir::DispatchOp,
+/// Return true iff the Operation is a fir::CallOp, fir::DispatchOp,
 /// mlir::CallOp, or mlir::CallIndirectOp and not pure
-/// NB: this is not the same as `!pureCall(op)`
+/// NB: This is not the same as `!pureCall(op)`.
 inline bool impureCall(mlir::Operation *op) {
   // Should we also auto-detect that the called function is pure if its
   // arguments are not references?  For now, rely on a "pure" attribute.
   return op && isaCall(op) && !op->getAttr("pure");
 }
 
-/// return true iff the Operation is a fir::CallOp, fir::DispatchOp,
+/// Return true iff the Operation is a fir::CallOp, fir::DispatchOp,
 /// mlir::CallOp, or mlir::CallIndirectOp and is also pure.
-/// NB: this is not the same as `!impureCall(op)`
+/// NB: This is not the same as `!impureCall(op)`.
 inline bool pureCall(mlir::Operation *op) {
   // Should we also auto-detect that the called function is pure if its
   // arguments are not references?  For now, rely on a "pure" attribute.

flang/include/flang/Optimizer/Dialect/FIRType.h

@@ -193,6 +193,22 @@ inline mlir::Type unwrapPassByRefType(mlir::Type t) {
   return t;
 }
 
+/// Unwrap all pointer and box types and return the element type if it is a
+/// sequence type, otherwise return null.
+inline fir::SequenceType unwrapUntilSeqType(mlir::Type t) {
+  while (true) {
+    if (!t)
+      return {};
+    if (auto ty = dyn_cast_ptrOrBoxEleTy(t)) {
+      t = ty;
+      continue;
+    }
+    if (auto seqTy = t.dyn_cast<fir::SequenceType>())
+      return seqTy;
+    return {};
+  }
+}
+
 #ifndef NDEBUG
 // !fir.ptr<X> and !fir.heap<X> where X is !fir.ptr, !fir.heap, or !fir.ref
 // is undefined and disallowed.