[flang] [llvm] [flang/flang-rt] Implement show_descriptor intrinsic, a non-standard extension. (PR #170389)
via llvm-commits
llvm-commits at lists.llvm.org
Tue Dec 2 15:19:28 PST 2025
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-fir-hlfir
@llvm/pr-subscribers-flang-semantics
Author: Valery Dmitriev (valerydmit)
<details>
<summary>Changes</summary>
This is a reapply the original patch (#<!-- -->169137) with the flang-rt unit test changes limiting it to linux platform only.
Additionally accommodated style changes from Peter Klausler (#<!-- -->170227)
show_descriptor intrinsic prints details of a descriptor (extended Fortran pointer).
It accepts a descriptor for any type and rank, including scalars.
Requires use of flang_debug module.
Example:
program test
use flang_debug
implicit none
integer :: a(4) = (/ 1,3,5,7 /)
call show_descriptor(a(1:3))
end program test
and its output:
Descriptor @ 0x7ffe01ec6a98:
base_addr 0x563b7035103c
elem_len 4
version 20240719
rank 1
type 9 "INTEGER(kind=4)"
attribute 0
extra 0
addendum 0
alloc_idx 0
---
Patch is 40.29 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/170389.diff
15 Files Affected:
- (modified) flang-rt/include/flang-rt/runtime/descriptor.h (+3-1)
- (modified) flang-rt/lib/runtime/descriptor.cpp (+152-5)
- (modified) flang-rt/lib/runtime/extensions.cpp (+9)
- (modified) flang-rt/unittests/Runtime/Descriptor.cpp (+123)
- (modified) flang/docs/Intrinsics.md (+43)
- (modified) flang/include/flang/Optimizer/Builder/IntrinsicCall.h (+1)
- (modified) flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h (+4-1)
- (modified) flang/include/flang/Runtime/extensions.h (+8)
- (modified) flang/lib/Evaluate/intrinsics.cpp (+2)
- (modified) flang/lib/Optimizer/Builder/IntrinsicCall.cpp (+14)
- (modified) flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp (+7)
- (modified) flang/module/__fortran_builtins.f90 (+3)
- (added) flang/module/flang_debug.f90 (+14)
- (added) flang/test/Lower/Intrinsics/show_descriptor.f90 (+241)
- (modified) flang/tools/f18/CMakeLists.txt (+1)
``````````diff
diff --git a/flang-rt/include/flang-rt/runtime/descriptor.h b/flang-rt/include/flang-rt/runtime/descriptor.h
index ff7ec050d32c7..40e30e3bf783f 100644
--- a/flang-rt/include/flang-rt/runtime/descriptor.h
+++ b/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;
diff --git a/flang-rt/lib/runtime/descriptor.cpp b/flang-rt/lib/runtime/descriptor.cpp
index 5ede5f9d9f9ed..75bea976e2087 100644
--- a/flang-rt/lib/runtime/descriptor.cpp
+++ b/flang-rt/lib/runtime/descriptor.cpp
@@ -292,14 +292,161 @@ 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)
+ default:
+ return nullptr;
+ }
+#undef CASE
+ }
+ TypeCode code{type};
+ if (!code.IsValid()) {
+ return "invalid";
+ }
+ auto categoryAndKind{code.GetCategoryAndKind()};
+ if (!categoryAndKind) {
+ return nullptr;
+ }
+ TypeCategory tcat{categoryAndKind->first};
+ int kind{categoryAndKind->second};
+
+#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));
+ std::fprintf(f, " rank %d%s\n", rank(), rank() ? "" : " (scalar)");
+ 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()));
diff --git a/flang-rt/lib/runtime/extensions.cpp b/flang-rt/lib/runtime/extensions.cpp
index c110b0381890c..108d7b1923b99 100644
--- a/flang-rt/lib/runtime/extensions.cpp
+++ b/flang-rt/lib/runtime/extensions.cpp
@@ -467,6 +467,15 @@ void FORTRAN_PROCEDURE_NAME(srand)(int *seed) {
rand_seed_lock.Drop();
}
+
+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 {
diff --git a/flang-rt/unittests/Runtime/Descriptor.cpp b/flang-rt/unittests/Runtime/Descriptor.cpp
index 4a7bb43a492af..0f6dd697e1e33 100644
--- a/flang-rt/unittests/Runtime/Descriptor.cpp
+++ b/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,125 @@ TEST(Descriptor, FixedStride) {
EXPECT_TRUE(descriptor.IsContiguous());
EXPECT_EQ(descriptor.FixedStride().value_or(-666), 0);
}
+
+// The test below uses file operations that have nuances across multiple
+// platforms. Hence limit coverage by linux only unless wider coverage
+// should be required.
+#if defined(__linux__) && !defined(__ANDROID__)
+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 = nullptr;
+ tmpf = tmpfile();
+ ASSERT_TRUE(tmpf) << "tmpfile returned NULL";
+ auto resetTmpFile = [tmpf]() {
+ fflush(tmpf);
+ rewind(tmpf);
+ ftruncate(fileno(tmpf), 0);
+ };
+
+ auto getAddrFilteredContent = [tmpf]() -> std::string {
+ rewind(tmpf);
+ std::ostringstream content;
+ char buffer[1024];
+ size_t bytes_read;
+ while ((bytes_read = fread(buffer, 1, sizeof(buffer), tmpf)) > 0) {
+ content.write(buffer, bytes_read);
+ }
+
+ return std::regex_replace(
+ std::regex_replace(content.str(), std::regex("Descriptor @.*:"),
+ "Descriptor @ [addr]:"),
+ std::regex("base_addr .*"), "base_addr [addr]");
+ };
+
+ descriptor.Dump(tmpf, /*dumpRawType=*/false);
+ // also dump as CFI type
+ descriptor.Dump(tmpf, /*dumpRawType=*/true);
+ std::string output = getAddrFilteredContent();
+ ASSERT_STREQ(output.c_str(),
+ "Descriptor @ [addr]:\n"
+ " base_addr [addr]\n"
+ " elem_len 4\n"
+ " version 20240719\n"
+ " rank 0 (scalar)\n"
+ " type 9 \"INTEGER(kind=4)\"\n"
+ " attribute 0\n"
+ " extra 0\n"
+ " addendum 0\n"
+ " alloc_idx 0\n"
+ "Descriptor @ [addr]:\n"
+ " base_addr [addr]\n"
+ " elem_len 4\n"
+ " version 20240719\n"
+ " rank 0 (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();
+ ASSERT_STREQ(output.c_str(),
+ "Descriptor @ [addr]:\n"
+ " base_addr [addr]\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();
+ ASSERT_STREQ(output.c_str(),
+ "Descriptor @ [addr]:\n"
+ " base_addr [addr]\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);
+}
+#endif // defined(__linux__) && !defined(__ANDROID__)
diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index 31bead9f8bfdc..6451fc48fc6a2 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -1414,6 +1414,7 @@ This is prefixed by `STRING`, a colon and a space.
- **Class:** subroutine
- **Syntax:** `CALL PERROR(STRING)`
+<<<<<<< HEAD
### Non-Standard Intrinsics: SRAND
#### Description
@@ -1455,3 +1456,45 @@ The return value is of `REAL` type with the default kind.
- **Standard:** GNU extension
- **Class:** function
- **Syntax:** `RESULT = RAND(I)`
+
+### 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
+```
diff --git a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
index 0ae9177f98fd8..b248106b51101 100644
--- a/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
+++ b/flang/include/flang/Optimizer/Builder/IntrinsicCall.h
@@ -413,6 +413,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>);
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h
index 30c3189366cec..1f751827309a4 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h
@@ -111,12 +111,15 @@ void genSleep(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value genChdir(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value name);
-
mlir::Value genIrand(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value i);
mlir::Value genRand(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value i);
+/// generate dump of a descriptor
+void genShowDescriptor(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value descriptor);
+
} // namespace runtime
} // namespace fir
diff --git a/flang/include/flang/Runtime/extensions.h b/flang/include/flang/Runtime/extensions.h
index f2765a5987ea1..40ce77112d183 100644
--- a/flang/include/flang/Runtime/extensions.h
+++ b/flang/include/flang/Runtime/extensions.h
@@ -25,6 +25,11 @@ typedef std::uint32_t gid_t;
#else
#include "sys/types.h" //pid_t
#endif
+namespace Fortran {
+namespace runtime {
+class Descriptor;
+}
+} // namespace Fortran
extern "C" {
@@ -111,5 +116,8 @@ float RTNAME(Rand)(int *i, const char *sourceFile, int line);
// GNU extension subroutine SRAND(SEED)
void FORTRAN_PROCEDURE_NAME(srand)(int *seed);
+// flang extension subroutine SHOW_DESCRIPTOR(D)
+void RTNAME(ShowDescriptor)(const Fortran::runtime::Descriptor *descr);
+
} // extern "C"
#endif // FORTRAN_RUNTIME_EXTENSIONS_H_
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index bbcb766274e7f..d69400e0ec188 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1713,6 +1713,8 @@ static const IntrinsicInterface intrinsicSubroutine[]{
{}, Rank::scalar, IntrinsicClass::impureSubroutine},
{"second", {{"time", DefaultReal, Rank::scalar}}, {}, Rank::scalar,
IntrinsicClass::impureSubroutine},
+ {"__builtin_show_descriptor", {{"d", AnyData, Rank::anyOrAssumedRank}}, {},
+ Rank::elemental, IntrinsicClass::impureSubroutine},
{"system",
{{"command", DefaultChar, Rank::scalar},
{"exitstat", DefaultInt, Rank::scalar, Optionality::optional,
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index 3619e5bb942db..75a74eeb18417 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -727,6 +727,10 @@ static constexpr IntrinsicHandler handlers[]{
{"shifta", &I::genShiftA},
{"shiftl", &I::genShift<mlir::arith::ShLIOp>},
{"shiftr", &I::genShift<mlir::arith::ShRUIOp>},
+ {"show_descriptor",
+ &I::genShowDescriptor,
+ {{{"d", asBox}}},
+ /*isElemental=*/false},
{"sign", &I::genSign},
{"signal",
&I::genSignalSubroutine,
@@ -7884,6 +7888,16 @@ mlir::Value IntrinsicLibrary::genShiftA(mlir::Type resultType,
return result;
}
+void IntrinsicLibrary::genShowDescriptor(
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 1 && "expected single argument for show_descriptor");
+ const mlir::Value descriptor = fir::getBase(args[0]);
+
+ assert(fir::isa_box_type(descriptor.getType()) &&
+ "argument must have been lowered to box type");
+ fir::runtime::genShowDescriptor(builder, loc, descriptor);
+}
+
// SIGNAL
void IntrinsicLibrary::genSignalSubroutine(
llvm::ArrayRef<fir::ExtendedValue> args) {
diff --git a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp
index 4d366135c305f..a5f16f89b260a 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp
+++ b/flang/lib/Optimizer/Builder/Runtime/Intrinsics.cpp
@@ -494,3 +494,10 @@ mlir::Value fir::runtime::genRand(fir::FirOpBuilder &builder,
builder, loc, runtimeFuncTy, i, sourceFile, sourceLine);
return fir::CallOp::create(builder, loc, runtimeFunc, args).getResult(0);
}
+
+void fir::runtime::genShowDescriptor(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value descAddr) {
+ mlir::func::FuncOp func{
+ fir::runtime::getRuntimeFunc<mkRTKey(ShowDescriptor)>(loc, builder)};
+ fir::CallOp::create(builder, loc, func, descAddr);
+}
diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90
index 4d134fa4b62b1..a9b60508785db 100644
--- a/flang/module/__fortran_builtins.f90
+++ b/flang/module/__fortran_builtins.f90
@@ -28,6 +28,9 @@
intrinsic :: __builtin_c_f_pointer
public :: __builtin_c_f_pointer
+ intrinsic :: __builtin_show_descriptor
+ public :: __builtin_show_descriptor
+
intrinsic :: sizeof ! extension
public :: sizeof
diff --git a/flang/module/flang_debug.f90 b/flang/module/flang_debug.f90
new file mode 100644
index 0000000000000..baab3b2477f49
--- /dev/null
+++ b/flang/module/flang_debug.f90
@@ -0,0 +1,14 @@
+!===-- module/flang_debug.f90 ----------------------------------------------===!
+!
+! 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
+!
+!===------------------------------------------------------------------------===!
+
+module flang_debug
+
+ use __fortran_builtins, only: &
+ show_descriptor => __builtin_show_descriptor
+
+end module flang_debug
diff --git a/flang/test/Lower/Intrinsics/show_descriptor.f90 b/flang/test/Lower/Intrinsics/show_descriptor.f90
new file mode 100644
index 0000000000000..a0b8d3eb4348f
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/show_descriptor.f90
@@ -0,0 +1,241 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+module test_show_descriptor
+use flang_debug
+contains
+subroutine test_int
+! CHECK-LABEL: func.func @_QMtest_show_descriptorPtest_int() {
+ implicit none
+ integer :: n
+ integer,allocatable :: a(:)
+ n = 5
+ allocate(a(n))
+! CHECK: %[[C3:.*]] = arith.constant 3 : index
+! CHECK: %[[C1:.*]] = arith.constant 1 : index
+! CHECK: %[[C5:.*]] = arith.constant 5 : i32
+! CHECK: %[[C0:.*]] = arith.constant 0 : index
+! CHECK: %[[DUMMY_SCOPE_0:.*]] = fir.dummy_scope : !fir.dscope
+! CHECK: %[[ALLOCA_0:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {bindc_name = "a", uniq_name = "_QMtest_show_descriptorFtest_intEa"}
+! CHECK: %[[ZERO_BITS_0:.*]] = fir.zero_bits !fir.heap<!fir.array<?xi32>>
+! CHECK: %[[SHAPE_0:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1>
+! CHECK: %[[EMBOX_0:.*]] = fir.embox %[[ZERO_BITS_0]](%[[SHAPE_0]]) : (!fir.heap<!fir.array<?xi32>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?xi32>>>
+! CHECK: fir.store %[[EMBOX_0]] to %[[ALLOCA_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+! CHECK: %[[DECLARE_0:.*]] = fir.declare %[[ALLOCA_0]] {fortr...
[truncated]
``````````
</details>
https://github.com/llvm/llvm-project/pull/170389
More information about the llvm-commits
mailing list