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 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 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 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. 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