[flang][fir] Update FIR's character type.

[schweitz]

Summary

Upstream the changes made to the !fir.char type.

https://github.com/flang-compiler/f18-llvm-project/pull/269
https://github.com/flang-compiler/f18-llvm-project/pull/557

[schweitz]

Typo in commit message. 7e20a413483307c2f7df327074bc0b687335f3b1

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

 
 /// Extract the `Type` pointed to from a FIR memory reference type. If `t` is
 /// not a memory reference type, then returns a null `Type`.
 mlir::Type dyn_cast_ptrEleTy(mlir::Type t);
 
 // Intrinsic types
 
 /// Model of the Fortran CHARACTER intrinsic type, including the KIND type
-/// parameter. The model does not include a LEN type parameter. A CharacterType
-/// is thus the type of a single character value.
+/// parameter. The model optionally includes a LEN type parameter. A
+/// CharacterType is thus the type of both a single character value and a
+/// character with a LEN parameter.
 class CharacterType
     : public mlir::Type::TypeBase<CharacterType, mlir::Type,
                                   detail::CharacterTypeStorage> {
 public:
   using Base::Base;
-  static CharacterType get(mlir::MLIRContext *ctxt, KindTy kind);
+  using LenType = std::int64_t;
+
+  static CharacterType get(mlir::MLIRContext *ctxt, KindTy kind, LenType len);
+  /// Return unknown length CHARACTER type.
+  static CharacterType getUnknownLen(mlir::MLIRContext *ctxt, KindTy kind) {
+    return get(ctxt, kind, unknownLen());
+  }
+  /// Return length 1 CHARACTER type.
+  static CharacterType getSingleton(mlir::MLIRContext *ctxt, KindTy kind) {
+    return get(ctxt, kind, singleton());
+  }
   KindTy getFKind() const;
+
+  /// CHARACTER is a singleton and has a LEN of 1.
+  static constexpr LenType singleton() { return 1; }
+  /// CHARACTER has an unknown LEN property.
+  static constexpr LenType unknownLen() { return -1; }
+
+  /// Access to a CHARACTER's LEN property. Defaults to 1.
+  LenType getLen() const;
 };
 
 /// Model of a Fortran COMPLEX intrinsic type, including the KIND type
 /// parameter. COMPLEX is a floating point type with a real and imaginary
 /// member.
 class ComplexType : public mlir::Type::TypeBase<fir::ComplexType, mlir::Type,
                                                 detail::ComplexTypeStorage> {
 public:

 /// Index, or FIR Int). Aborts execution if condition is false.
 void verifyIntegralType(mlir::Type type);
 
 /// Is `t` a FIR or MLIR Complex type?
 inline bool isa_complex(mlir::Type t) {
   return t.isa<fir::ComplexType>() || t.isa<mlir::ComplexType>();
 }
 
+inline bool isa_char_string(mlir::Type t) {
+  if (auto ct = t.dyn_cast_or_null<fir::CharacterType>())
+    return ct.getLen() != fir::CharacterType::singleton();
+  return false;
+}
+
+/// Is `t` a box type for which it is not possible to deduce the box size.
+/// It is not possible to deduce the size of a box that describes an entity
+/// of unknown rank or type.
+bool isa_unknown_size_box(mlir::Type t);
+
 } // namespace fir
 
 #endif // OPTIMIZER_DIALECT_FIRTYPE_H

