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 // Fill "extents" array with the extents of component "comp" from derived type 21 // instance "derivedInstance". 22 static RT_API_ATTRS void GetComponentExtents(SubscriptValue (&extents)[maxRank], 23 const typeInfo::Component &comp, const Descriptor &derivedInstance) { 24 const typeInfo::Value *bounds{comp.bounds()}; 25 for (int dim{0}; dim < comp.rank(); ++dim) { 26 auto lb{bounds[2 * dim].GetValue(&derivedInstance).value_or(0)}; 27 auto ub{bounds[2 * dim + 1].GetValue(&derivedInstance).value_or(0)}; 28 extents[dim] = ub >= lb ? static_cast<SubscriptValue>(ub - lb + 1) : 0; 29 } 30 } 31 32 RT_API_ATTRS int Initialize(const Descriptor &instance, 33 const typeInfo::DerivedType &derived, Terminator &terminator, bool hasStat, 34 const Descriptor *errMsg) { 35 const Descriptor &componentDesc{derived.component()}; 36 std::size_t elements{instance.Elements()}; 37 int stat{StatOk}; 38 // Initialize data components in each element; the per-element iterations 39 // constitute the inner loops, not the outer ones 40 std::size_t myComponents{componentDesc.Elements()}; 41 for (std::size_t k{0}; k < myComponents; ++k) { 42 const auto &comp{ 43 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)}; 44 SubscriptValue at[maxRank]; 45 instance.GetLowerBounds(at); 46 if (comp.genre() == typeInfo::Component::Genre::Allocatable || 47 comp.genre() == typeInfo::Component::Genre::Automatic) { 48 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) { 49 Descriptor &allocDesc{ 50 *instance.ElementComponent<Descriptor>(at, comp.offset())}; 51 comp.EstablishDescriptor(allocDesc, instance, terminator); 52 allocDesc.raw().attribute = CFI_attribute_allocatable; 53 if (comp.genre() == typeInfo::Component::Genre::Automatic) { 54 stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat); 55 if (stat == StatOk) { 56 if (const DescriptorAddendum * addendum{allocDesc.Addendum()}) { 57 if (const auto *derived{addendum->derivedType()}) { 58 if (!derived->noInitializationNeeded()) { 59 stat = Initialize( 60 allocDesc, *derived, terminator, hasStat, errMsg); 61 } 62 } 63 } 64 } 65 if (stat != StatOk) { 66 break; 67 } 68 } 69 } 70 } else if (const void *init{comp.initialization()}) { 71 // Explicit initialization of data pointers and 72 // non-allocatable non-automatic components 73 std::size_t bytes{comp.SizeInBytes(instance)}; 74 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) { 75 char *ptr{instance.ElementComponent<char>(at, comp.offset())}; 76 std::memcpy(ptr, init, bytes); 77 } 78 } else if (comp.genre() == typeInfo::Component::Genre::Pointer) { 79 // Data pointers without explicit initialization are established 80 // so that they are valid right-hand side targets of pointer 81 // assignment statements. 82 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) { 83 Descriptor &ptrDesc{ 84 *instance.ElementComponent<Descriptor>(at, comp.offset())}; 85 comp.EstablishDescriptor(ptrDesc, instance, terminator); 86 ptrDesc.raw().attribute = CFI_attribute_pointer; 87 } 88 } else if (comp.genre() == typeInfo::Component::Genre::Data && 89 comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) { 90 // Default initialization of non-pointer non-allocatable/automatic 91 // data component. Handles parent component's elements. Recursive. 92 SubscriptValue extents[maxRank]; 93 GetComponentExtents(extents, comp, instance); 94 StaticDescriptor<maxRank, true, 0> staticDescriptor; 95 Descriptor &compDesc{staticDescriptor.descriptor()}; 96 const typeInfo::DerivedType &compType{*comp.derivedType()}; 97 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) { 98 compDesc.Establish(compType, 99 instance.ElementComponent<char>(at, comp.offset()), comp.rank(), 100 extents); 101 stat = Initialize(compDesc, compType, terminator, hasStat, errMsg); 102 if (stat != StatOk) { 103 break; 104 } 105 } 106 } 107 } 108 // Initialize procedure pointer components in each element 109 const Descriptor &procPtrDesc{derived.procPtr()}; 110 std::size_t myProcPtrs{procPtrDesc.Elements()}; 111 for (std::size_t k{0}; k < myProcPtrs; ++k) { 112 const auto &comp{ 113 *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)}; 114 SubscriptValue at[maxRank]; 115 instance.GetLowerBounds(at); 116 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) { 117 auto &pptr{*instance.ElementComponent<typeInfo::ProcedurePointer>( 118 at, comp.offset)}; 119 pptr = comp.procInitialization; 120 } 121 } 122 return stat; 123 } 124 125 RT_API_ATTRS int InitializeClone(const Descriptor &clone, 126 const Descriptor &orig, const typeInfo::DerivedType &derived, 127 Terminator &terminator, bool hasStat, const Descriptor *errMsg) { 128 const Descriptor &componentDesc{derived.component()}; 129 std::size_t elements{orig.Elements()}; 130 int stat{StatOk}; 131 132 // Skip pointers and unallocated variables. 133 if (orig.IsPointer() || !orig.IsAllocated()) { 134 return stat; 135 } 136 // Initialize each data component. 137 std::size_t components{componentDesc.Elements()}; 138 for (std::size_t i{0}; i < components; ++i) { 139 const typeInfo::Component &comp{ 140 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(i)}; 141 SubscriptValue at[maxRank]; 142 orig.GetLowerBounds(at); 143 // Allocate allocatable components that are also allocated in the original 144 // object. 145 if (comp.genre() == typeInfo::Component::Genre::Allocatable) { 146 // Initialize each element. 147 for (std::size_t j{0}; j < elements; ++j, orig.IncrementSubscripts(at)) { 148 Descriptor &origDesc{ 149 *orig.ElementComponent<Descriptor>(at, comp.offset())}; 150 Descriptor &cloneDesc{ 151 *clone.ElementComponent<Descriptor>(at, comp.offset())}; 152 if (origDesc.IsAllocated()) { 153 cloneDesc.ApplyMold(origDesc, origDesc.rank()); 154 stat = ReturnError(terminator, cloneDesc.Allocate(), errMsg, hasStat); 155 if (stat == StatOk) { 156 if (const DescriptorAddendum * addendum{cloneDesc.Addendum()}) { 157 if (const typeInfo::DerivedType * 158 derived{addendum->derivedType()}) { 159 if (!derived->noInitializationNeeded()) { 160 // Perform default initialization for the allocated element. 161 stat = Initialize( 162 cloneDesc, *derived, terminator, hasStat, errMsg); 163 } 164 // Initialize derived type's allocatables. 165 if (stat == StatOk) { 166 stat = InitializeClone(cloneDesc, origDesc, *derived, 167 terminator, hasStat, errMsg); 168 } 169 } 170 } 171 } 172 } 173 if (stat != StatOk) { 174 break; 175 } 176 } 177 } else if (comp.genre() == typeInfo::Component::Genre::Data && 178 comp.derivedType()) { 179 // Handle nested derived types. 180 const typeInfo::DerivedType &compType{*comp.derivedType()}; 181 SubscriptValue extents[maxRank]; 182 GetComponentExtents(extents, comp, orig); 183 // Data components don't have descriptors, allocate them. 184 StaticDescriptor<maxRank, true, 0> origStaticDesc; 185 StaticDescriptor<maxRank, true, 0> cloneStaticDesc; 186 Descriptor &origDesc{origStaticDesc.descriptor()}; 187 Descriptor &cloneDesc{cloneStaticDesc.descriptor()}; 188 // Initialize each element. 189 for (std::size_t j{0}; j < elements; ++j, orig.IncrementSubscripts(at)) { 190 origDesc.Establish(compType, 191 orig.ElementComponent<char>(at, comp.offset()), comp.rank(), 192 extents); 193 cloneDesc.Establish(compType, 194 clone.ElementComponent<char>(at, comp.offset()), comp.rank(), 195 extents); 196 stat = InitializeClone( 197 cloneDesc, origDesc, compType, terminator, hasStat, errMsg); 198 if (stat != StatOk) { 199 break; 200 } 201 } 202 } 203 } 204 return stat; 205 } 206 207 static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal( 208 const typeInfo::DerivedType &derived, int rank) { 209 if (const auto *ranked{derived.FindSpecialBinding( 210 typeInfo::SpecialBinding::RankFinal(rank))}) { 211 return ranked; 212 } else if (const auto *assumed{derived.FindSpecialBinding( 213 typeInfo::SpecialBinding::Which::AssumedRankFinal)}) { 214 return assumed; 215 } else { 216 return derived.FindSpecialBinding( 217 typeInfo::SpecialBinding::Which::ElementalFinal); 218 } 219 } 220 221 static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor, 222 const typeInfo::DerivedType &derived, Terminator *terminator) { 223 if (const auto *special{FindFinal(derived, descriptor.rank())}) { 224 if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) { 225 std::size_t elements{descriptor.Elements()}; 226 SubscriptValue at[maxRank]; 227 descriptor.GetLowerBounds(at); 228 if (special->IsArgDescriptor(0)) { 229 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc; 230 Descriptor &elemDesc{statDesc.descriptor()}; 231 elemDesc = descriptor; 232 elemDesc.raw().attribute = CFI_attribute_pointer; 233 elemDesc.raw().rank = 0; 234 auto *p{special->GetProc<void (*)(const Descriptor &)>()}; 235 for (std::size_t j{0}; j++ < elements; 236 descriptor.IncrementSubscripts(at)) { 237 elemDesc.set_base_addr(descriptor.Element<char>(at)); 238 p(elemDesc); 239 } 240 } else { 241 auto *p{special->GetProc<void (*)(char *)>()}; 242 for (std::size_t j{0}; j++ < elements; 243 descriptor.IncrementSubscripts(at)) { 244 p(descriptor.Element<char>(at)); 245 } 246 } 247 } else { 248 StaticDescriptor<maxRank, true, 10> statDesc; 249 Descriptor ©{statDesc.descriptor()}; 250 const Descriptor *argDescriptor{&descriptor}; 251 if (descriptor.rank() > 0 && special->IsArgContiguous(0) && 252 !descriptor.IsContiguous()) { 253 // The FINAL subroutine demands a contiguous array argument, but 254 // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous. 255 // Finalize a shallow copy of the data. 256 copy = descriptor; 257 copy.set_base_addr(nullptr); 258 copy.raw().attribute = CFI_attribute_allocatable; 259 Terminator stubTerminator{"CallFinalProcedure() in Fortran runtime", 0}; 260 RUNTIME_CHECK(terminator ? *terminator : stubTerminator, 261 copy.Allocate() == CFI_SUCCESS); 262 ShallowCopyDiscontiguousToContiguous(copy, descriptor); 263 argDescriptor = © 264 } 265 if (special->IsArgDescriptor(0)) { 266 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc; 267 Descriptor &tmpDesc{statDesc.descriptor()}; 268 tmpDesc = *argDescriptor; 269 tmpDesc.raw().attribute = CFI_attribute_pointer; 270 tmpDesc.Addendum()->set_derivedType(&derived); 271 auto *p{special->GetProc<void (*)(const Descriptor &)>()}; 272 p(tmpDesc); 273 } else { 274 auto *p{special->GetProc<void (*)(char *)>()}; 275 p(argDescriptor->OffsetElement<char>()); 276 } 277 if (argDescriptor == ©) { 278 ShallowCopyContiguousToDiscontiguous(descriptor, copy); 279 copy.Deallocate(); 280 } 281 } 282 } 283 } 284 285 // Fortran 2018 subclause 7.5.6.2 286 RT_API_ATTRS void Finalize(const Descriptor &descriptor, 287 const typeInfo::DerivedType &derived, Terminator *terminator) { 288 if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) { 289 return; 290 } 291 CallFinalSubroutine(descriptor, derived, terminator); 292 const auto *parentType{derived.GetParentType()}; 293 bool recurse{parentType && !parentType->noFinalizationNeeded()}; 294 // If there's a finalizable parent component, handle it last, as required 295 // by the Fortran standard (7.5.6.2), and do so recursively with the same 296 // descriptor so that the rank is preserved. 297 const Descriptor &componentDesc{derived.component()}; 298 std::size_t myComponents{componentDesc.Elements()}; 299 std::size_t elements{descriptor.Elements()}; 300 for (auto k{recurse ? std::size_t{1} 301 /* skip first component, it's the parent */ 302 : 0}; 303 k < myComponents; ++k) { 304 const auto &comp{ 305 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)}; 306 SubscriptValue at[maxRank]; 307 descriptor.GetLowerBounds(at); 308 if (comp.genre() == typeInfo::Component::Genre::Allocatable && 309 comp.category() == TypeCategory::Derived) { 310 // Component may be polymorphic or unlimited polymorphic. Need to use the 311 // dynamic type to check whether finalization is needed. 312 for (std::size_t j{0}; j++ < elements; 313 descriptor.IncrementSubscripts(at)) { 314 const Descriptor &compDesc{ 315 *descriptor.ElementComponent<Descriptor>(at, comp.offset())}; 316 if (compDesc.IsAllocated()) { 317 if (const DescriptorAddendum * addendum{compDesc.Addendum()}) { 318 if (const typeInfo::DerivedType * 319 compDynamicType{addendum->derivedType()}) { 320 if (!compDynamicType->noFinalizationNeeded()) { 321 Finalize(compDesc, *compDynamicType, terminator); 322 } 323 } 324 } 325 } 326 } 327 } else if (comp.genre() == typeInfo::Component::Genre::Allocatable || 328 comp.genre() == typeInfo::Component::Genre::Automatic) { 329 if (const typeInfo::DerivedType * compType{comp.derivedType()}) { 330 if (!compType->noFinalizationNeeded()) { 331 for (std::size_t j{0}; j++ < elements; 332 descriptor.IncrementSubscripts(at)) { 333 const Descriptor &compDesc{ 334 *descriptor.ElementComponent<Descriptor>(at, comp.offset())}; 335 if (compDesc.IsAllocated()) { 336 Finalize(compDesc, *compType, terminator); 337 } 338 } 339 } 340 } 341 } else if (comp.genre() == typeInfo::Component::Genre::Data && 342 comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) { 343 SubscriptValue extents[maxRank]; 344 GetComponentExtents(extents, comp, descriptor); 345 StaticDescriptor<maxRank, true, 0> staticDescriptor; 346 Descriptor &compDesc{staticDescriptor.descriptor()}; 347 const typeInfo::DerivedType &compType{*comp.derivedType()}; 348 for (std::size_t j{0}; j++ < elements; 349 descriptor.IncrementSubscripts(at)) { 350 compDesc.Establish(compType, 351 descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(), 352 extents); 353 Finalize(compDesc, compType, terminator); 354 } 355 } 356 } 357 if (recurse) { 358 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc; 359 Descriptor &tmpDesc{statDesc.descriptor()}; 360 tmpDesc = descriptor; 361 tmpDesc.raw().attribute = CFI_attribute_pointer; 362 tmpDesc.Addendum()->set_derivedType(parentType); 363 tmpDesc.raw().elem_len = parentType->sizeInBytes(); 364 Finalize(tmpDesc, *parentType, terminator); 365 } 366 } 367 368 // The order of finalization follows Fortran 2018 7.5.6.2, with 369 // elementwise finalization of non-parent components taking place 370 // before parent component finalization, and with all finalization 371 // preceding any deallocation. 372 RT_API_ATTRS void Destroy(const Descriptor &descriptor, bool finalize, 373 const typeInfo::DerivedType &derived, Terminator *terminator) { 374 if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) { 375 return; 376 } 377 if (finalize && !derived.noFinalizationNeeded()) { 378 Finalize(descriptor, derived, terminator); 379 } 380 // Deallocate all direct and indirect allocatable and automatic components. 381 // Contrary to finalization, the order of deallocation does not matter. 382 const Descriptor &componentDesc{derived.component()}; 383 std::size_t myComponents{componentDesc.Elements()}; 384 std::size_t elements{descriptor.Elements()}; 385 SubscriptValue at[maxRank]; 386 descriptor.GetLowerBounds(at); 387 for (std::size_t k{0}; k < myComponents; ++k) { 388 const auto &comp{ 389 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)}; 390 const bool destroyComp{ 391 comp.derivedType() && !comp.derivedType()->noDestructionNeeded()}; 392 if (comp.genre() == typeInfo::Component::Genre::Allocatable || 393 comp.genre() == typeInfo::Component::Genre::Automatic) { 394 for (std::size_t j{0}; j < elements; ++j) { 395 Descriptor *d{ 396 descriptor.ElementComponent<Descriptor>(at, comp.offset())}; 397 if (destroyComp) { 398 Destroy(*d, /*finalize=*/false, *comp.derivedType(), terminator); 399 } 400 d->Deallocate(); 401 descriptor.IncrementSubscripts(at); 402 } 403 } else if (destroyComp && 404 comp.genre() == typeInfo::Component::Genre::Data) { 405 SubscriptValue extents[maxRank]; 406 GetComponentExtents(extents, comp, descriptor); 407 StaticDescriptor<maxRank, true, 0> staticDescriptor; 408 Descriptor &compDesc{staticDescriptor.descriptor()}; 409 const typeInfo::DerivedType &compType{*comp.derivedType()}; 410 for (std::size_t j{0}; j++ < elements; 411 descriptor.IncrementSubscripts(at)) { 412 compDesc.Establish(compType, 413 descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(), 414 extents); 415 Destroy(compDesc, /*finalize=*/false, *comp.derivedType(), terminator); 416 } 417 } 418 } 419 } 420 421 RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) { 422 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 423 if (const auto *derived = addendum->derivedType()) { 424 // Destruction is needed if and only if there are direct or indirect 425 // allocatable or automatic components. 426 return !derived->noDestructionNeeded(); 427 } 428 } 429 return false; 430 } 431 432 RT_OFFLOAD_API_GROUP_END 433 } // namespace Fortran::runtime 434