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

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