llvm-project

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

21
namespace Fortran::runtime {
22

23
RT_OFFLOAD_API_GROUP_BEGIN
24

25
RT_API_ATTRS Descriptor::Descriptor(const Descriptor &that) { *this = that; }
26

27
RT_API_ATTRS Descriptor &Descriptor::operator=(const Descriptor &that) {
28
  std::memcpy(this, &that, that.SizeInBytes());
29
  return *this;
30
}
31

32
RT_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

61
namespace {
62
template <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

70
RT_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

75
RT_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

82
RT_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

89
RT_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

100
RT_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

118
RT_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

125
RT_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

132
RT_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

139
RT_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

145
RT_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

154
RT_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

175
RT_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

186
RT_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

202
RT_API_ATTRS int Descriptor::Deallocate() {
203
  ISO::CFI_cdesc_t &descriptor{raw()};
204
  if (!descriptor.base_addr) {
205
    return CFI_ERROR_BASE_ADDR_NULL;
206
  } else {
207
    std::free(descriptor.base_addr);
208
    descriptor.base_addr = nullptr;
209
    return CFI_SUCCESS;
210
  }
211
}
212

213
RT_API_ATTRS bool Descriptor::DecrementSubscripts(
214
    SubscriptValue *subscript, const int *permutation) const {
215
  for (int j{raw_.rank - 1}; j >= 0; --j) {
216
    int k{permutation ? permutation[j] : j};
217
    const Dimension &dim{GetDimension(k)};
218
    if (--subscript[k] >= dim.LowerBound()) {
219
      return true;
220
    }
221
    subscript[k] = dim.UpperBound();
222
  }
223
  return false;
224
}
225

226
RT_API_ATTRS std::size_t Descriptor::ZeroBasedElementNumber(
227
    const SubscriptValue *subscript, const int *permutation) const {
228
  std::size_t result{0};
229
  std::size_t coefficient{1};
230
  for (int j{0}; j < raw_.rank; ++j) {
231
    int k{permutation ? permutation[j] : j};
232
    const Dimension &dim{GetDimension(k)};
233
    result += coefficient * (subscript[k] - dim.LowerBound());
234
    coefficient *= dim.Extent();
235
  }
236
  return result;
237
}
238

239
RT_API_ATTRS bool Descriptor::EstablishPointerSection(const Descriptor &source,
240
    const SubscriptValue *lower, const SubscriptValue *upper,
241
    const SubscriptValue *stride) {
242
  *this = source;
243
  raw_.attribute = CFI_attribute_pointer;
244
  int newRank{raw_.rank};
245
  for (int j{0}; j < raw_.rank; ++j) {
246
    if (!stride || stride[j] == 0) {
247
      if (newRank > 0) {
248
        --newRank;
249
      } else {
250
        return false;
251
      }
252
    }
253
  }
254
  raw_.rank = newRank;
255
  if (const auto *sourceAddendum = source.Addendum()) {
256
    if (auto *addendum{Addendum()}) {
257
      *addendum = *sourceAddendum;
258
    } else {
259
      return false;
260
    }
261
  }
262
  return CFI_section(&raw_, &source.raw_, lower, upper, stride) == CFI_SUCCESS;
263
}
264

265
RT_API_ATTRS void Descriptor::ApplyMold(const Descriptor &mold, int rank) {
266
  raw_.elem_len = mold.raw_.elem_len;
267
  raw_.rank = rank;
268
  raw_.type = mold.raw_.type;
269
  for (int j{0}; j < rank && j < mold.raw_.rank; ++j) {
270
    GetDimension(j) = mold.GetDimension(j);
271
  }
272
  if (auto *addendum{Addendum()}) {
273
    if (auto *moldAddendum{mold.Addendum()}) {
274
      *addendum = *moldAddendum;
275
    } else {
276
      INTERNAL_CHECK(!addendum->derivedType());
277
    }
278
  }
279
}
280

281
RT_API_ATTRS void Descriptor::Check() const {
282
  // TODO
283
}
284

285
void Descriptor::Dump(FILE *f) const {
286
  std::fprintf(f, "Descriptor @ %p:\n", reinterpret_cast<const void *>(this));
287
  std::fprintf(f, "  base_addr %p\n", raw_.base_addr);
288
  std::fprintf(f, "  elem_len  %zd\n", static_cast<std::size_t>(raw_.elem_len));
289
  std::fprintf(f, "  version   %d\n", static_cast<int>(raw_.version));
290
  std::fprintf(f, "  rank      %d\n", static_cast<int>(raw_.rank));
291
  std::fprintf(f, "  type      %d\n", static_cast<int>(raw_.type));
292
  std::fprintf(f, "  attribute %d\n", static_cast<int>(raw_.attribute));
293
  std::fprintf(f, "  addendum  %d\n", static_cast<int>(raw_.f18Addendum));
294
  for (int j{0}; j < raw_.rank; ++j) {
295
    std::fprintf(f, "  dim[%d] lower_bound %jd\n", j,
296
        static_cast<std::intmax_t>(raw_.dim[j].lower_bound));
297
    std::fprintf(f, "         extent      %jd\n",
298
        static_cast<std::intmax_t>(raw_.dim[j].extent));
299
    std::fprintf(f, "         sm          %jd\n",
300
        static_cast<std::intmax_t>(raw_.dim[j].sm));
301
  }
302
  if (const DescriptorAddendum * addendum{Addendum()}) {
303
    addendum->Dump(f);
304
  }
305
}
306

307
RT_API_ATTRS DescriptorAddendum &DescriptorAddendum::operator=(
308
    const DescriptorAddendum &that) {
309
  derivedType_ = that.derivedType_;
310
  auto lenParms{that.LenParameters()};
311
  for (std::size_t j{0}; j < lenParms; ++j) {
312
    len_[j] = that.len_[j];
313
  }
314
  return *this;
315
}
316

317
RT_API_ATTRS std::size_t DescriptorAddendum::SizeInBytes() const {
318
  return SizeInBytes(LenParameters());
319
}
320

321
RT_API_ATTRS std::size_t DescriptorAddendum::LenParameters() const {
322
  const auto *type{derivedType()};
323
  return type ? type->LenParameters() : 0;
324
}
325

326
void DescriptorAddendum::Dump(FILE *f) const {
327
  std::fprintf(
328
      f, "  derivedType @ %p\n", reinterpret_cast<const void *>(derivedType()));
329
  std::size_t lenParms{LenParameters()};
330
  for (std::size_t j{0}; j < lenParms; ++j) {
331
    std::fprintf(f, "  len[%zd] %jd\n", j, static_cast<std::intmax_t>(len_[j]));
332
  }
333
}
334

335
RT_OFFLOAD_API_GROUP_END
336

337
} // namespace Fortran::runtime
338