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

source code of flang/runtime/pointer.cpp