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 "descriptor.h"
11 #include "stat.h"
12 #include "terminator.h"
13 #include "type-info.h"
14
15 namespace Fortran::runtime {
16
Initialize(const Descriptor & instance,const typeInfo::DerivedType & derived,Terminator & terminator,bool hasStat,const Descriptor * errMsg)17 int Initialize(const Descriptor &instance, const typeInfo::DerivedType &derived,
18 Terminator &terminator, bool hasStat, const Descriptor *errMsg) {
19 const Descriptor &componentDesc{derived.component()};
20 std::size_t elements{instance.Elements()};
21 std::size_t byteStride{instance.ElementBytes()};
22 int stat{StatOk};
23 // Initialize data components in each element; the per-element iteration
24 // constitutes the inner loops, not outer
25 std::size_t myComponents{componentDesc.Elements()};
26 for (std::size_t k{0}; k < myComponents; ++k) {
27 const auto &comp{
28 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
29 if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
30 comp.genre() == typeInfo::Component::Genre::Automatic) {
31 for (std::size_t j{0}; j < elements; ++j) {
32 Descriptor &allocDesc{*instance.OffsetElement<Descriptor>(
33 j * byteStride + comp.offset())};
34 comp.EstablishDescriptor(allocDesc, instance, terminator);
35 allocDesc.raw().attribute = CFI_attribute_allocatable;
36 if (comp.genre() == typeInfo::Component::Genre::Automatic) {
37 stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat);
38 if (stat == StatOk) {
39 stat = Initialize(allocDesc, derived, terminator, hasStat, errMsg);
40 }
41 if (stat != StatOk) {
42 break;
43 }
44 }
45 }
46 } else if (const void *init{comp.initialization()}) {
47 // Explicit initialization of data pointers and
48 // non-allocatable non-automatic components
49 std::size_t bytes{comp.SizeInBytes(instance)};
50 for (std::size_t j{0}; j < elements; ++j) {
51 char *ptr{instance.OffsetElement<char>(j * byteStride + comp.offset())};
52 std::memcpy(ptr, init, bytes);
53 }
54 } else if (comp.genre() == typeInfo::Component::Genre::Data &&
55 comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) {
56 // Default initialization of non-pointer non-allocatable/automatic
57 // data component. Handles parent component's elements. Recursive.
58 SubscriptValue extent[maxRank];
59 const typeInfo::Value *bounds{comp.bounds()};
60 for (int dim{0}; dim < comp.rank(); ++dim) {
61 typeInfo::TypeParameterValue lb{
62 bounds[2 * dim].GetValue(&instance).value_or(0)};
63 typeInfo::TypeParameterValue ub{
64 bounds[2 * dim + 1].GetValue(&instance).value_or(0)};
65 extent[dim] = ub >= lb ? ub - lb + 1 : 0;
66 }
67 StaticDescriptor<maxRank, true, 0> staticDescriptor;
68 Descriptor &compDesc{staticDescriptor.descriptor()};
69 const typeInfo::DerivedType &compType{*comp.derivedType()};
70 for (std::size_t j{0}; j < elements; ++j) {
71 compDesc.Establish(compType,
72 instance.OffsetElement<char>(j * byteStride + comp.offset()),
73 comp.rank(), extent);
74 stat = Initialize(compDesc, compType, terminator, hasStat, errMsg);
75 if (stat != StatOk) {
76 break;
77 }
78 }
79 }
80 }
81 // Initialize procedure pointer components in each element
82 const Descriptor &procPtrDesc{derived.procPtr()};
83 std::size_t myProcPtrs{procPtrDesc.Elements()};
84 for (std::size_t k{0}; k < myProcPtrs; ++k) {
85 const auto &comp{
86 *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
87 for (std::size_t j{0}; j < elements; ++j) {
88 auto &pptr{*instance.OffsetElement<typeInfo::ProcedurePointer>(
89 j * byteStride + comp.offset)};
90 pptr = comp.procInitialization;
91 }
92 }
93 return stat;
94 }
95
FindFinal(const typeInfo::DerivedType & derived,int rank)96 static const typeInfo::SpecialBinding *FindFinal(
97 const typeInfo::DerivedType &derived, int rank) {
98 const typeInfo::SpecialBinding *elemental{nullptr};
99 const Descriptor &specialDesc{derived.special()};
100 std::size_t totalSpecialBindings{specialDesc.Elements()};
101 for (std::size_t j{0}; j < totalSpecialBindings; ++j) {
102 const auto &special{
103 *specialDesc.ZeroBasedIndexedElement<typeInfo::SpecialBinding>(j)};
104 switch (special.which()) {
105 case typeInfo::SpecialBinding::Which::Final:
106 if (special.rank() == rank) {
107 return &special;
108 }
109 break;
110 case typeInfo::SpecialBinding::Which::ElementalFinal:
111 elemental = &special;
112 break;
113 case typeInfo::SpecialBinding::Which::AssumedRankFinal:
114 return &special;
115 default:;
116 }
117 }
118 return elemental;
119 }
120
CallFinalSubroutine(const Descriptor & descriptor,const typeInfo::DerivedType & derived)121 static void CallFinalSubroutine(
122 const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
123 if (const auto *special{FindFinal(derived, descriptor.rank())}) {
124 // The following code relies on the fact that finalizable objects
125 // must be contiguous.
126 if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
127 std::size_t byteStride{descriptor.ElementBytes()};
128 std::size_t elements{descriptor.Elements()};
129 if (special->IsArgDescriptor(0)) {
130 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
131 Descriptor &elemDesc{statDesc.descriptor()};
132 elemDesc = descriptor;
133 elemDesc.raw().attribute = CFI_attribute_pointer;
134 elemDesc.raw().rank = 0;
135 auto *p{special->GetProc<void (*)(const Descriptor &)>()};
136 for (std::size_t j{0}; j < elements; ++j) {
137 elemDesc.set_base_addr(
138 descriptor.OffsetElement<char>(j * byteStride));
139 p(elemDesc);
140 }
141 } else {
142 auto *p{special->GetProc<void (*)(char *)>()};
143 for (std::size_t j{0}; j < elements; ++j) {
144 p(descriptor.OffsetElement<char>(j * byteStride));
145 }
146 }
147 } else if (special->IsArgDescriptor(0)) {
148 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
149 Descriptor &tmpDesc{statDesc.descriptor()};
150 tmpDesc = descriptor;
151 tmpDesc.raw().attribute = CFI_attribute_pointer;
152 tmpDesc.Addendum()->set_derivedType(&derived);
153 auto *p{special->GetProc<void (*)(const Descriptor &)>()};
154 p(tmpDesc);
155 } else {
156 auto *p{special->GetProc<void (*)(char *)>()};
157 p(descriptor.OffsetElement<char>());
158 }
159 }
160 }
161
162 // The order of finalization follows Fortran 2018 7.5.6.2, with
163 // deallocation of non-parent components (and their consequent finalization)
164 // taking place before parent component finalization.
Destroy(const Descriptor & descriptor,bool finalize,const typeInfo::DerivedType & derived)165 void Destroy(const Descriptor &descriptor, bool finalize,
166 const typeInfo::DerivedType &derived) {
167 if (finalize) {
168 CallFinalSubroutine(descriptor, derived);
169 }
170 const Descriptor &componentDesc{derived.component()};
171 std::size_t myComponents{componentDesc.Elements()};
172 std::size_t elements{descriptor.Elements()};
173 std::size_t byteStride{descriptor.ElementBytes()};
174 // If there's a finalizable parent component, handle it last, as required
175 // by the Fortran standard (7.5.6.2), and do so recursively with the same
176 // descriptor so that the rank is preserved. Otherwise, destroy the parent
177 // component like any other.
178 const auto *parentType{derived.GetParentType()};
179 bool recurse{finalize && parentType && !parentType->noDestructionNeeded()};
180 for (auto k{recurse
181 ? std::size_t{1} /* skip first component, it's the parent */
182 : 0};
183 k < myComponents; ++k) {
184 const auto &comp{
185 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
186 if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
187 comp.genre() == typeInfo::Component::Genre::Automatic) {
188 if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
189 if (!compType->noDestructionNeeded()) {
190 for (std::size_t j{0}; j < elements; ++j) {
191 Destroy(*descriptor.OffsetElement<Descriptor>(
192 j * byteStride + comp.offset()),
193 finalize, *compType);
194 }
195 }
196 }
197 for (std::size_t j{0}; j < elements; ++j) {
198 descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset())
199 ->Deallocate();
200 }
201 } else if (comp.genre() == typeInfo::Component::Genre::Data &&
202 comp.derivedType() && !comp.derivedType()->noDestructionNeeded()) {
203 SubscriptValue extent[maxRank];
204 const typeInfo::Value *bounds{comp.bounds()};
205 for (int dim{0}; dim < comp.rank(); ++dim) {
206 extent[dim] = bounds[2 * dim].GetValue(&descriptor).value_or(0) -
207 bounds[2 * dim + 1].GetValue(&descriptor).value_or(0) + 1;
208 }
209 StaticDescriptor<maxRank, true, 0> staticDescriptor;
210 Descriptor &compDesc{staticDescriptor.descriptor()};
211 const typeInfo::DerivedType &compType{*comp.derivedType()};
212 for (std::size_t j{0}; j < elements; ++j) {
213 compDesc.Establish(compType,
214 descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
215 comp.rank(), extent);
216 Destroy(compDesc, finalize, compType);
217 }
218 }
219 }
220 if (recurse) {
221 Destroy(descriptor, finalize, *parentType);
222 }
223 }
224
225 // TODO: Assign()
226
227 } // namespace Fortran::runtime
228