[flang] implement show_descriptor intrinsic, a non-standard extension

flang-rt/include/flang-rt/runtime/descriptor.h

@@ -510,7 +510,9 @@ class Descriptor {
 
   RT_API_ATTRS void Check() const;
 
-  void Dump(FILE * = stdout) const;
+  // When dumpRawType, dumps stringified CFI_type_*, otherwise
+  // try to canonicalize and print as a Fortran type.
+  void Dump(FILE * = stdout, bool dumpRawType = true) const;
 
   RT_API_ATTRS inline bool HasAddendum() const {
     return raw_.extra & _CFI_ADDENDUM_FLAG;

flang-rt/lib/runtime/descriptor.cpp

@@ -292,14 +292,168 @@ RT_API_ATTRS void Descriptor::Check() const {
   // TODO
 }
 
-void Descriptor::Dump(FILE *f) const {
+static const char *GetTypeStr(ISO::CFI_type_t type, bool dumpRawType) {
+  if (dumpRawType) {
+#define CASE(x) \
+  case (x): \
+    return #x;
+    switch (type) {
+      CASE(CFI_type_signed_char)
+      CASE(CFI_type_short)
+      CASE(CFI_type_int)
+      CASE(CFI_type_long)
+      CASE(CFI_type_long_long)
+      CASE(CFI_type_size_t)
+      CASE(CFI_type_int8_t)
+      CASE(CFI_type_int16_t)
+      CASE(CFI_type_int32_t)
+      CASE(CFI_type_int64_t)
+      CASE(CFI_type_int128_t)
+      CASE(CFI_type_int_least8_t)
+      CASE(CFI_type_int_least16_t)
+      CASE(CFI_type_int_least32_t)
+      CASE(CFI_type_int_least64_t)
+      CASE(CFI_type_int_least128_t)
+      CASE(CFI_type_int_fast8_t)
+      CASE(CFI_type_int_fast16_t)
+      CASE(CFI_type_int_fast32_t)
+      CASE(CFI_type_int_fast64_t)
+      CASE(CFI_type_int_fast128_t)
+      CASE(CFI_type_intmax_t)
+      CASE(CFI_type_intptr_t)
+      CASE(CFI_type_ptrdiff_t)
+      CASE(CFI_type_half_float)
+      CASE(CFI_type_bfloat)
+      CASE(CFI_type_float)
+      CASE(CFI_type_double)
+      CASE(CFI_type_extended_double)
+      CASE(CFI_type_long_double)
+      CASE(CFI_type_float128)
+      CASE(CFI_type_half_float_Complex)
+      CASE(CFI_type_bfloat_Complex)
+      CASE(CFI_type_float_Complex)
+      CASE(CFI_type_double_Complex)
+      CASE(CFI_type_extended_double_Complex)
+      CASE(CFI_type_long_double_Complex)
+      CASE(CFI_type_float128_Complex)
+      CASE(CFI_type_Bool)
+      CASE(CFI_type_char)
+      CASE(CFI_type_cptr)
+      CASE(CFI_type_struct)
+      CASE(CFI_type_char16_t)
+      CASE(CFI_type_char32_t)
+      CASE(CFI_type_uint8_t)
+      CASE(CFI_type_uint16_t)
+      CASE(CFI_type_uint32_t)
+      CASE(CFI_type_uint64_t)
+      CASE(CFI_type_uint128_t)
+    }
+#undef CASE
+    return nullptr;
+  }
+  TypeCode code{type};
+
+  if (!code.IsValid())
+    return "invalid";
+
+  common::optional<std::pair<TypeCategory, int>> categoryAndKind =
+      code.GetCategoryAndKind();
+  if (!categoryAndKind)
+    return nullptr;
+
+  TypeCategory tcat;
+  int kind;
+  std::tie(tcat, kind) = *categoryAndKind;
+
+#define CASE(cat, k) \
+  case (k): \
+    return #cat "(kind=" #k ")";
+  switch (tcat) {
+  case TypeCategory::Integer:
+    switch (kind) {
+      CASE(INTEGER, 1)
+      CASE(INTEGER, 2)
+      CASE(INTEGER, 4)
+      CASE(INTEGER, 8)
+      CASE(INTEGER, 16)
+    }
+    break;
+  case TypeCategory::Unsigned:
+    switch (kind) {
+      CASE(UNSIGNED, 1)
+      CASE(UNSIGNED, 2)
+      CASE(UNSIGNED, 4)
+      CASE(UNSIGNED, 8)
+      CASE(UNSIGNED, 16)
+    }
+    break;
+  case TypeCategory::Real:
+    switch (kind) {
+      CASE(REAL, 2)
+      CASE(REAL, 3)
+      CASE(REAL, 4)
+      CASE(REAL, 8)
+      CASE(REAL, 10)
+      CASE(REAL, 16)
+    }
+    break;
+  case TypeCategory::Complex:
+    switch (kind) {
+      CASE(COMPLEX, 2)
+      CASE(COMPLEX, 3)
+      CASE(COMPLEX, 4)
+      CASE(COMPLEX, 8)
+      CASE(COMPLEX, 10)
+      CASE(COMPLEX, 16)
+    }
+    break;
+  case TypeCategory::Character:
+    switch (kind) {
+      CASE(CHARACTER, 1)
+      CASE(CHARACTER, 2)
+      CASE(CHARACTER, 4)
+    }
+    break;
+  case TypeCategory::Logical:
+    switch (kind) {
+      CASE(LOGICAL, 1)
+      CASE(LOGICAL, 2)
+      CASE(LOGICAL, 4)
+      CASE(LOGICAL, 8)
+    }
+    break;
+  case TypeCategory::Derived:
+    return "DERIVED";
+  }
+#undef CASE
+  return nullptr;
+}
+
+void Descriptor::Dump(FILE *f, bool dumpRawType) const {
   std::fprintf(f, "Descriptor @ %p:\n", reinterpret_cast<const void *>(this));
   std::fprintf(f, "  base_addr %p\n", raw_.base_addr);
-  std::fprintf(f, "  elem_len  %zd\n", static_cast<std::size_t>(raw_.elem_len));
+  std::fprintf(f, "  elem_len  %zd\n", ElementBytes());
   std::fprintf(f, "  version   %d\n", static_cast<int>(raw_.version));
-  std::fprintf(f, "  rank      %d\n", static_cast<int>(raw_.rank));
-  std::fprintf(f, "  type      %d\n", static_cast<int>(raw_.type));
-  std::fprintf(f, "  attribute %d\n", static_cast<int>(raw_.attribute));
+  if (rank() > 0) {
+    std::fprintf(f, "  rank      %d\n", rank());
+  } else {
+    std::fprintf(f, "  scalar\n");
+  }
+  int ty = static_cast<int>(raw_.type);
+  if (const char *tyStr = GetTypeStr(raw_.type, dumpRawType)) {
+    std::fprintf(f, "  type      %d \"%s\"\n", ty, tyStr);
+  } else {
+    std::fprintf(f, "  type      %d\n", ty);
+  }
+  int attr = static_cast<int>(raw_.attribute);
+  if (IsPointer()) {
+    std::fprintf(f, "  attribute %d (pointer) \n", attr);
+  } else if (IsAllocatable()) {
+    std::fprintf(f, "  attribute %d (allocatable)\n", attr);
+  } else {
+    std::fprintf(f, "  attribute %d\n", attr);
+  }
+
   std::fprintf(f, "  extra     %d\n", static_cast<int>(raw_.extra));
   std::fprintf(f, "    addendum  %d\n", static_cast<int>(HasAddendum()));
   std::fprintf(f, "    alloc_idx %d\n", static_cast<int>(GetAllocIdx()));

flang-rt/lib/runtime/extensions.cpp

@@ -398,6 +398,14 @@ std::int64_t RTNAME(time)() { return time(nullptr); }
 // MCLOCK: returns accumulated CPU time in ticks
 std::int32_t FORTRAN_PROCEDURE_NAME(mclock)() { return std::clock(); }
 
+void RTNAME(ShowDescriptor)(const Fortran::runtime::Descriptor *descr) {
+  if (descr) {
+    descr->Dump(stderr, /*dumpRawType=*/false);
+  } else {
+    std::fprintf(stderr, "NULL\n");
+  }
+}
+
 // Extension procedures related to I/O
 
 namespace io {

flang-rt/unittests/Runtime/Descriptor.cpp

@@ -9,6 +9,7 @@
 #include "flang-rt/runtime/descriptor.h"
 #include "tools.h"
 #include "gtest/gtest.h"
+#include <regex>
 
 using namespace Fortran::runtime;
 
@@ -158,3 +159,115 @@ TEST(Descriptor, FixedStride) {
   EXPECT_TRUE(descriptor.IsContiguous());
   EXPECT_EQ(descriptor.FixedStride().value_or(-666), 0);
 }
+
+static std::string getAddrFilteredContent(FILE *fin) {
+  rewind(fin);
+  std::ostringstream content;
+  char buffer[1024];
+  size_t bytes_read;
+  while ((bytes_read = fread(buffer, 1, sizeof(buffer), fin)) > 0) {
+    content.write(buffer, bytes_read);
+  }
+  return std::regex_replace(
+      content.str(), std::regex("(0x[0-9a-fA-F]*)"), "[address]");
+}
+
+TEST(Descriptor, Dump) {
+  StaticDescriptor<4> staticDesc[2];
+  Descriptor &descriptor{staticDesc[0].descriptor()};
+  using Type = std::int32_t;
+  Type data[8][8][8];
+  constexpr int four{static_cast<int>(sizeof data[0][0][0])};
+  TypeCode integer{TypeCategory::Integer, four};
+  // Scalar
+  descriptor.Establish(integer, four, data, 0);
+  FILE *tmpf = tmpfile();
+  ASSERT_TRUE(tmpf) << "tmpfile returned NULL";
+  auto resetTmpFile = [tmpf]() {
+    rewind(tmpf);
+    ftruncate(fileno(tmpf), 0);
+  };
+
+  descriptor.Dump(tmpf, /*dumpRawType=*/false);
+  // also dump as CFI type
+  descriptor.Dump(tmpf, /*dumpRawType=*/true);
+  std::string output = getAddrFilteredContent(tmpf);
+  ASSERT_STREQ(output.c_str(),
+      "Descriptor @ [address]:\n"
+      "  base_addr [address]\n"
+      "  elem_len  4\n"
+      "  version   20240719\n"
+      "  scalar\n"
+      "  type      9 \"INTEGER(kind=4)\"\n"
+      "  attribute 0\n"
+      "  extra     0\n"
+      "    addendum  0\n"
+      "    alloc_idx 0\n"
+      "Descriptor @ [address]:\n"
+      "  base_addr [address]\n"
+      "  elem_len  4\n"
+      "  version   20240719\n"
+      "  scalar\n"
+      "  type      9 \"CFI_type_int32_t\"\n"
+      "  attribute 0\n"
+      "  extra     0\n"
+      "    addendum  0\n"
+      "    alloc_idx 0\n");
+
+  // Contiguous matrix (0:7, 0:7)
+  SubscriptValue extent[3]{8, 8, 8};
+  descriptor.Establish(integer, four, data, 2, extent);
+  resetTmpFile();
+  descriptor.Dump(tmpf, /*dumpRawType=*/false);
+  output = getAddrFilteredContent(tmpf);
+  ASSERT_STREQ(output.c_str(),
+      "Descriptor @ [address]:\n"
+      "  base_addr [address]\n"
+      "  elem_len  4\n"
+      "  version   20240719\n"
+      "  rank      2\n"
+      "  type      9 \"INTEGER(kind=4)\"\n"
+      "  attribute 0\n"
+      "  extra     0\n"
+      "    addendum  0\n"
+      "    alloc_idx 0\n"
+      "  dim[0] lower_bound 0\n"
+      "         extent      8\n"
+      "         sm          4\n"
+      "  dim[1] lower_bound 0\n"
+      "         extent      8\n"
+      "         sm          32\n");
+
+  TypeCode real{TypeCategory::Real, four};
+  // Discontiguous real 3-D array (0:7, 0:6:2, 0:6:2)
+  descriptor.Establish(real, four, data, 3, extent);
+  descriptor.GetDimension(1).SetExtent(4);
+  descriptor.GetDimension(1).SetByteStride(8 * 2 * four);
+  descriptor.GetDimension(2).SetExtent(4);
+  descriptor.GetDimension(2).SetByteStride(8 * 8 * 2 * four);
+
+  resetTmpFile();
+  descriptor.Dump(tmpf, /*dumpRawType=*/false);
+  output = getAddrFilteredContent(tmpf);
+  ASSERT_STREQ(output.c_str(),
+      "Descriptor @ [address]:\n"
+      "  base_addr [address]\n"
+      "  elem_len  4\n"
+      "  version   20240719\n"
+      "  rank      3\n"
+      "  type      27 \"REAL(kind=4)\"\n"
+      "  attribute 0\n"
+      "  extra     0\n"
+      "    addendum  0\n"
+      "    alloc_idx 0\n"
+      "  dim[0] lower_bound 0\n"
+      "         extent      8\n"
+      "         sm          4\n"
+      "  dim[1] lower_bound 0\n"
+      "         extent      4\n"
+      "         sm          64\n"
+      "  dim[2] lower_bound 0\n"
+      "         extent      4\n"
+      "         sm          512\n");
+  fclose(tmpf);
+}

flang/docs/Intrinsics.md

@@ -1379,3 +1379,45 @@ This is prefixed by `STRING`, a colon and a space.
 - **Standard:** GNU extension
 - **Class:** subroutine
 - **Syntax:** `CALL PERROR(STRING)`
+
+### Non-Standard Intrinsics: SHOW_DESCRIPTOR
+
+#### Description
+`SHOW_DESCRIPTOR(VAR)` prints (on the C stderr stream) a contents of a descriptor for the variable VAR,
+which can be of any type and rank, including scalars.
+Requires use of flang_debug module.
+
+Here is an example of its output:
+```
+Descriptor @ 0x7ffe506fc368:
+  base_addr 0x55944caef0f0
+  elem_len  4
+  version   20240719
+  rank      1
+  type      9 "INTEGER(kind=4)"
+  attribute 2 (allocatable)
+  extra     0
+    addendum  0
+    alloc_idx 0
+  dim[0] lower_bound 1
+         extent      5
+         sm          4
+```
+
+#### Usage and Info
+- **Standard:** flang extension
+- **Class:** subroutine
+- **Syntax:** `CALL show_descriptor(VAR)`
+
+#### Example
+```Fortran
+subroutine test
+  use flang_debug
+  implicit none
+  character(len=9) :: c = 'Hey buddy'
+  integer :: a(5)
+  call show_descriptor(c)
+  call show_descriptor(c(1:3))
+  call show_descriptor(a)
+end subroutine test
+```

flang/include/flang/Optimizer/Builder/IntrinsicCall.h

@@ -408,6 +408,7 @@ struct IntrinsicLibrary {
   template <typename Shift>
   mlir::Value genShift(mlir::Type resultType, llvm::ArrayRef<mlir::Value>);
   mlir::Value genShiftA(mlir::Type resultType, llvm::ArrayRef<mlir::Value>);
+  void genShowDescriptor(llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genSign(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genSind(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genSinpi(mlir::Type, llvm::ArrayRef<mlir::Value>);

flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h

@@ -109,6 +109,9 @@ void genSleep(fir::FirOpBuilder &builder, mlir::Location loc,
 mlir::Value genChdir(fir::FirOpBuilder &builder, mlir::Location loc,
                      mlir::Value name);
 
+/// generate dump of a descriptor
+void genShowDescriptor(fir::FirOpBuilder &builder, mlir::Location loc,
+                       mlir::Value descriptor);
 } // namespace runtime
 } // namespace fir