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 | |
16 | namespace Fortran::runtime { |
17 | |
18 | RT_OFFLOAD_API_GROUP_BEGIN |
19 | |
20 | RT_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 | |
120 | static 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 | |
134 | static 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 ©{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 = © |
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 == ©) { |
191 | ShallowCopyContiguousToDiscontiguous(to: descriptor, from: copy); |
192 | copy.Deallocate(); |
193 | } |
194 | } |
195 | } |
196 | } |
197 | |
198 | // Fortran 2018 subclause 7.5.6.2 |
199 | RT_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. |
291 | RT_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 | |
319 | RT_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 | |
337 | RT_OFFLOAD_API_GROUP_END |
338 | } // namespace Fortran::runtime |
339 | |