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

source code of flang-rt/lib/runtime/pointer.cpp