[flang] Enable character type guard in select type

[clementval]

Summary

SELECT TYPE lower and conversion was not handling
character type guard. This add support for it.

[jeanPerier]

flang/lib/Lower/Bridge.cpp

2295

Shouldn't the length come from the selector fir.class instead of being unknow at runtime ? (fir::factory::CharacterExprHelper.readLengthFromBox might be able to do this).
This code also seems to only deal with scalars, SELECT TYPE support for intrinsic types is still TODO right ?

[clementval]

flang/lib/Lower/Bridge.cpp

2295

We can use the BoxEleSizeOp but not fir::factory::CharacterExprHelper.readLengthFromBox since it requires a fir.char type.

The support for intrinsic type is already in.

[jeanPerier]

flang/lib/Lower/Bridge.cpp

2295

We can use the BoxEleSizeOp but not fir:🏭:CharacterExprHelper.readLengthFromBox since it requires a fir.char type

Makes sense. Do not forget to divide by the character kind.

The support for intrinsic type is already in.

Sorry, my question was about intrinsic arrays, I forgot the important word.... It seems the code does not care about the shape at that point for intrinsic types.

[clementval]

flang/lib/Lower/Bridge.cpp

2295

Makes sense. Do not forget to divide by the character kind.

Right. Kind might not be retrievable since the the selector is always unlimited polymorphic for intrinsic type guards. So we might need to keep unknownLen unless there is another way to retrive the kind?

Sorry, my question was about intrinsic arrays, I forgot the important word.... It seems the code does not care about the shape at that point for intrinsic types.

Oh ok. Yeah it might need some update for arrays.

[jeanPerier]

flang/lib/Lower/Bridge.cpp

2295

You should be able to get the kind from the type guard of the TYPE_IS (attr.getType()) that should be a fir.char<kind, len> here right ?

[clementval]

flang/lib/Lower/Bridge.cpp

2295

Yeah my bad. I'm not thinking correctly today :)

[clementval]

Get char length from box

[clementval]

flang/lib/Lower/Bridge.cpp

2295

I'll do array in a separate patch.

[jeanPerier]

Looks good

flang/lib/Lower/Bridge.cpp

2295

I'll do array in a separate patch.

Sound good to me

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

public:
   /// returned length will be empty.
   mlir::Value getLength(mlir::Value memref);
 
   /// Compute length given a fir.box describing a character entity.
   /// It adjusts the length from the number of bytes per the descriptor
   /// to the number of characters per the Fortran KIND.
   mlir::Value readLengthFromBox(mlir::Value box);
 
+  /// Same as readLengthFromBox but the CharacterType is provided.
+  mlir::Value readLengthFromBox(mlir::Value box, fir::CharacterType charTy);
+
 private:
   /// FIXME: the implementation also needs a clean-up now that
   /// CharBoxValue are better propagated.
   fir::CharBoxValue materializeValue(mlir::Value str);
   mlir::Value getCharBoxBuffer(const fir::CharBoxValue &box);
   mlir::Value createElementAddr(mlir::Value buffer, mlir::Value index);
   mlir::Value createLoadCharAt(mlir::Value buff, mlir::Value index);
   void createStoreCharAt(mlir::Value str, mlir::Value index, mlir::Value c);

flang/lib/Lower/Bridge.cpp

for (Fortran::lower::pft::Evaluation &eval :
             mlir::Type ty;
             if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
                     typeSpec->u)) {
               const Fortran::semantics::IntrinsicTypeSpec *intrinsic =
                   typeSpec->declTypeSpec->AsIntrinsic();
               int kind =
                   Fortran::evaluate::ToInt64(intrinsic->kind()).value_or(kind);
               llvm::SmallVector<Fortran::lower::LenParameterTy> params;
-              if (intrinsic->category() ==
-                      Fortran::common::TypeCategory::Character ||
-                  intrinsic->category() ==
-                      Fortran::common::TypeCategory::Derived)
-                TODO(loc, "typeSpec with length parameters");
               ty = genType(intrinsic->category(), kind, params);
             } else {
               const Fortran::semantics::DerivedTypeSpec *derived =
                   typeSpec->declTypeSpec->AsDerived();
               ty = genType(*derived);
             }
             attrList.push_back(fir::ExactTypeAttr::get(ty));
           } else if (const auto *derived =
for (Fortran::lower::pft::Evaluation &eval :
           fir::ExactTypeAttr attr =
               typeGuardAttr.dyn_cast<fir::ExactTypeAttr>();
           mlir::Value exactValue;
           if (std::holds_alternative<Fortran::parser::IntrinsicTypeSpec>(
                   typeSpec->u)) {
             exactValue = builder->create<fir::BoxAddrOp>(
                 loc, fir::ReferenceType::get(attr.getType()),
                 fir::getBase(selector));
+            const Fortran::semantics::IntrinsicTypeSpec *intrinsic =
+                typeSpec->declTypeSpec->AsIntrinsic();
+            if (intrinsic->category() ==
+                Fortran::common::TypeCategory::Character) {
+              auto charTy = attr.getType().dyn_cast<fir::CharacterType>();
+              mlir::Value charLen =
+                  fir::factory::CharacterExprHelper(*builder, loc)
+                      .readLengthFromBox(fir::getBase(selector), charTy);
+              addAssocEntitySymbol(fir::CharBoxValue(exactValue, charLen));
+            } else {
+              addAssocEntitySymbol(exactValue);
+            }
           } else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
                          typeSpec->u)) {
             exactValue = builder->create<fir::ConvertOp>(
                 loc, fir::BoxType::get(attr.getType()), fir::getBase(selector));
-          }
             addAssocEntitySymbol(exactValue);