flang/lib/Lower/ConvertType.cpp

 }
 
 template <>
 mlir::Type
 genFIRType<Fortran::common::TypeCategory::Character>(mlir::MLIRContext *context,
                                                      int KIND) {
   if (Fortran::evaluate::IsValidKindOfIntrinsicType(
           Fortran::common::TypeCategory::Character, KIND))
-    return fir::CharacterType::get(context, KIND);
+    return fir::CharacterType::get(context, KIND, 1);
   return {};
 }
 
 template <>
 mlir::Type
 genFIRType<Fortran::common::TypeCategory::Complex>(mlir::MLIRContext *context,
                                                    int KIND) {
   if (Fortran::evaluate::IsValidKindOfIntrinsicType(

flang/lib/Lower/IO.cpp

 static std::tuple<mlir::Value, mlir::Value, mlir::Value>
 lowerSourceTextAsStringLit(Fortran::lower::AbstractConverter &converter,
                            mlir::Location loc, llvm::StringRef text,
                            mlir::Type strTy, mlir::Type lenTy) {
   text = text.drop_front(text.find('('));
   text = text.take_front(text.rfind(')') + 1);
   auto &builder = converter.getFirOpBuilder();
   auto lit = builder.createStringLit(
-      loc, /*FIXME*/ fir::CharacterType::get(builder.getContext(), 1), text);
+      loc, /*FIXME*/ fir::CharacterType::get(builder.getContext(), 1, 1), text);
   auto data =
       Fortran::lower::CharacterExprHelper{builder, loc}.materializeCharacter(
           lit);
   auto buff = builder.createConvert(loc, strTy, data.first);
   auto len = builder.createConvert(loc, lenTy, data.second);
   return {buff, len, mlir::Value{}};
 }
 

flang/lib/Lower/IntrinsicCall.cpp

mlir::Value IntrinsicLibrary::genIchar(mlir::Type resultType,
                                        llvm::ArrayRef<mlir::Value> args) {
   // There can be an optional kind in second argument.
   assert(args.size() >= 1);
 
   auto arg = args[0];
   Fortran::lower::CharacterExprHelper helper{builder, loc};
   auto dataAndLen = helper.createUnboxChar(arg);
   auto charType = fir::CharacterType::get(
-      builder.getContext(), helper.getCharacterKind(arg.getType()));
+      builder.getContext(), helper.getCharacterKind(arg.getType()), 1);
   auto refType = builder.getRefType(charType);
   auto charAddr = builder.createConvert(loc, refType, dataAndLen.first);
   auto charVal = builder.create<fir::LoadOp>(loc, charType, charAddr);
   return builder.createConvert(loc, resultType, charVal);
 }
 
 // IEOR
 mlir::Value IntrinsicLibrary::genIEOr(mlir::Type resultType,

flang/lib/Optimizer/Dialect/FIRType.cpp

BoxCharType parseBoxChar(mlir::DialectAsmParser &parser) {
   return parseKindSingleton<BoxCharType>(parser);
 }
 
 // `boxproc` `<` return-type `>`
 BoxProcType parseBoxProc(mlir::DialectAsmParser &parser, mlir::Location loc) {
   return parseTypeSingleton<BoxProcType>(parser, loc);
 }
 
-// `char` `<` kind `>`
+// `char` `<` kind [`,` `len`] `>`
 CharacterType parseCharacter(mlir::DialectAsmParser &parser) {
-  return parseKindSingleton<CharacterType>(parser);
+  int kind = 0;
+  if (parser.parseLess() || parser.parseInteger(kind)) {
+    parser.emitError(parser.getCurrentLocation(), "kind value expected");
+    return {};
+  }
+  CharacterType::LenType len = 1;
+  if (mlir::succeeded(parser.parseOptionalComma())) {
+    if (mlir::succeeded(parser.parseOptionalQuestion())) {
+      len = fir::CharacterType::unknownLen();
+    } else if (!mlir::succeeded(parser.parseInteger(len))) {
+      parser.emitError(parser.getCurrentLocation(), "len value expected");
+      return {};
+    }
+  }
+  if (parser.parseGreater())
+    return {};
+  return CharacterType::get(parser.getBuilder().getContext(), kind, len);
 }
 
 // `complex` `<` kind `>`
 fir::ComplexType parseComplex(mlir::DialectAsmParser &parser) {
   return parseKindSingleton<fir::ComplexType>(parser);
 }
 
 // `shape` `<` rank `>`

 // bounds ::= `?` | int-lit
 SequenceType parseSequence(mlir::DialectAsmParser &parser, mlir::Location) {
   if (parser.parseLess()) {
     parser.emitError(parser.getNameLoc(), "expecting '<'");
     return {};
   }
   SequenceType::Shape shape;
   if (parser.parseOptionalStar()) {
-    if (parser.parseDimensionList(shape, true)) {
+    if (parser.parseDimensionList(shape, /*allowDynamic=*/true)) {
       parser.emitError(parser.getNameLoc(), "invalid shape");
       return {};
     }
   } else if (parser.parseColon()) {
     parser.emitError(parser.getNameLoc(), "expected ':'");
     return {};
   }
   mlir::Type eleTy;

 
 namespace fir {
 namespace detail {
 
 // Type storage classes
 
 /// `CHARACTER` storage
 struct CharacterTypeStorage : public mlir::TypeStorage {
-  using KeyTy = KindTy;
+  using KeyTy = std::tuple<KindTy, CharacterType::LenType>;
 
-  static unsigned hashKey(const KeyTy &key) { return llvm::hash_combine(key); }
+  static unsigned hashKey(const KeyTy &key) {
+    auto hashVal = llvm::hash_combine(std::get<0>(key));
+    return llvm::hash_combine(hashVal, llvm::hash_combine(std::get<1>(key)));
+  }
 
-  bool operator==(const KeyTy &key) const { return key == getFKind(); }
+  bool operator==(const KeyTy &key) const {
+    return key == KeyTy{getFKind(), getLen()};
+  }
 
   static CharacterTypeStorage *construct(mlir::TypeStorageAllocator &allocator,
-                                         KindTy kind) {
+                                         const KeyTy &key) {
     auto *storage = allocator.allocate<CharacterTypeStorage>();
-    return new (storage) CharacterTypeStorage{kind};
+    return new (storage)
+        CharacterTypeStorage{std::get<0>(key), std::get<1>(key)};
   }
 
   KindTy getFKind() const { return kind; }
+  CharacterType::LenType getLen() const { return len; }
 
 protected:
   KindTy kind;
+  CharacterType::LenType len;
 
 private:
   CharacterTypeStorage() = delete;
-  explicit CharacterTypeStorage(KindTy kind) : kind{kind} {}
+  explicit CharacterTypeStorage(KindTy kind, CharacterType::LenType len)
+      : kind{kind}, len{len} {}
 };
 
 struct ShapeTypeStorage : public mlir::TypeStorage {
   using KeyTy = unsigned;
 
   static unsigned hashKey(const KeyTy &key) { return llvm::hash_combine(key); }
 
   bool operator==(const KeyTy &key) const { return key == getRank(); }
struct BoxCharTypeStorage : public mlir::TypeStorage {
   static BoxCharTypeStorage *construct(mlir::TypeStorageAllocator &allocator,
                                        KindTy kind) {
     auto *storage = allocator.allocate<BoxCharTypeStorage>();
     return new (storage) BoxCharTypeStorage{kind};
   }
 
   KindTy getFKind() const { return kind; }
 
-  // a !fir.boxchar<k> always wraps a !fir.char<k>
+  // a !fir.boxchar<k> always wraps a !fir.char<k, ?>
   CharacterType getElementType(mlir::MLIRContext *ctxt) const {
-    return CharacterType::get(ctxt, getFKind());
+    return CharacterType::getUnknownLen(ctxt, getFKind());
   }
 
 protected:
   KindTy kind;
 
 private:
   BoxCharTypeStorage() = delete;
   explicit BoxCharTypeStorage(KindTy kind) : kind{kind} {}

 };
 
 /// Sequence-like object storage
 struct SequenceTypeStorage : public mlir::TypeStorage {
   using KeyTy =
       std::tuple<SequenceType::Shape, mlir::Type, mlir::AffineMapAttr>;
 
   static unsigned hashKey(const KeyTy &key) {
-    auto shapeHash{hash_value(std::get<SequenceType::Shape>(key))};
+    auto shapeHash = hash_value(std::get<SequenceType::Shape>(key));
     shapeHash = llvm::hash_combine(shapeHash, std::get<mlir::Type>(key));
     return llvm::hash_combine(shapeHash, std::get<mlir::AffineMapAttr>(key));
   }
 
   bool operator==(const KeyTy &key) const {
     return key == KeyTy{getShape(), getElementType(), getLayoutMap()};
   }
 
return llvm::TypeSwitch<mlir::Type, mlir::Type>(t)
           [](auto p) { return p.getEleTy(); })
       .Default([](mlir::Type) { return mlir::Type{}; });
 }
 
 } // namespace fir
 
 // CHARACTER
 
-CharacterType fir::CharacterType::get(mlir::MLIRContext *ctxt, KindTy kind) {
-  return Base::get(ctxt, kind);
+CharacterType fir::CharacterType::get(mlir::MLIRContext *ctxt, KindTy kind,
+                                      CharacterType::LenType len) {
+  return Base::get(ctxt, kind, len);
 }
 
 KindTy fir::CharacterType::getFKind() const { return getImpl()->getFKind(); }
 
+CharacterType::LenType fir::CharacterType::getLen() const {
+  return getImpl()->getLen();
+}
+
 // Field
 
 FieldType fir::FieldType::get(mlir::MLIRContext *ctxt) {
   return Base::get(ctxt, 0);
 }
 
 // Len
 
fir::VectorType::verifyConstructionInvariants(mlir::Location loc, uint64_t len,
   return mlir::success();
 }
 
 namespace {
 
 void printBounds(llvm::raw_ostream &os, const SequenceType::Shape &bounds) {
   os << '<';
   for (auto &b : bounds) {
-    if (b >= 0) {
+    if (b >= 0)
       os << b << 'x';
-    } else {
+    else
       os << "?x";
-    }
-  }
-}
 
 llvm::SmallPtrSet<detail::RecordTypeStorage const *, 4> recordTypeVisited;
 
 } // namespace
 
 void fir::verifyIntegralType(mlir::Type type) {
   if (isaIntegerType(type) || type.isa<mlir::IndexType>())
     return;
if (auto type = ty.dyn_cast<BoxCharType>()) {
     return;
   }
   if (auto type = ty.dyn_cast<BoxProcType>()) {
     os << "boxproc<";
     p.printType(type.getEleTy());
     os << '>';
     return;
   }
-  if (auto type = ty.dyn_cast<CharacterType>()) {
-    os << "char<" << type.getFKind() << '>';
+  if (auto chTy = ty.dyn_cast<CharacterType>()) {
+    // Fortran intrinsic type CHARACTER
+    os << "char<" << chTy.getFKind();
+    auto len = chTy.getLen();
+    if (len != fir::CharacterType::singleton()) {
+      os << ',';
+      if (len == fir::CharacterType::unknownLen())
+        os << '?';
+      else
+        os << len;
+    }
+    os << '>';
     return;
   }
   if (auto type = ty.dyn_cast<fir::ComplexType>()) {
     // Fortran intrinsic type COMPLEX
     os << "complex<" << type.getFKind() << '>';
     return;
   }
   if (auto type = ty.dyn_cast<RecordType>()) {
void fir::printFirType(FIROpsDialect *, mlir::Type ty,
   }
   if (auto type = ty.dyn_cast<fir::VectorType>()) {
     os << "vector<" << type.getLen() << ':';
     p.printType(type.getEleTy());
     os << '>';
     return;
   }
 }
+
+bool fir::isa_unknown_size_box(mlir::Type t) {
+  if (auto boxTy = t.dyn_cast<fir::BoxType>()) {
+    auto eleTy = boxTy.getEleTy();
+    if (auto actualEleTy = fir::dyn_cast_ptrEleTy(eleTy))
+      eleTy = actualEleTy;
+    if (eleTy.isa<mlir::NoneType>())
+      return true;
+    if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
+      if (seqTy.hasUnknownShape())
+        return true;
+  }
+  return false;
+}

flang/test/Fir/fir-types.fir

 // Test the FIR types
 
 // RUN: tco -emit-fir %s | tco -emit-fir | FileCheck %s
 
 // Fortran Intrinsic types
 // CHECK-LABEL: func private @it1() -> !fir.int<4>
 // CHECK-LABEL: func private @it2() -> !fir.real<8>
 // CHECK-LABEL: func private @it3() -> !fir.complex<8>
 // CHECK-LABEL: func private @it4() -> !fir.logical<1>
 // CHECK-LABEL: func private @it5() -> !fir.char<1>
+// CHECK-LABEL: func private @it6() -> !fir.char<2,10>
+// CHECK-LABEL: func private @it7() -> !fir.char<4,?>
 func private @it1() -> !fir.int<4>
 func private @it2() -> !fir.real<8>
 func private @it3() -> !fir.complex<8>
 func private @it4() -> !fir.logical<1>
 func private @it5() -> !fir.char<1>
+func private @it6() -> !fir.char<2,10>
+func private @it7() -> !fir.char<4,?>
 
 // Fortran Derived types (records)
 // CHECK-LABEL: func private @dvd1() -> !fir.type<derived1>
 // CHECK-LABEL: func private @dvd2() -> !fir.type<derived2(p:i32)>
 // CHECK-LABEL: func private @dvd3() -> !fir.type<derived3{f:f32}>
 // CHECK-LABEL: func private @dvd4() -> !fir.type<derived4(p:i8){f:f32}>
 // CHECK-LABEL: func private @dvd5() -> !fir.type<derived5(p1:i8,p2:i8,p3:i8,p4:i8,p5:i8){f1:f32,f2:f32,f3:f32,f4:f32,f5:f32,f6:f32,f7:f32,f8:f32}>
 // CHECK-LABEL: func private @dvd6() -> !fir.type<derived6{f:!fir.ptr<!fir.type<derived6>>}>