flang/runtime/pointer.cpp

   1 //===-- runtime/pointer.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 "flang/Runtime/pointer.h"
  10 #include "assign-impl.h"
  11 #include "derived.h"
  12 #include "environment.h"
  13 #include "stat.h"
  14 #include "terminator.h"
  15 #include "tools.h"
  16 #include "type-info.h"
  17
  18 namespace Fortran::runtime {
  19 extern "C" {
  20 RT_EXT_API_GROUP_BEGIN
  21
  22 void RTDEF(PointerNullifyIntrinsic)(Descriptor &pointer, TypeCategory category,
  23     int kind, int rank, int corank) {
  24   INTERNAL_CHECK(corank == 0);
  25   pointer.Establish(TypeCode{category, kind},
  26       Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
  27       CFI_attribute_pointer);
  28 }
  29
  30 void RTDEF(PointerNullifyCharacter)(Descriptor &pointer, SubscriptValue length,
  31     int kind, int rank, int corank) {
  32   INTERNAL_CHECK(corank == 0);
  33   pointer.Establish(
  34       kind, length, nullptr, rank, nullptr, CFI_attribute_pointer);
  35 }
  36
  37 void RTDEF(PointerNullifyDerived)(Descriptor &pointer,
  38     const typeInfo::DerivedType &derivedType, int rank, int corank) {
  39   INTERNAL_CHECK(corank == 0);
  40   pointer.Establish(derivedType, nullptr, rank, nullptr, CFI_attribute_pointer);
  41 }
  42
  43 void RTDEF(PointerSetBounds)(Descriptor &pointer, int zeroBasedDim,
  44     SubscriptValue lower, SubscriptValue upper) {
  45   INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < pointer.rank());
  46   pointer.GetDimension(zeroBasedDim).SetBounds(lower, upper);
  47   // The byte strides are computed when the pointer is allocated.
  48 }
  49
  50 // TODO: PointerSetCoBounds
  51
  52 void RTDEF(PointerSetDerivedLength)(
  53     Descriptor &pointer, int which, SubscriptValue x) {
  54   DescriptorAddendum *addendum{pointer.Addendum()};
  55   INTERNAL_CHECK(addendum != nullptr);
  56   addendum->SetLenParameterValue(which, x);
  57 }
  58
  59 void RTDEF(PointerApplyMold)(
  60     Descriptor &pointer, const Descriptor &mold, int rank) {
  61   pointer.ApplyMold(mold, rank);
  62 }
  63
  64 void RTDEF(PointerAssociateScalar)(Descriptor &pointer, void *target) {
  65   pointer.set_base_addr(target);
  66 }
  67
  68 void RTDEF(PointerAssociate)(Descriptor &pointer, const Descriptor &target) {
  69   pointer = target;
  70   pointer.raw().attribute = CFI_attribute_pointer;
  71 }
  72
  73 void RTDEF(PointerAssociateLowerBounds)(Descriptor &pointer,
  74     const Descriptor &target, const Descriptor &lowerBounds) {
  75   pointer = target;
  76   pointer.raw().attribute = CFI_attribute_pointer;
  77   int rank{pointer.rank()};
  78   Terminator terminator{__FILE__, __LINE__};
  79   std::size_t boundElementBytes{lowerBounds.ElementBytes()};
  80   for (int j{0}; j < rank; ++j) {
  81     Dimension &dim{pointer.GetDimension(j)};
  82     dim.SetLowerBound(dim.Extent() == 0
  83             ? 1
  84             : GetInt64(lowerBounds.ZeroBasedIndexedElement<const char>(j),
  85                   boundElementBytes, terminator));
  86   }
  87 }
  88
  89 void RTDEF(PointerAssociateRemapping)(Descriptor &pointer,
  90     const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
  91     int sourceLine) {
  92   pointer = target;
  93   pointer.raw().attribute = CFI_attribute_pointer;
  94   Terminator terminator{sourceFile, sourceLine};
  95   SubscriptValue byteStride{/*captured from first dimension*/};
  96   std::size_t boundElementBytes{bounds.ElementBytes()};
  97   std::size_t boundsRank{
  98       static_cast<std::size_t>(bounds.GetDimension(1).Extent())};
  99   pointer.raw().rank = boundsRank;
 100   for (unsigned j{0}; j < boundsRank; ++j) {
 101     auto &dim{pointer.GetDimension(j)};
 102     dim.SetBounds(GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j),
 103                       boundElementBytes, terminator),
 104         GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j + 1),
 105             boundElementBytes, terminator));
 106     if (j == 0) {
 107       byteStride = dim.ByteStride() * dim.Extent();
 108     } else {
 109       dim.SetByteStride(byteStride);
 110       byteStride *= dim.Extent();
 111     }
 112   }
 113   if (pointer.Elements() > target.Elements()) {
 114     terminator.Crash("PointerAssociateRemapping: too many elements in remapped "
 115                      "pointer (%zd > %zd)",
 116         pointer.Elements(), target.Elements());
 117   }
 118   if (auto *pointerAddendum{pointer.Addendum()}) {
 119     if (const auto *targetAddendum{target.Addendum()}) {
 120       if (const auto *derived{targetAddendum->derivedType()}) {
 121         pointerAddendum->set_derivedType(derived);
 122       }
 123     }
 124   }
 125 }
 126
 127 RT_API_ATTRS void *AllocateValidatedPointerPayload(std::size_t byteSize) {
 128   // Add space for a footer to validate during deallocation.
 129   constexpr std::size_t align{sizeof(std::uintptr_t)};
 130   byteSize = ((byteSize + align - 1) / align) * align;
 131   std::size_t total{byteSize + sizeof(std::uintptr_t)};
 132   void *p{std::malloc(total)};
 133   if (p) {
 134     // Fill the footer word with the XOR of the ones' complement of
 135     // the base address, which is a value that would be highly unlikely
 136     // to appear accidentally at the right spot.
 137     std::uintptr_t *footer{
 138         reinterpret_cast<std::uintptr_t *>(static_cast<char *>(p) + byteSize)};
 139     *footer = ~reinterpret_cast<std::uintptr_t>(p);
 140   }
 141   return p;
 142 }
 143
 144 int RTDEF(PointerAllocate)(Descriptor &pointer, bool hasStat,
 145     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 146   Terminator terminator{sourceFile, sourceLine};
 147   if (!pointer.IsPointer()) {
 148     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 149   }
 150   std::size_t elementBytes{pointer.ElementBytes()};
 151   if (static_cast<std::int64_t>(elementBytes) < 0) {
 152     // F'2023 7.4.4.2 p5: "If the character length parameter value evaluates
 153     // to a negative value, the length of character entities declared is zero."
 154     elementBytes = pointer.raw().elem_len = 0;
 155   }
 156   std::size_t byteSize{pointer.Elements() * elementBytes};
 157   void *p{AllocateValidatedPointerPayload(byteSize)};
 158   if (!p) {
 159     return ReturnError(terminator, CFI_ERROR_MEM_ALLOCATION, errMsg, hasStat);
 160   }
 161   pointer.set_base_addr(p);
 162   pointer.SetByteStrides();
 163   int stat{StatOk};
 164   if (const DescriptorAddendum * addendum{pointer.Addendum()}) {
 165     if (const auto *derived{addendum->derivedType()}) {
 166       if (!derived->noInitializationNeeded()) {
 167         stat = Initialize(pointer, *derived, terminator, hasStat, errMsg);
 168       }
 169     }
 170   }
 171   return ReturnError(terminator, stat, errMsg, hasStat);
 172 }
 173
 174 int RTDEF(PointerAllocateSource)(Descriptor &pointer, const Descriptor &source,
 175     bool hasStat, const Descriptor *errMsg, const char *sourceFile,
 176     int sourceLine) {
 177   int stat{RTNAME(PointerAllocate)(
 178       pointer, hasStat, errMsg, sourceFile, sourceLine)};
 179   if (stat == StatOk) {
 180     Terminator terminator{sourceFile, sourceLine};
 181     DoFromSourceAssign(pointer, source, terminator);
 182   }
 183   return stat;
 184 }
 185
 186 static RT_API_ATTRS std::size_t GetByteSize(
 187     const ISO::CFI_cdesc_t &descriptor) {
 188   std::size_t rank{descriptor.rank};
 189   const ISO::CFI_dim_t *dim{descriptor.dim};
 190   std::size_t byteSize{descriptor.elem_len};
 191   for (std::size_t j{0}; j < rank; ++j) {
 192     byteSize *= dim[j].extent;
 193   }
 194   return byteSize;
 195 }
 196
 197 bool RT_API_ATTRS ValidatePointerPayload(const ISO::CFI_cdesc_t &desc) {
 198   std::size_t byteSize{GetByteSize(desc)};
 199   constexpr std::size_t align{sizeof(std::uintptr_t)};
 200   byteSize = ((byteSize + align - 1) / align) * align;
 201   const void *p{desc.base_addr};
 202   const std::uintptr_t *footer{reinterpret_cast<const std::uintptr_t *>(
 203       static_cast<const char *>(p) + byteSize)};
 204   return *footer == ~reinterpret_cast<std::uintptr_t>(p);
 205 }
 206
 207 int RTDEF(PointerDeallocate)(Descriptor &pointer, bool hasStat,
 208     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 209   Terminator terminator{sourceFile, sourceLine};
 210   if (!pointer.IsPointer()) {
 211     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 212   }
 213   if (!pointer.IsAllocated()) {
 214     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
 215   }
 216   if (executionEnvironment.checkPointerDeallocation &&
 217       !ValidatePointerPayload(pointer.raw())) {
 218     return ReturnError(terminator, StatBadPointerDeallocation, errMsg, hasStat);
 219   }
 220   return ReturnError(terminator,
 221       pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator),
 222       errMsg, hasStat);
 223 }
 224
 225 int RTDEF(PointerDeallocatePolymorphic)(Descriptor &pointer,
 226     const typeInfo::DerivedType *derivedType, bool hasStat,
 227     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 228   int stat{RTNAME(PointerDeallocate)(
 229       pointer, hasStat, errMsg, sourceFile, sourceLine)};
 230   if (stat == StatOk) {
 231     if (DescriptorAddendum * addendum{pointer.Addendum()}) {
 232       addendum->set_derivedType(derivedType);
 233       pointer.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
 234     } else {
 235       // Unlimited polymorphic descriptors initialized with
 236       // PointerNullifyIntrinsic do not have an addendum. Make sure the
 237       // derivedType is null in that case.
 238       INTERNAL_CHECK(!derivedType);
 239       pointer.raw().type = CFI_type_other;
 240     }
 241   }
 242   return stat;
 243 }
 244
 245 bool RTDEF(PointerIsAssociated)(const Descriptor &pointer) {
 246   return pointer.raw().base_addr != nullptr;
 247 }
 248
 249 bool RTDEF(PointerIsAssociatedWith)(
 250     const Descriptor &pointer, const Descriptor *target) {
 251   if (!target) {
 252     return pointer.raw().base_addr != nullptr;
 253   }
 254   if (!target->raw().base_addr ||
 255       (target->raw().type != CFI_type_struct && target->ElementBytes() == 0)) {
 256     return false;
 257   }
 258   int rank{pointer.rank()};
 259   if (pointer.raw().base_addr != target->raw().base_addr ||
 260       pointer.ElementBytes() != target->ElementBytes() ||
 261       rank != target->rank()) {
 262     return false;
 263   }
 264   for (int j{0}; j < rank; ++j) {
 265     const Dimension &pDim{pointer.GetDimension(j)};
 266     const Dimension &tDim{target->GetDimension(j)};
 267     auto pExtent{pDim.Extent()};
 268     if (pExtent == 0 || pExtent != tDim.Extent() ||
 269         (pExtent != 1 && pDim.ByteStride() != tDim.ByteStride())) {
 270       return false;
 271     }
 272   }
 273   return true;
 274 }
 275
 276 // TODO: PointerCheckLengthParameter
 277
 278 RT_EXT_API_GROUP_END
 279 } // extern "C"
 280 } // namespace Fortran::runtime