+          }
         } else if (std::holds_alternative<Fortran::parser::DerivedTypeSpec>(
                        guard.u)) {
           // CLASS IS
           fir::SubclassAttr attr = typeGuardAttr.dyn_cast<fir::SubclassAttr>();
           mlir::Value derived = builder->create<fir::ConvertOp>(
               loc, fir::ClassType::get(attr.getType()), fir::getBase(selector));
           addAssocEntitySymbol(derived);
         }

flang/lib/Optimizer/Builder/Character.cpp

mlir::Value fir::factory::CharacterExprHelper::extractCodeFromSingleton(
   auto intType = builder.getIntegerType(bits);
   auto zero = builder.getIntegerAttr(builder.getIndexType(), 0);
   return builder.create<fir::ExtractValueOp>(loc, intType, singleton,
                                              builder.getArrayAttr(zero));
 }
 
 mlir::Value
 fir::factory::CharacterExprHelper::readLengthFromBox(mlir::Value box) {
+  auto charTy = recoverCharacterType(box.getType());
+  return readLengthFromBox(box, charTy);
+}
+
+mlir::Value fir::factory::CharacterExprHelper::readLengthFromBox(
+    mlir::Value box, fir::CharacterType charTy) {
   auto lenTy = builder.getCharacterLengthType();
   auto size = builder.create<fir::BoxEleSizeOp>(loc, lenTy, box);
-  auto charTy = recoverCharacterType(box.getType());
   auto bits = builder.getKindMap().getCharacterBitsize(charTy.getFKind());
   auto width = bits / 8;
   if (width > 1) {
     auto widthVal = builder.createIntegerConstant(loc, lenTy, width);
     return builder.create<mlir::arith::DivSIOp>(loc, size, widthVal);
   }
   return size;
 }

flang/lib/Optimizer/Transforms/ControlFlowConverter.cpp

