1//===-- lib/runtime/type-info.cpp -------------------------------*- C++ -*-===//
2//
3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4// See https://llvm.org/LICENSE.txt for license information.
5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6//
7//===----------------------------------------------------------------------===//
8
9#include "flang-rt/runtime/type-info.h"
10#include "flang-rt/runtime/terminator.h"
11#include "flang-rt/runtime/tools.h"
12#include <cstdio>
13
14namespace Fortran::runtime::typeInfo {
15
16RT_OFFLOAD_API_GROUP_BEGIN
17
18RT_API_ATTRS Fortran::common::optional<TypeParameterValue> Value::GetValue(
19 const Descriptor *descriptor) const {
20 switch (genre_) {
21 case Genre::Explicit:
22 return value_;
23 case Genre::LenParameter:
24 if (descriptor) {
25 if (const auto *addendum{descriptor->Addendum()}) {
26 return addendum->LenParameterValue(value_);
27 }
28 }
29 return Fortran::common::nullopt;
30 default:
31 return Fortran::common::nullopt;
32 }
33}
34
35RT_API_ATTRS std::size_t Component::GetElementByteSize(
36 const Descriptor &instance) const {
37 switch (category()) {
38 case TypeCategory::Integer:
39 case TypeCategory::Unsigned:
40 case TypeCategory::Real:
41 case TypeCategory::Logical:
42 return kind_;
43 case TypeCategory::Complex:
44 return 2 * kind_;
45 case TypeCategory::Character:
46 if (auto value{characterLen_.GetValue(&instance)}) {
47 return kind_ * *value;
48 }
49 break;
50 case TypeCategory::Derived:
51 if (const auto *type{derivedType()}) {
52 return type->sizeInBytes();
53 }
54 break;
55 }
56 return 0;
57}
58
59RT_API_ATTRS std::size_t Component::GetElements(
60 const Descriptor &instance) const {
61 std::size_t elements{1};
62 if (int rank{rank_}) {
63 if (const Value * boundValues{bounds()}) {
64 for (int j{0}; j < rank; ++j) {
65 TypeParameterValue lb{
66 boundValues[2 * j].GetValue(&instance).value_or(0)};
67 TypeParameterValue ub{
68 boundValues[2 * j + 1].GetValue(&instance).value_or(0)};
69 if (ub >= lb) {
70 elements *= ub - lb + 1;
71 } else {
72 return 0;
73 }
74 }
75 } else {
76 return 0;
77 }
78 }
79 return elements;
80}
81
82RT_API_ATTRS std::size_t Component::SizeInBytes(
83 const Descriptor &instance) const {
84 if (genre() == Genre::Data) {
85 return GetElementByteSize(instance) * GetElements(instance);
86 } else if (category() == TypeCategory::Derived) {
87 const DerivedType *type{derivedType()};
88 return Descriptor::SizeInBytes(
89 rank_, true, type ? type->LenParameters() : 0);
90 } else {
91 return Descriptor::SizeInBytes(rank_);
92 }
93}
94
95RT_API_ATTRS void Component::EstablishDescriptor(Descriptor &descriptor,
96 const Descriptor &container, Terminator &terminator) const {
97 ISO::CFI_attribute_t attribute{static_cast<ISO::CFI_attribute_t>(
98 genre_ == Genre::Allocatable ? CFI_attribute_allocatable
99 : genre_ == Genre::Pointer ? CFI_attribute_pointer
100 : CFI_attribute_other)};
101 TypeCategory cat{category()};
102 if (cat == TypeCategory::Character) {
103 std::size_t lengthInChars{0};
104 if (auto length{characterLen_.GetValue(&container)}) {
105 lengthInChars = static_cast<std::size_t>(*length);
106 } else {
107 RUNTIME_CHECK(
108 terminator, characterLen_.genre() == Value::Genre::Deferred);
109 }
110 descriptor.Establish(
111 kind_, lengthInChars, nullptr, rank_, nullptr, attribute);
112 } else if (cat == TypeCategory::Derived) {
113 if (const DerivedType * type{derivedType()}) {
114 descriptor.Establish(*type, nullptr, rank_, nullptr, attribute);
115 } else { // unlimited polymorphic
116 descriptor.Establish(TypeCode{TypeCategory::Derived, 0}, 0, nullptr,
117 rank_, nullptr, attribute, true);
118 }
119 } else {
120 descriptor.Establish(cat, kind_, nullptr, rank_, nullptr, attribute);
121 }
122 if (rank_ && genre_ != Genre::Allocatable && genre_ != Genre::Pointer) {
123 const typeInfo::Value *boundValues{bounds()};
124 RUNTIME_CHECK(terminator, boundValues != nullptr);
125 auto byteStride{static_cast<SubscriptValue>(descriptor.ElementBytes())};
126 for (int j{0}; j < rank_; ++j) {
127 auto lb{boundValues++->GetValue(&container)};
128 auto ub{boundValues++->GetValue(&container)};
129 RUNTIME_CHECK(terminator, lb.has_value() && ub.has_value());
130 Dimension &dim{descriptor.GetDimension(j)};
131 dim.SetBounds(*lb, *ub);
132 dim.SetByteStride(byteStride);
133 byteStride *= dim.Extent();
134 }
135 }
136}
137
138RT_API_ATTRS void Component::CreatePointerDescriptor(Descriptor &descriptor,
139 const Descriptor &container, Terminator &terminator,
140 const SubscriptValue *subscripts) const {
141 RUNTIME_CHECK(terminator, genre_ == Genre::Data);
142 EstablishDescriptor(descriptor, container, terminator);
143 if (subscripts) {
144 descriptor.set_base_addr(container.Element<char>(subscripts) + offset_);
145 } else {
146 descriptor.set_base_addr(container.OffsetElement<char>() + offset_);
147 }
148 descriptor.raw().attribute = CFI_attribute_pointer;
149}
150
151RT_API_ATTRS const DerivedType *DerivedType::GetParentType() const {
152 if (hasParent_) {
153 const Descriptor &compDesc{component()};
154 const Component &component{*compDesc.OffsetElement<const Component>()};
155 return component.derivedType();
156 } else {
157 return nullptr;
158 }
159}
160
161RT_API_ATTRS const Component *DerivedType::FindDataComponent(
162 const char *compName, std::size_t compNameLen) const {
163 const Descriptor &compDesc{component()};
164 std::size_t n{compDesc.Elements()};
165 SubscriptValue at[maxRank];
166 compDesc.GetLowerBounds(at);
167 for (std::size_t j{0}; j < n; ++j, compDesc.IncrementSubscripts(at)) {
168 const Component *component{compDesc.Element<Component>(at)};
169 INTERNAL_CHECK(component != nullptr);
170 const Descriptor &nameDesc{component->name()};
171 if (nameDesc.ElementBytes() == compNameLen &&
172 Fortran::runtime::memcmp(
173 compName, nameDesc.OffsetElement(), compNameLen) == 0) {
174 return component;
175 }
176 }
177 const DerivedType *parent{GetParentType()};
178 return parent ? parent->FindDataComponent(compName, compNameLen) : nullptr;
179}
180
181RT_OFFLOAD_API_GROUP_END
182
183static void DumpScalarCharacter(
184 FILE *f, const Descriptor &desc, const char *what) {
185 if (desc.raw().version == CFI_VERSION &&
186 desc.type() == TypeCode{TypeCategory::Character, 1} &&
187 desc.ElementBytes() > 0 && desc.rank() == 0 &&
188 desc.OffsetElement() != nullptr) {
189 std::fwrite(ptr: desc.OffsetElement(), size: desc.ElementBytes(), n: 1, s: f);
190 } else {
191 std::fprintf(stream: f, format: "bad %s descriptor: ", what);
192 desc.Dump(f);
193 }
194}
195
196FILE *DerivedType::Dump(FILE *f) const {
197 std::fprintf(f, "DerivedType @ %p:\n", reinterpret_cast<const void *>(this));
198 const std::uint64_t *uints{reinterpret_cast<const std::uint64_t *>(this)};
199 for (int j{0}; j < 64; ++j) {
200 int offset{j * static_cast<int>(sizeof *uints)};
201 std::fprintf(f, " [+%3d](%p) 0x%016jx", offset,
202 reinterpret_cast<const void *>(&uints[j]),
203 static_cast<std::uintmax_t>(uints[j]));
204 if (offset == offsetof(DerivedType, binding_)) {
205 std::fputs(" <-- binding_\n", f);
206 } else if (offset == offsetof(DerivedType, name_)) {
207 std::fputs(" <-- name_\n", f);
208 } else if (offset == offsetof(DerivedType, sizeInBytes_)) {
209 std::fputs(" <-- sizeInBytes_\n", f);
210 } else if (offset == offsetof(DerivedType, uninstantiated_)) {
211 std::fputs(" <-- uninstantiated_\n", f);
212 } else if (offset == offsetof(DerivedType, kindParameter_)) {
213 std::fputs(" <-- kindParameter_\n", f);
214 } else if (offset == offsetof(DerivedType, lenParameterKind_)) {
215 std::fputs(" <-- lenParameterKind_\n", f);
216 } else if (offset == offsetof(DerivedType, component_)) {
217 std::fputs(" <-- component_\n", f);
218 } else if (offset == offsetof(DerivedType, procPtr_)) {
219 std::fputs(" <-- procPtr_\n", f);
220 } else if (offset == offsetof(DerivedType, special_)) {
221 std::fputs(" <-- special_\n", f);
222 } else if (offset == offsetof(DerivedType, specialBitSet_)) {
223 std::fputs(" <-- specialBitSet_\n", f);
224 } else if (offset == offsetof(DerivedType, hasParent_)) {
225 std::fputs(" <-- (flags)\n", f);
226 } else {
227 std::fputc('\n', f);
228 }
229 }
230 std::fputs(" name: ", f);
231 DumpScalarCharacter(f, name(), "DerivedType::name");
232 const Descriptor &bindingDesc{binding()};
233 std::fprintf(
234 f, "\n binding descriptor (byteSize 0x%zx): ", binding_.byteSize);
235 bindingDesc.Dump(f);
236 const Descriptor &compDesc{component()};
237 std::fputs("\n components:\n", f);
238 if (compDesc.raw().version == CFI_VERSION &&
239 compDesc.type() == TypeCode{TypeCategory::Derived, 0} &&
240 compDesc.ElementBytes() == sizeof(Component) && compDesc.rank() == 1) {
241 std::size_t n{compDesc.Elements()};
242 for (std::size_t j{0}; j < n; ++j) {
243 const Component &comp{*compDesc.ZeroBasedIndexedElement<Component>(j)};
244 std::fprintf(f, " [%3zd] ", j);
245 comp.Dump(f);
246 }
247 } else {
248 std::fputs(" bad descriptor: ", f);
249 compDesc.Dump(f);
250 }
251 const Descriptor &specialDesc{special()};
252 std::fprintf(
253 f, "\n special descriptor (byteSize 0x%zx): ", special_.byteSize);
254 specialDesc.Dump(f);
255 if (specialDesc.IsAllocated()) {
256 std::size_t specials{specialDesc.Elements()};
257 for (std::size_t j{0}; j < specials; ++j) {
258 std::fprintf(f, " [%3zd] ", j);
259 specialDesc.ZeroBasedIndexedElement<SpecialBinding>(j)->Dump(f);
260 }
261 }
262 return f;
263}
264
265FILE *Component::Dump(FILE *f) const {
266 std::fprintf(f, "Component @ %p:\n", reinterpret_cast<const void *>(this));
267 std::fputs(" name: ", f);
268 DumpScalarCharacter(f, name(), "Component::name");
269 if (genre_ == Genre::Data) {
270 std::fputs(" Data ", f);
271 } else if (genre_ == Genre::Pointer) {
272 std::fputs(" Pointer ", f);
273 } else if (genre_ == Genre::Allocatable) {
274 std::fputs(" Allocatable", f);
275 } else if (genre_ == Genre::Automatic) {
276 std::fputs(" Automatic ", f);
277 } else {
278 std::fprintf(f, " (bad genre 0x%x)", static_cast<int>(genre_));
279 }
280 std::fprintf(f, " category %d kind %d rank %d offset 0x%zx\n", category_,
281 kind_, rank_, static_cast<std::size_t>(offset_));
282 if (initialization_) {
283 std::fprintf(f, " initialization @ %p:\n",
284 reinterpret_cast<const void *>(initialization_));
285 for (int j{0}; j < 128; j += sizeof(std::uint64_t)) {
286 std::fprintf(f, " [%3d] 0x%016jx\n", j,
287 static_cast<std::uintmax_t>(
288 *reinterpret_cast<const std::uint64_t *>(initialization_ + j)));
289 }
290 }
291 return f;
292}
293
294FILE *SpecialBinding::Dump(FILE *f) const {
295 std::fprintf(
296 f, "SpecialBinding @ %p:\n", reinterpret_cast<const void *>(this));
297 switch (which_) {
298 case Which::ScalarAssignment:
299 std::fputs(" ScalarAssignment", f);
300 break;
301 case Which::ElementalAssignment:
302 std::fputs(" ElementalAssignment", f);
303 break;
304 case Which::ReadFormatted:
305 std::fputs(" ReadFormatted", f);
306 break;
307 case Which::ReadUnformatted:
308 std::fputs(" ReadUnformatted", f);
309 break;
310 case Which::WriteFormatted:
311 std::fputs(" WriteFormatted", f);
312 break;
313 case Which::WriteUnformatted:
314 std::fputs(" WriteUnformatted", f);
315 break;
316 case Which::ElementalFinal:
317 std::fputs(" ElementalFinal", f);
318 break;
319 case Which::AssumedRankFinal:
320 std::fputs(" AssumedRankFinal", f);
321 break;
322 default:
323 std::fprintf(f, " rank-%d final:",
324 static_cast<int>(which_) - static_cast<int>(Which::ScalarFinal));
325 break;
326 }
327 std::fprintf(f, " isArgDescriptorSet: 0x%x\n", isArgDescriptorSet_);
328 std::fprintf(f, " isTypeBound: 0x%x\n", isTypeBound_);
329 std::fprintf(f, " isArgContiguousSet: 0x%x\n", isArgContiguousSet_);
330 std::fprintf(f, " proc: %p\n", reinterpret_cast<void *>(proc_));
331 return f;
332}
333
334} // namespace Fortran::runtime::typeInfo
335

source code of flang-rt/lib/runtime/type-info.cpp