1//===-- runtime/descriptor.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 "flang/Runtime/descriptor.h"
10#include "ISO_Fortran_util.h"
11#include "derived.h"
12#include "memory.h"
13#include "stat.h"
14#include "terminator.h"
15#include "tools.h"
16#include "type-info.h"
17#include <cassert>
18#include <cstdlib>
19#include <cstring>
20
21namespace Fortran::runtime {
22
23RT_OFFLOAD_API_GROUP_BEGIN
24
25RT_API_ATTRS Descriptor::Descriptor(const Descriptor &that) { *this = that; }
26
27RT_API_ATTRS Descriptor &Descriptor::operator=(const Descriptor &that) {
28 std::memcpy(this, &that, that.SizeInBytes());
29 return *this;
30}
31
32RT_API_ATTRS void Descriptor::Establish(TypeCode t, std::size_t elementBytes,
33 void *p, int rank, const SubscriptValue *extent,
34 ISO::CFI_attribute_t attribute, bool addendum) {
35 Terminator terminator{__FILE__, __LINE__};
36 int cfiStatus{ISO::VerifyEstablishParameters(&raw_, p, attribute, t.raw(),
37 elementBytes, rank, extent, /*external=*/false)};
38 if (cfiStatus != CFI_SUCCESS) {
39 terminator.Crash(
40 "Descriptor::Establish: CFI_establish returned %d for CFI_type_t(%d)",
41 cfiStatus, t.raw());
42 }
43 ISO::EstablishDescriptor(
44 &raw_, p, attribute, t.raw(), elementBytes, rank, extent);
45 if (elementBytes == 0) {
46 raw_.elem_len = 0;
47 // Reset byte strides of the dimensions, since EstablishDescriptor()
48 // only does that when the base address is not nullptr.
49 for (int j{0}; j < rank; ++j) {
50 GetDimension(j).SetByteStride(0);
51 }
52 }
53 raw_.f18Addendum = addendum;
54 DescriptorAddendum *a{Addendum()};
55 RUNTIME_CHECK(terminator, addendum == (a != nullptr));
56 if (a) {
57 new (a) DescriptorAddendum{};
58 }
59}
60
61namespace {
62template <TypeCategory CAT, int KIND> struct TypeSizeGetter {
63 constexpr RT_API_ATTRS std::size_t operator()() const {
64 CppTypeFor<CAT, KIND> arr[2];
65 return sizeof arr / 2;
66 }
67};
68} // namespace
69
70RT_API_ATTRS std::size_t Descriptor::BytesFor(TypeCategory category, int kind) {
71 Terminator terminator{__FILE__, __LINE__};
72 return ApplyType<TypeSizeGetter, std::size_t>(category, kind, terminator);
73}
74
75RT_API_ATTRS void Descriptor::Establish(TypeCategory c, int kind, void *p,
76 int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute,
77 bool addendum) {
78 Establish(TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute,
79 addendum);
80}
81
82RT_API_ATTRS void Descriptor::Establish(int characterKind,
83 std::size_t characters, void *p, int rank, const SubscriptValue *extent,
84 ISO::CFI_attribute_t attribute, bool addendum) {
85 Establish(TypeCode{TypeCategory::Character, characterKind},
86 characterKind * characters, p, rank, extent, attribute, addendum);
87}
88
89RT_API_ATTRS void Descriptor::Establish(const typeInfo::DerivedType &dt,
90 void *p, int rank, const SubscriptValue *extent,
91 ISO::CFI_attribute_t attribute) {
92 Establish(TypeCode{TypeCategory::Derived, 0}, dt.sizeInBytes(), p, rank,
93 extent, attribute, true);
94 DescriptorAddendum *a{Addendum()};
95 Terminator terminator{__FILE__, __LINE__};
96 RUNTIME_CHECK(terminator, a != nullptr);
97 new (a) DescriptorAddendum{&dt};
98}
99
100RT_API_ATTRS OwningPtr<Descriptor> Descriptor::Create(TypeCode t,
101 std::size_t elementBytes, void *p, int rank, const SubscriptValue *extent,
102 ISO::CFI_attribute_t attribute, bool addendum,
103 const typeInfo::DerivedType *dt) {
104 Terminator terminator{__FILE__, __LINE__};
105 RUNTIME_CHECK(terminator, t.IsDerived() == (dt != nullptr));
106 int derivedTypeLenParameters = dt ? dt->LenParameters() : 0;
107 std::size_t bytes{SizeInBytes(rank, addendum, derivedTypeLenParameters)};
108 Descriptor *result{
109 reinterpret_cast<Descriptor *>(AllocateMemoryOrCrash(terminator, bytes))};
110 if (dt) {
111 result->Establish(*dt, p, rank, extent, attribute);
112 } else {
113 result->Establish(t, elementBytes, p, rank, extent, attribute, addendum);
114 }
115 return OwningPtr<Descriptor>{result};
116}
117
118RT_API_ATTRS OwningPtr<Descriptor> Descriptor::Create(TypeCategory c, int kind,
119 void *p, int rank, const SubscriptValue *extent,
120 ISO::CFI_attribute_t attribute) {
121 return Create(
122 TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute);
123}
124
125RT_API_ATTRS OwningPtr<Descriptor> Descriptor::Create(int characterKind,
126 SubscriptValue characters, void *p, int rank, const SubscriptValue *extent,
127 ISO::CFI_attribute_t attribute) {
128 return Create(TypeCode{TypeCategory::Character, characterKind},
129 characterKind * characters, p, rank, extent, attribute);
130}
131
132RT_API_ATTRS OwningPtr<Descriptor> Descriptor::Create(
133 const typeInfo::DerivedType &dt, void *p, int rank,
134 const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
135 return Create(TypeCode{TypeCategory::Derived, 0}, dt.sizeInBytes(), p, rank,
136 extent, attribute, /*addendum=*/true, &dt);
137}
138
139RT_API_ATTRS std::size_t Descriptor::SizeInBytes() const {
140 const DescriptorAddendum *addendum{Addendum()};
141 return sizeof *this - sizeof(Dimension) + raw_.rank * sizeof(Dimension) +
142 (addendum ? addendum->SizeInBytes() : 0);
143}
144
145RT_API_ATTRS std::size_t Descriptor::Elements() const {
146 int n{rank()};
147 std::size_t elements{1};
148 for (int j{0}; j < n; ++j) {
149 elements *= GetDimension(j).Extent();
150 }
151 return elements;
152}
153
154RT_API_ATTRS int Descriptor::Allocate() {
155 std::size_t elementBytes{ElementBytes()};
156 if (static_cast<std::int64_t>(elementBytes) < 0) {
157 // F'2023 7.4.4.2 p5: "If the character length parameter value evaluates
158 // to a negative value, the length of character entities declared is zero."
159 elementBytes = raw_.elem_len = 0;
160 }
161 std::size_t byteSize{Elements() * elementBytes};
162 // Zero size allocation is possible in Fortran and the resulting
163 // descriptor must be allocated/associated. Since std::malloc(0)
164 // result is implementation defined, always allocate at least one byte.
165 void *p{byteSize ? std::malloc(byteSize) : std::malloc(1)};
166 if (!p) {
167 return CFI_ERROR_MEM_ALLOCATION;
168 }
169 // TODO: image synchronization
170 raw_.base_addr = p;
171 SetByteStrides();
172 return 0;
173}
174
175RT_API_ATTRS void Descriptor::SetByteStrides() {
176 if (int dims{rank()}) {
177 std::size_t stride{ElementBytes()};
178 for (int j{0}; j < dims; ++j) {
179 auto &dimension{GetDimension(j)};
180 dimension.SetByteStride(stride);
181 stride *= dimension.Extent();
182 }
183 }
184}
185
186RT_API_ATTRS int Descriptor::Destroy(
187 bool finalize, bool destroyPointers, Terminator *terminator) {
188 if (!destroyPointers && raw_.attribute == CFI_attribute_pointer) {
189 return StatOk;
190 } else {
191 if (auto *addendum{Addendum()}) {
192 if (const auto *derived{addendum->derivedType()}) {
193 if (!derived->noDestructionNeeded()) {
194 runtime::Destroy(*this, finalize, *derived, terminator);
195 }
196 }
197 }
198 return Deallocate();
199 }
200}
201
202RT_API_ATTRS int Descriptor::Deallocate() { return ISO::CFI_deallocate(&raw_); }
203
204RT_API_ATTRS bool Descriptor::DecrementSubscripts(
205 SubscriptValue *subscript, const int *permutation) const {
206 for (int j{raw_.rank - 1}; j >= 0; --j) {
207 int k{permutation ? permutation[j] : j};
208 const Dimension &dim{GetDimension(k)};
209 if (--subscript[k] >= dim.LowerBound()) {
210 return true;
211 }
212 subscript[k] = dim.UpperBound();
213 }
214 return false;
215}
216
217RT_API_ATTRS std::size_t Descriptor::ZeroBasedElementNumber(
218 const SubscriptValue *subscript, const int *permutation) const {
219 std::size_t result{0};
220 std::size_t coefficient{1};
221 for (int j{0}; j < raw_.rank; ++j) {
222 int k{permutation ? permutation[j] : j};
223 const Dimension &dim{GetDimension(k)};
224 result += coefficient * (subscript[k] - dim.LowerBound());
225 coefficient *= dim.Extent();
226 }
227 return result;
228}
229
230RT_API_ATTRS bool Descriptor::EstablishPointerSection(const Descriptor &source,
231 const SubscriptValue *lower, const SubscriptValue *upper,
232 const SubscriptValue *stride) {
233 *this = source;
234 raw_.attribute = CFI_attribute_pointer;
235 int newRank{raw_.rank};
236 for (int j{0}; j < raw_.rank; ++j) {
237 if (!stride || stride[j] == 0) {
238 if (newRank > 0) {
239 --newRank;
240 } else {
241 return false;
242 }
243 }
244 }
245 raw_.rank = newRank;
246 if (const auto *sourceAddendum = source.Addendum()) {
247 if (auto *addendum{Addendum()}) {
248 *addendum = *sourceAddendum;
249 } else {
250 return false;
251 }
252 }
253 return CFI_section(&raw_, &source.raw_, lower, upper, stride) == CFI_SUCCESS;
254}
255
256RT_API_ATTRS void Descriptor::ApplyMold(const Descriptor &mold, int rank) {
257 raw_.elem_len = mold.raw_.elem_len;
258 raw_.rank = rank;
259 raw_.type = mold.raw_.type;
260 for (int j{0}; j < rank && j < mold.raw_.rank; ++j) {
261 GetDimension(j) = mold.GetDimension(j);
262 }
263 if (auto *addendum{Addendum()}) {
264 if (auto *moldAddendum{mold.Addendum()}) {
265 *addendum = *moldAddendum;
266 } else {
267 INTERNAL_CHECK(!addendum->derivedType());
268 }
269 }
270}
271
272RT_API_ATTRS void Descriptor::Check() const {
273 // TODO
274}
275
276void Descriptor::Dump(FILE *f) const {
277 std::fprintf(f, "Descriptor @ %p:\n", reinterpret_cast<const void *>(this));
278 std::fprintf(f, " base_addr %p\n", raw_.base_addr);
279 std::fprintf(f, " elem_len %zd\n", static_cast<std::size_t>(raw_.elem_len));
280 std::fprintf(f, " version %d\n", static_cast<int>(raw_.version));
281 std::fprintf(f, " rank %d\n", static_cast<int>(raw_.rank));
282 std::fprintf(f, " type %d\n", static_cast<int>(raw_.type));
283 std::fprintf(f, " attribute %d\n", static_cast<int>(raw_.attribute));
284 std::fprintf(f, " addendum %d\n", static_cast<int>(raw_.f18Addendum));
285 for (int j{0}; j < raw_.rank; ++j) {
286 std::fprintf(f, " dim[%d] lower_bound %jd\n", j,
287 static_cast<std::intmax_t>(raw_.dim[j].lower_bound));
288 std::fprintf(f, " extent %jd\n",
289 static_cast<std::intmax_t>(raw_.dim[j].extent));
290 std::fprintf(f, " sm %jd\n",
291 static_cast<std::intmax_t>(raw_.dim[j].sm));
292 }
293 if (const DescriptorAddendum * addendum{Addendum()}) {
294 addendum->Dump(f);
295 }
296}
297
298RT_API_ATTRS DescriptorAddendum &DescriptorAddendum::operator=(
299 const DescriptorAddendum &that) {
300 derivedType_ = that.derivedType_;
301 auto lenParms{that.LenParameters()};
302 for (std::size_t j{0}; j < lenParms; ++j) {
303 len_[j] = that.len_[j];
304 }
305 return *this;
306}
307
308RT_API_ATTRS std::size_t DescriptorAddendum::SizeInBytes() const {
309 return SizeInBytes(LenParameters());
310}
311
312RT_API_ATTRS std::size_t DescriptorAddendum::LenParameters() const {
313 const auto *type{derivedType()};
314 return type ? type->LenParameters() : 0;
315}
316
317void DescriptorAddendum::Dump(FILE *f) const {
318 std::fprintf(
319 f, " derivedType @ %p\n", reinterpret_cast<const void *>(derivedType()));
320 std::size_t lenParms{LenParameters()};
321 for (std::size_t j{0}; j < lenParms; ++j) {
322 std::fprintf(f, " len[%zd] %jd\n", j, static_cast<std::intmax_t>(len_[j]));
323 }
324}
325
326RT_OFFLOAD_API_GROUP_END
327
328} // namespace Fortran::runtime
329

source code of flang/runtime/descriptor.cpp