Turn on the assertion to check that the Value bound to a Symbol in the

lowering symbol table has a legal type.

Corrects a number of bugs associated with fixing the symbol table, etc.

Author: schweitzpgi

flang/include/flang/Evaluate/expression.h

@@ -26,6 +26,7 @@
 #include "flang/Common/indirection.h"
 #include "flang/Common/template.h"
 #include "flang/Parser/char-block.h"
+#include "llvm/Support/Compiler.h"
 #include <algorithm>
 #include <list>
 #include <tuple>
@@ -93,6 +94,9 @@ template <typename RESULT> class ExpressionBase {
   std::optional<DynamicType> GetType() const;
   int Rank() const;
   std::string AsFortran() const;
+  LLVM_DUMP_METHOD void dump() const {
+    llvm::errs() << "Ev::Expr is <{" << AsFortran() << "}>\n";
+  }
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
   static Derived Rewrite(FoldingContext &, Derived &&);
 };
@@ -129,8 +133,8 @@ class Operation {
 
 public:
   CLASS_BOILERPLATE(Operation)
-  explicit Operation(const Expr<OPERANDS> &...x) : operand_{x...} {}
-  explicit Operation(Expr<OPERANDS> &&...x) : operand_{std::move(x)...} {}
+  explicit Operation(const Expr<OPERANDS> &... x) : operand_{x...} {}
+  explicit Operation(Expr<OPERANDS> &&... x) : operand_{std::move(x)...} {}
 
   Derived &derived() { return *static_cast<Derived *>(this); }
   const Derived &derived() const { return *static_cast<const Derived *>(this); }

flang/include/flang/Lower/Support/BoxValue.h

@@ -14,6 +14,7 @@
 #define LOWER_SUPPORT_BOXVALUE_H
 
 #include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/Support/Matcher.h"
 #include "mlir/IR/Value.h"
 #include "llvm/ADT/SmallVector.h"
 #include "llvm/Support/Compiler.h"
@@ -53,8 +54,8 @@ class AbstractBox {
 public:
   AbstractBox() = delete;
   AbstractBox(mlir::Value addr) : addr{addr} {
-    // FIXME: enable the assert!
-    // assert(fir::isa_passbyref_type(addr.getType()));
+    assert(isa_passbyref_type(addr.getType()) &&
+           "box values must be references");
   }
 
   /// An abstract box always contains a memory reference to a value.
@@ -219,17 +220,25 @@ ExtendedValue substBase(const ExtendedValue &exv, mlir::Value base);
 /// example, an entity may have an address in memory that contains its value(s)
 /// as well as various attribute values that describe the shape and starting
 /// indices if it is an array entity.
-class ExtendedValue {
+class ExtendedValue : public details::matcher<ExtendedValue> {
 public:
+  using VT = std::variant<UnboxedValue, CharBoxValue, ArrayBoxValue,
+                          CharArrayBoxValue, BoxValue, ProcBoxValue>;
+
   template <typename A>
   constexpr ExtendedValue(A &&box) : box{std::forward<A>(box)} {}
 
+  template <typename A>
+  constexpr const A *getBoxOf() const {
+    return std::get_if<A>(&box);
+  }
+
   constexpr const CharBoxValue *getCharBox() const {
-    return std::get_if<CharBoxValue>(&box);
+    return getBoxOf<CharBoxValue>();
   }
 
   constexpr const UnboxedValue *getUnboxed() const {
-    return std::get_if<UnboxedValue>(&box);
+    return getBoxOf<UnboxedValue>();
   }
 
   /// LLVM style debugging of extended values
@@ -241,10 +250,10 @@ class ExtendedValue {
   friend mlir::Value getLen(const ExtendedValue &exv);
   friend ExtendedValue substBase(const ExtendedValue &exv, mlir::Value base);
 
+  const VT &matchee() const { return box; }
+
 private:
-  std::variant<UnboxedValue, CharBoxValue, ArrayBoxValue, CharArrayBoxValue,
-               BoxValue, ProcBoxValue>
-      box;
+  VT box;
 };
 } // namespace fir
 

flang/include/flang/Optimizer/Support/Matcher.h

@@ -0,0 +1,34 @@
+//===-- Optimizer/Support/Matcher.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.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef OPTIMIZER_SUPPORT_MATCHER_H
+#define OPTIMIZER_SUPPORT_MATCHER_H
+
+#include <variant>
+
+// Boilerplate CRTP class for a simplified type-casing syntactic sugar.
+namespace fir::details {
+// clang-format off
+template<class... Ts> struct matches : Ts... { using Ts::operator()...; };
+template<class... Ts> matches(Ts...) -> matches<Ts...>;
+template<typename N> struct matcher {
+  template<typename... Ts> auto match(Ts... ts) {
+    return std::visit(matches{ts...}, static_cast<N*>(this)->matchee());
+  }
+  template<typename... Ts> auto match(Ts... ts) const {
+    return std::visit(matches{ts...}, static_cast<N const*>(this)->matchee());
+  }
+};
+// clang-format on
+} // namespace fir::details
+
+#endif // OPTIMIZER_SUPPORT_MATCHER_H

flang/lib/Lower/ConvertExpr.cpp

@@ -844,6 +844,8 @@ class ExprLowering {
              &con) {
     // TODO:
     // - derived type constant
+    //   ?? derived type cannot match the above template, can it? looks like it
+    //   would have to be Constant<SomeType<TC::Derived>> instead
     if (con.Rank() > 0)
       return genArrayLit(con);
     auto opt = con.GetScalarValue();
@@ -1263,16 +1265,16 @@ class ExprLowering {
     return std::visit([&](const auto &x) { return genval(x); }, des.u);
   }
 
-  // call a function
   template <typename A>
-  fir::ExtendedValue gen(const Fortran::evaluate::FunctionRef<A> &funRef) {
-    TODO();
-  }
-  template <typename A>
-  fir::ExtendedValue genval(const Fortran::evaluate::FunctionRef<A> &funRef) {
-    TODO(); // Derived type functions (user + intrinsics)
+  fir::ExtendedValue gen(const Fortran::evaluate::FunctionRef<A> &func) {
+    auto resTy = converter.genType(*func.proc().GetSymbol());
+    auto retVal = genProcedureRef(func, llvm::ArrayRef<mlir::Type>{resTy});
+    auto mem = builder.create<fir::AllocaOp>(getLoc(), resTy);
+    builder.create<fir::StoreOp>(getLoc(), fir::getBase(retVal), mem);
+    return mem.getResult();
   }
 
+  /// Generate a call to an intrinsic function.
   fir::ExtendedValue
   genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef,
                   const Fortran::evaluate::SpecificIntrinsic &intrinsic,
@@ -1289,11 +1291,10 @@ class ExprLowering {
     // lowering facility should control argument lowering.
     for (const auto &arg : procRef.arguments()) {
       if (auto *expr = Fortran::evaluate::UnwrapExpr<
-              Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>(arg)) {
+              Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>(arg))
         operands.emplace_back(genval(*expr));
-      } else {
-        operands.emplace_back(mlir::Value{}); // absent optional
-      }
+      else
+        operands.emplace_back(fir::UnboxedValue{}); // absent optional
     }
     // Let the intrinsic library lower the intrinsic procedure call
     llvm::StringRef name = intrinsic.name;
@@ -1340,15 +1341,9 @@ class ExprLowering {
       // allowed, probably because nobody thought of restricting this usage.
       // gfortran/ifort compiles this.
       assert(expr && "assumed type used as statement function argument");
-      auto argVal = genval(*expr);
-      if (auto *charBox = argVal.getCharBox()) {
-        symMap.addCharSymbol(dummySymbol, charBox->getBuffer(),
-                             charBox->getLen());
-      } else {
-        // As per Fortran 2018 C1580, statement function arguments can only be
-        // scalars, so just pass the base address.
-        symMap.addSymbol(dummySymbol, fir::getBase(argVal));
-      }
+      // As per Fortran 2018 C1580, statement function arguments can only be
+      // scalars, so just pass the box with the address.
+      symMap.addSymbol(dummySymbol, genExtAddr(*expr));
     }
     auto result = genval(details.stmtFunction().value());
     LLVM_DEBUG(llvm::errs() << "stmt-function: " << result << '\n');
@@ -1565,7 +1560,12 @@ class ExprLowering {
     if constexpr (inRefSet<std::decay_t<decltype(a)>>) {
       return gen(a);
     } else {
-      llvm_unreachable("expression error");
+      // Since `a` is not itself a valid referent, determine its value and
+      // create a temporary location for referencing.
+      auto val = fir::getBase(genval(a));
+      auto mem = builder.create<fir::AllocaOp>(getLoc(), val.getType());
+      builder.create<fir::StoreOp>(getLoc(), val, mem);
+      return mem.getResult();
     }
   }
 

flang/lib/Lower/IntrinsicCall.cpp

@@ -28,6 +28,8 @@
 #include <string_view>
 #include <utility>
 
+#define DEBUG_TYPE "flang-lower-intrinsic"
+
 #define PGMATH_DECLARE
 #include "../runtime/pgmath.h.inc"
 
@@ -1072,7 +1074,6 @@ mlir::Value IntrinsicLibrary::genFloor(mlir::Type resultType,
 mlir::Value IntrinsicLibrary::genIAnd(mlir::Type resultType,
                                       llvm::ArrayRef<mlir::Value> args) {
   assert(args.size() == 2);
-
   return builder.create<mlir::AndOp>(loc, args[0], args[1]);
 }
 
@@ -1083,22 +1084,29 @@ mlir::Value IntrinsicLibrary::genIchar(mlir::Type resultType,
   assert(args.size() >= 1 && args.size() <= 2);
 
   auto arg = args[0];
-  assert(Fortran::lower::CharacterExprHelper::isCharacter(arg.getType()) &&
+  auto argTy = arg.getType();
+  assert(Fortran::lower::CharacterExprHelper::isCharacter(argTy) &&
          "Error: Unhandled type passed to ICHAR");
-  Fortran::lower::CharacterExprHelper helper{builder, loc};
-  auto dataAndLen = helper.createUnboxChar(arg);
-  auto charType = helper.getCharacterType(arg.getType());
   mlir::Value charVal;
-  if (fir::isa_ref_type(dataAndLen.first.getType())) {
-    auto refType = builder.getRefType(charType);
-    auto charAddr = builder.createConvert(loc, refType, dataAndLen.first);
-    charVal = builder.create<fir::LoadOp>(loc, charType, charAddr);
+  if (auto charTy = argTy.dyn_cast<fir::CharacterType>()) {
+    assert(charTy.singleton());
+    charVal = arg;
+  } else if (auto seqTy = argTy.dyn_cast<fir::SequenceType>()) {
+    auto zero =
+        builder.createIntegerConstant(loc, builder.getIntegerType(32), 0);
+    charVal = builder.create<fir::ExtractValueOp>(loc, seqTy.getEleTy(), arg,
+                                                  mlir::ValueRange{zero});
   } else {
-    charVal = builder.create<fir::ExtractValueOp>(
-        loc, charType, dataAndLen.first,
-        llvm::ArrayRef<mlir::Value>{
-            builder.createIntegerConstant(loc, builder.getIntegerType(32), 0)});
+    using H = Fortran::lower::CharacterExprHelper;
+    H helper{builder, loc};
+    auto dataAndLen = helper.createUnboxChar(arg);
+    // Strip away any sequence type residual.
+    auto toTy =
+        builder.getRefType(H::getCharacterType(dataAndLen.first.getType()));
+    auto cast = builder.createConvert(loc, toTy, dataAndLen.first);
+    charVal = builder.create<fir::LoadOp>(loc, cast);
   }
+  LLVM_DEBUG(llvm::errs() << "ichar(" << charVal << ")\n");
   return builder.createConvert(loc, resultType, charVal);
 }
 

flang/lib/Lower/SymbolMap.h

@@ -172,6 +172,20 @@ struct SymbolBox {
 /// etc.
 class SymMap {
 public:
+  /// Add an extended value to the symbol table.
+  void addSymbol(semantics::SymbolRef sym, const fir::ExtendedValue &ext,
+                 bool force = false) {
+    ext.match([&](const fir::UnboxedValue &v) { addSymbol(sym, v, force); },
+              [&](const fir::CharBoxValue &v) { makeSym(sym, v, force); },
+              [&](const fir::ArrayBoxValue &v) { makeSym(sym, v, force); },
+              [&](const fir::CharArrayBoxValue &v) { makeSym(sym, v, force); },
+              [&](const fir::BoxValue &v) { makeSym(sym, v, force); },
+              [](auto) {
+                llvm::report_fatal_error(
+                    "box value should not be added to symbol table");
+              });
+  }
+
   /// Add a trivial symbol mapping to an address.
   void addSymbol(semantics::SymbolRef sym, mlir::Value value,
                  bool force = false) {

flang/lib/Optimizer/Dialect/FIRType.cpp

@@ -984,7 +984,8 @@ bool isa_box_type(mlir::Type t) {
 }
 
 bool isa_passbyref_type(mlir::Type t) {
-  return t.isa<ReferenceType>() || isa_box_type(t);
+  return t.isa<ReferenceType>() || isa_box_type(t) ||
+         t.isa<mlir::FunctionType>();
 }
 
 bool isa_aggregate(mlir::Type t) {