1//===-- runtime/derived.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 "derived.h"
10#include "stat.h"
11#include "terminator.h"
12#include "tools.h"
13#include "type-info.h"
14#include "flang/Runtime/descriptor.h"
15
16namespace Fortran::runtime {
17
18RT_OFFLOAD_API_GROUP_BEGIN
19
20RT_API_ATTRS int Initialize(const Descriptor &instance,
21 const typeInfo::DerivedType &derived, Terminator &terminator, bool hasStat,
22 const Descriptor *errMsg) {
23 const Descriptor &componentDesc{derived.component()};
24 std::size_t elements{instance.Elements()};
25 int stat{StatOk};
26 // Initialize data components in each element; the per-element iterations
27 // constitute the inner loops, not the outer ones
28 std::size_t myComponents{componentDesc.Elements()};
29 for (std::size_t k{0}; k < myComponents; ++k) {
30 const auto &comp{
31 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
32 SubscriptValue at[maxRank];
33 instance.GetLowerBounds(at);
34 if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
35 comp.genre() == typeInfo::Component::Genre::Automatic) {
36 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
37 Descriptor &allocDesc{
38 *instance.ElementComponent<Descriptor>(at, comp.offset())};
39 comp.EstablishDescriptor(allocDesc, instance, terminator);
40 allocDesc.raw().attribute = CFI_attribute_allocatable;
41 if (comp.genre() == typeInfo::Component::Genre::Automatic) {
42 stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat);
43 if (stat == StatOk) {
44 if (const DescriptorAddendum * addendum{allocDesc.Addendum()}) {
45 if (const auto *derived{addendum->derivedType()}) {
46 if (!derived->noInitializationNeeded()) {
47 stat = Initialize(
48 allocDesc, *derived, terminator, hasStat, errMsg);
49 }
50 }
51 }
52 }
53 if (stat != StatOk) {
54 break;
55 }
56 }
57 }
58 } else if (const void *init{comp.initialization()}) {
59 // Explicit initialization of data pointers and
60 // non-allocatable non-automatic components
61 std::size_t bytes{comp.SizeInBytes(instance)};
62 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
63 char *ptr{instance.ElementComponent<char>(at, comp.offset())};
64 std::memcpy(dest: ptr, src: init, n: bytes);
65 }
66 } else if (comp.genre() == typeInfo::Component::Genre::Pointer) {
67 // Data pointers without explicit initialization are established
68 // so that they are valid right-hand side targets of pointer
69 // assignment statements.
70 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
71 Descriptor &ptrDesc{
72 *instance.ElementComponent<Descriptor>(at, comp.offset())};
73 comp.EstablishDescriptor(ptrDesc, instance, terminator);
74 ptrDesc.raw().attribute = CFI_attribute_pointer;
75 }
76 } else if (comp.genre() == typeInfo::Component::Genre::Data &&
77 comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) {
78 // Default initialization of non-pointer non-allocatable/automatic
79 // data component. Handles parent component's elements. Recursive.
80 SubscriptValue extent[maxRank];
81 const typeInfo::Value *bounds{comp.bounds()};
82 for (int dim{0}; dim < comp.rank(); ++dim) {
83 typeInfo::TypeParameterValue lb{
84 bounds[2 * dim].GetValue(&instance).value_or(0)};
85 typeInfo::TypeParameterValue ub{
86 bounds[2 * dim + 1].GetValue(&instance).value_or(0)};
87 extent[dim] = ub >= lb ? ub - lb + 1 : 0;
88 }
89 StaticDescriptor<maxRank, true, 0> staticDescriptor;
90 Descriptor &compDesc{staticDescriptor.descriptor()};
91 const typeInfo::DerivedType &compType{*comp.derivedType()};
92 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
93 compDesc.Establish(compType,
94 instance.ElementComponent<char>(at, comp.offset()), comp.rank(),
95 extent);
96 stat = Initialize(compDesc, compType, terminator, hasStat, errMsg);
97 if (stat != StatOk) {
98 break;
99 }
100 }
101 }
102 }
103 // Initialize procedure pointer components in each element
104 const Descriptor &procPtrDesc{derived.procPtr()};
105 std::size_t myProcPtrs{procPtrDesc.Elements()};
106 for (std::size_t k{0}; k < myProcPtrs; ++k) {
107 const auto &comp{
108 *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
109 SubscriptValue at[maxRank];
110 instance.GetLowerBounds(at);
111 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
112 auto &pptr{*instance.ElementComponent<typeInfo::ProcedurePointer>(
113 at, comp.offset)};
114 pptr = comp.procInitialization;
115 }
116 }
117 return stat;
118}
119
120static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal(
121 const typeInfo::DerivedType &derived, int rank) {
122 if (const auto *ranked{derived.FindSpecialBinding(
123 typeInfo::SpecialBinding::RankFinal(rank))}) {
124 return ranked;
125 } else if (const auto *assumed{derived.FindSpecialBinding(
126 typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {
127 return assumed;
128 } else {
129 return derived.FindSpecialBinding(
130 typeInfo::SpecialBinding::Which::ElementalFinal);
131 }
132}
133
134static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
135 const typeInfo::DerivedType &derived, Terminator *terminator) {
136 if (const auto *special{FindFinal(derived, descriptor.rank())}) {
137 if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
138 std::size_t elements{descriptor.Elements()};
139 SubscriptValue at[maxRank];
140 descriptor.GetLowerBounds(at);
141 if (special->IsArgDescriptor(0)) {
142 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
143 Descriptor &elemDesc{statDesc.descriptor()};
144 elemDesc = descriptor;
145 elemDesc.raw().attribute = CFI_attribute_pointer;
146 elemDesc.raw().rank = 0;
147 auto *p{special->GetProc<void (*)(const Descriptor &)>()};
148 for (std::size_t j{0}; j++ < elements;
149 descriptor.IncrementSubscripts(at)) {
150 elemDesc.set_base_addr(descriptor.Element<char>(at));
151 p(elemDesc);
152 }
153 } else {
154 auto *p{special->GetProc<void (*)(char *)>()};
155 for (std::size_t j{0}; j++ < elements;
156 descriptor.IncrementSubscripts(at)) {
157 p(descriptor.Element<char>(at));
158 }
159 }
160 } else {
161 StaticDescriptor<maxRank, true, 10> statDesc;
162 Descriptor &copy{statDesc.descriptor()};
163 const Descriptor *argDescriptor{&descriptor};
164 if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
165 !descriptor.IsContiguous()) {
166 // The FINAL subroutine demands a contiguous array argument, but
167 // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.
168 // Finalize a shallow copy of the data.
169 copy = descriptor;
170 copy.set_base_addr(nullptr);
171 copy.raw().attribute = CFI_attribute_allocatable;
172 Terminator stubTerminator{"CallFinalProcedure() in Fortran runtime", 0};
173 RUNTIME_CHECK(terminator ? *terminator : stubTerminator,
174 copy.Allocate() == CFI_SUCCESS);
175 ShallowCopyDiscontiguousToContiguous(to: copy, from: descriptor);
176 argDescriptor = &copy;
177 }
178 if (special->IsArgDescriptor(0)) {
179 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
180 Descriptor &tmpDesc{statDesc.descriptor()};
181 tmpDesc = *argDescriptor;
182 tmpDesc.raw().attribute = CFI_attribute_pointer;
183 tmpDesc.Addendum()->set_derivedType(&derived);
184 auto *p{special->GetProc<void (*)(const Descriptor &)>()};
185 p(tmpDesc);
186 } else {
187 auto *p{special->GetProc<void (*)(char *)>()};
188 p(argDescriptor->OffsetElement<char>());
189 }
190 if (argDescriptor == &copy) {
191 ShallowCopyContiguousToDiscontiguous(to: descriptor, from: copy);
192 copy.Deallocate();
193 }
194 }
195 }
196}
197
198// Fortran 2018 subclause 7.5.6.2
199RT_API_ATTRS void Finalize(const Descriptor &descriptor,
200 const typeInfo::DerivedType &derived, Terminator *terminator) {
201 if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
202 return;
203 }
204 CallFinalSubroutine(descriptor, derived, terminator);
205 const auto *parentType{derived.GetParentType()};
206 bool recurse{parentType && !parentType->noFinalizationNeeded()};
207 // If there's a finalizable parent component, handle it last, as required
208 // by the Fortran standard (7.5.6.2), and do so recursively with the same
209 // descriptor so that the rank is preserved.
210 const Descriptor &componentDesc{derived.component()};
211 std::size_t myComponents{componentDesc.Elements()};
212 std::size_t elements{descriptor.Elements()};
213 for (auto k{recurse ? std::size_t{1}
214 /* skip first component, it's the parent */
215 : 0};
216 k < myComponents; ++k) {
217 const auto &comp{
218 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
219 SubscriptValue at[maxRank];
220 descriptor.GetLowerBounds(at);
221 if (comp.genre() == typeInfo::Component::Genre::Allocatable &&
222 comp.category() == TypeCategory::Derived) {
223 // Component may be polymorphic or unlimited polymorphic. Need to use the
224 // dynamic type to check whether finalization is needed.
225 for (std::size_t j{0}; j++ < elements;
226 descriptor.IncrementSubscripts(at)) {
227 const Descriptor &compDesc{
228 *descriptor.ElementComponent<Descriptor>(at, comp.offset())};
229 if (compDesc.IsAllocated()) {
230 if (const DescriptorAddendum * addendum{compDesc.Addendum()}) {
231 if (const typeInfo::DerivedType *
232 compDynamicType{addendum->derivedType()}) {
233 if (!compDynamicType->noFinalizationNeeded()) {
234 Finalize(compDesc, *compDynamicType, terminator);
235 }
236 }
237 }
238 }
239 }
240 } else if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
241 comp.genre() == typeInfo::Component::Genre::Automatic) {
242 if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
243 if (!compType->noFinalizationNeeded()) {
244 for (std::size_t j{0}; j++ < elements;
245 descriptor.IncrementSubscripts(at)) {
246 const Descriptor &compDesc{
247 *descriptor.ElementComponent<Descriptor>(at, comp.offset())};
248 if (compDesc.IsAllocated()) {
249 Finalize(compDesc, *compType, terminator);
250 }
251 }
252 }
253 }
254 } else if (comp.genre() == typeInfo::Component::Genre::Data &&
255 comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
256 SubscriptValue extent[maxRank];
257 const typeInfo::Value *bounds{comp.bounds()};
258 for (int dim{0}; dim < comp.rank(); ++dim) {
259 SubscriptValue lb{bounds[2 * dim].GetValue(&descriptor).value_or(0)};
260 SubscriptValue ub{
261 bounds[2 * dim + 1].GetValue(&descriptor).value_or(0)};
262 extent[dim] = ub >= lb ? ub - lb + 1 : 0;
263 }
264 StaticDescriptor<maxRank, true, 0> staticDescriptor;
265 Descriptor &compDesc{staticDescriptor.descriptor()};
266 const typeInfo::DerivedType &compType{*comp.derivedType()};
267 for (std::size_t j{0}; j++ < elements;
268 descriptor.IncrementSubscripts(at)) {
269 compDesc.Establish(compType,
270 descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
271 extent);
272 Finalize(compDesc, compType, terminator);
273 }
274 }
275 }
276 if (recurse) {
277 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
278 Descriptor &tmpDesc{statDesc.descriptor()};
279 tmpDesc = descriptor;
280 tmpDesc.raw().attribute = CFI_attribute_pointer;
281 tmpDesc.Addendum()->set_derivedType(parentType);
282 tmpDesc.raw().elem_len = parentType->sizeInBytes();
283 Finalize(tmpDesc, *parentType, terminator);
284 }
285}
286
287// The order of finalization follows Fortran 2018 7.5.6.2, with
288// elementwise finalization of non-parent components taking place
289// before parent component finalization, and with all finalization
290// preceding any deallocation.
291RT_API_ATTRS void Destroy(const Descriptor &descriptor, bool finalize,
292 const typeInfo::DerivedType &derived, Terminator *terminator) {
293 if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
294 return;
295 }
296 if (finalize && !derived.noFinalizationNeeded()) {
297 Finalize(descriptor, derived, terminator);
298 }
299 const Descriptor &componentDesc{derived.component()};
300 std::size_t myComponents{componentDesc.Elements()};
301 std::size_t elements{descriptor.Elements()};
302 SubscriptValue at[maxRank];
303 descriptor.GetLowerBounds(at);
304 for (std::size_t k{0}; k < myComponents; ++k) {
305 const auto &comp{
306 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
307 if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
308 comp.genre() == typeInfo::Component::Genre::Automatic) {
309 for (std::size_t j{0}; j < elements; ++j) {
310 Descriptor *d{
311 descriptor.ElementComponent<Descriptor>(at, comp.offset())};
312 d->Deallocate();
313 descriptor.IncrementSubscripts(at);
314 }
315 }
316 }
317}
318
319RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) {
320 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
321 if (const auto *derived = addendum->derivedType()) {
322 const Descriptor &componentDesc{derived->component()};
323 std::size_t myComponents{componentDesc.Elements()};
324 for (std::size_t k{0}; k < myComponents; ++k) {
325 const auto &comp{
326 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
327 if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
328 comp.genre() == typeInfo::Component::Genre::Automatic) {
329 return true;
330 }
331 }
332 }
333 }
334 return false;
335}
336
337RT_OFFLOAD_API_GROUP_END
338} // namespace Fortran::runtime
339

source code of flang/runtime/derived.cpp