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 if (pointer.Elements() > target.Elements()) {
119 terminator.Crash("PointerAssociateRemapping: too many elements in remapped "
120 "pointer (%zd > %zd)",
121 pointer.Elements(), target.Elements());
122 }
123}
124
125RT_API_ATTRS void *AllocateValidatedPointerPayload(
126 std::size_t byteSize, int allocatorIdx) {
127 // Add space for a footer to validate during deallocation.
128 constexpr std::size_t align{sizeof(std::uintptr_t)};
129 byteSize = ((byteSize + align - 1) / align) * align;
130 std::size_t total{byteSize + sizeof(std::uintptr_t)};
131 AllocFct alloc{allocatorRegistry.GetAllocator(allocatorIdx)};
132 void *p{alloc(total, /*asyncObject=*/nullptr)};
133 if (p && allocatorIdx == 0) {
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
144int 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, pointer.GetAllocIdx())};
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
174int 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
186static 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
197bool 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
207int 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 pointer.GetAllocIdx() == kDefaultAllocator &&
218 !ValidatePointerPayload(pointer.raw())) {
219 return ReturnError(terminator, StatBadPointerDeallocation, errMsg, hasStat);
220 }
221 return ReturnError(terminator,
222 pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator),
223 errMsg, hasStat);
224}
225
226int RTDEF(PointerDeallocatePolymorphic)(Descriptor &pointer,
227 const typeInfo::DerivedType *derivedType, bool hasStat,
228 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
229 int stat{RTNAME(PointerDeallocate)(
230 pointer, hasStat, errMsg, sourceFile, sourceLine)};
231 if (stat == StatOk) {
232 if (DescriptorAddendum * addendum{pointer.Addendum()}) {
233 addendum->set_derivedType(derivedType);
234 pointer.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
235 } else {
236 // Unlimited polymorphic descriptors initialized with
237 // PointerNullifyIntrinsic do not have an addendum. Make sure the
238 // derivedType is null in that case.
239 INTERNAL_CHECK(!derivedType);
240 pointer.raw().type = CFI_type_other;
241 }
242 }
243 return stat;
244}
245
246bool RTDEF(PointerIsAssociated)(const Descriptor &pointer) {
247 return pointer.raw().base_addr != nullptr;
248}
249
250bool RTDEF(PointerIsAssociatedWith)(
251 const Descriptor &pointer, const Descriptor *target) {
252 if (!target) {
253 return pointer.raw().base_addr != nullptr;
254 }
255 if (!target->raw().base_addr ||
256 (target->raw().type != CFI_type_struct && target->ElementBytes() == 0)) {
257 return false;
258 }
259 int rank{pointer.rank()};
260 if (pointer.raw().base_addr != target->raw().base_addr ||
261 pointer.ElementBytes() != target->ElementBytes() ||
262 rank != target->rank()) {
263 return false;
264 }
265 for (int j{0}; j < rank; ++j) {
266 const Dimension &pDim{pointer.GetDimension(j)};
267 const Dimension &tDim{target->GetDimension(j)};
268 auto pExtent{pDim.Extent()};
269 if (pExtent == 0 || pExtent != tDim.Extent() ||
270 (pExtent != 1 && pDim.ByteStride() != tDim.ByteStride())) {
271 return false;
272 }
273 }
274 return true;
275}
276
277// TODO: PointerCheckLengthParameter
278
279RT_EXT_API_GROUP_END
280} // extern "C"
281} // namespace Fortran::runtime
282

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