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

source code of flang-rt/lib/runtime/descriptor.cpp