static int getTypeCode(mlir::Type ty, fir::KindMapping &kindMap) {
     if (fir::isa_complex(ty)) {
       if (auto cmplxTy = ty.dyn_cast<mlir::ComplexType>())
         return fir::complexBitsToTypeCode(
             cmplxTy.getElementType().cast<mlir::FloatType>().getWidth());
       auto cmplxTy = ty.cast<fir::ComplexType>();
       return fir::complexBitsToTypeCode(
           kindMap.getRealBitsize(cmplxTy.getFKind()));
     }
-    return 0; // TODO more types.
+    if (auto charTy = ty.dyn_cast<fir::CharacterType>())
+      return fir::characterBitsToTypeCode(
+          kindMap.getCharacterBitsize(charTy.getFKind()));
+    return 0;
   }
 
   mlir::LogicalResult
   genTypeLadderStep(mlir::Location loc, mlir::Value selector,
                     mlir::Attribute attr, mlir::Block *dest,
                     llvm::Optional<mlir::ValueRange> destOps,
                     mlir::ModuleOp mod, mlir::PatternRewriter &rewriter,
                     fir::KindMapping &kindMap) const {
     mlir::Value cmp;
     // TYPE IS type guard comparison are all done inlined.
     if (auto a = attr.dyn_cast<fir::ExactTypeAttr>()) {
-      if (fir::isa_trivial(a.getType())) {
+      if (fir::isa_trivial(a.getType()) ||
+          a.getType().isa<fir::CharacterType>()) {
         // For type guard statement with Intrinsic type spec the type code of
         // the descriptor is compared.
         int code = getTypeCode(a.getType(), kindMap);
         if (code == 0)
           return mlir::emitError(loc)
-                 << "type code not done for " << a.getType();
+                 << "type code unavailable for " << a.getType();
         mlir::Value typeCode = rewriter.create<mlir::arith::ConstantOp>(
             loc, rewriter.getI8IntegerAttr(code));
         mlir::Value selectorTypeCode = rewriter.create<fir::BoxTypeCodeOp>(
             loc, rewriter.getI8Type(), selector);
         cmp = rewriter.create<mlir::arith::CmpIOp>(
             loc, mlir::arith::CmpIPredicate::eq, selectorTypeCode, typeCode);
       } else {
         // Flang inline the kind parameter in the type descriptor so we can

flang/test/Lower/select-type.f90

subroutine select_type5(a)
     type is (integer(1))
       print*, 'type is integer(1)'
     type is (integer(4))
       print*, 'type is integer(4)'
     type is (real(4))
       print*, 'type is real'
     type is (logical)
       print*, 'type is logical'
+    type is (character(*))
+      print*, 'type is character'
     class default
       print*,'default'
     end select
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMselect_type_lower_testPselect_type5(
 ! CHECK-SAME: %[[ARG0:.*]]: !fir.class<none> {fir.bindc_name = "a"})
 ! CHECK: fir.select_type %[[ARG0]] : !fir.class<none>
-! CHECK-SAME: [#fir.type_is<i8>, ^[[I8_BLK:.*]], #fir.type_is<i32>, ^[[I32_BLK:.*]], #fir.type_is<f32>, ^[[F32_BLK:.*]], #fir.type_is<!fir.logical<4>>, ^[[LOG_BLK:.*]], unit, ^[[DEFAULT:.*]]] 
+! CHECK-SAME: [#fir.type_is<i8>, ^[[I8_BLK:.*]], #fir.type_is<i32>, ^[[I32_BLK:.*]], #fir.type_is<f32>, ^[[F32_BLK:.*]], #fir.type_is<!fir.logical<4>>, ^[[LOG_BLK:.*]], #fir.type_is<!fir.char<1,?>>, ^[[CHAR_BLK:.*]], unit, ^[[DEFAULT:.*]]] 
 ! CHECK: ^[[I8_BLK]]
 ! CHECK: ^[[I32_BLK]]
 ! CHECK: ^[[F32_BLK]]
 ! CHECK: ^[[LOG_BLK]]
+! CHECK: ^[[CHAR_BLK]]
 ! CHECK: ^[[DEFAULT_BLOCK]]
 
 ! CFG-LABEL: func.func @_QMselect_type_lower_testPselect_type5(
+! CFG-SAME: %[[SELECTOR:.*]]: !fir.class<none> {fir.bindc_name = "a"}) {
+
+! CFG:  %[[INT8_TC:.*]] = arith.constant 7 : i8
+! CFG:  %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class<none>) -> i8
+! CFG:  %[[IS_INT8:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[INT8_TC]] : i8
+! CFG:  cf.cond_br %[[IS_INT8]], ^[[INT8_BLK:.*]], ^[[NOT_INT8:.*]]
+! CFG: ^[[NOT_INT8]]:
+! CFG:  %[[INT32_TC:.*]] = arith.constant 9 : i8
+! CFG:  %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class<none>) -> i8
+! CFG:  %[[IS_INT32:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[INT32_TC]] : i8
+! CFG:  cf.cond_br %[[IS_INT32]], ^[[INT32_BLK:.*]], ^[[NOT_INT32_BLK:.*]]
+! CFG: ^[[INT8_BLK]]:
+! CFG:  cf.br ^[[EXIT_BLK:.*]]
+! CFG: ^[[NOT_INT32_BLK]]:
+! CFG:  %[[FLOAT_TC:.*]] = arith.constant 27 : i8
+! CFG:  %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class<none>) -> i8
+! CFG:  %[[IS_FLOAT:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[FLOAT_TC]] : i8
+! CFG:  cf.cond_br %[[IS_FLOAT]], ^[[FLOAT_BLK:.*]], ^[[NOT_FLOAT_BLK:.*]]
+! CFG: ^[[INT32_BLK]]:
+! CFG:  cf.br ^[[EXIT_BLK]]
+! CFG: ^[[NOT_FLOAT_BLK]]:
+! CFG:  %[[LOGICAL_TC:.*]] = arith.constant 14 : i8
+! CFG:  %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class<none>) -> i8
+! CFG:  %[[IS_LOGICAL:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[LOGICAL_TC]] : i8
+! CFG:  cf.cond_br %[[IS_LOGICAL]], ^[[LOGICAL_BLK:.*]], ^[[NOT_LOGICAL_BLK:.*]]
+! CFG: ^[[FLOAT_BLK]]:
+! CFG:  cf.br ^[[EXIT_BLK]]
+! CFG: ^[[NOT_LOGICAL_BLK]]:
+! CFG:  %[[CHAR_TC:.*]] = arith.constant 40 : i8
+! CFG:  %[[TYPE_CODE:.*]] = fir.box_typecode %[[SELECTOR]] : (!fir.class<none>) -> i8
+! CFG:  %[[IS_CHAR:.*]] = arith.cmpi eq, %[[TYPE_CODE]], %[[CHAR_TC]] : i8
+! CFG:  cf.cond_br %[[IS_CHAR]], ^[[CHAR_BLK:.*]], ^[[NOT_CHAR_BLK:.*]]
+! CFG: ^[[LOGICAL_BLK]]:
+! CFG:  cf.br ^[[EXIT_BLK]]
+! CFG: ^[[NOT_CHAR_BLK]]:
+! CFG:  cf.br ^[[DEFAULT_BLK:.*]]
+! CFG: ^[[CHAR_BLK]]:
+! CFG:  cf.br ^[[EXIT_BLK]]
+! CFG: ^[[DEFAULT_BLK]]:
+! CFG:  cf.br ^[[EXIT_BLK]]
+! CFG: ^bb12:
+! CFG:  return
 
   subroutine select_type6(a)
     class(*) :: a
 
     select type(a)
     type is (integer)
       a = 100
     type is (real)