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
18namespace Fortran::runtime {
19extern "C" {
20RT_EXT_API_GROUP_BEGIN
21
22void 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
30void 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
37void 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
43void 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
52void 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
59void RTDEF(PointerApplyMold)(
60 Descriptor &pointer, const Descriptor &mold, int rank) {
61 pointer.ApplyMold(mold, rank);
62}
63
64void RTDEF(PointerAssociateScalar)(Descriptor &pointer, void *target) {
65 pointer.set_base_addr(target);
66}
67
68void RTDEF(PointerAssociate)(Descriptor &pointer, const Descriptor &target) {
69 pointer = target;
70 pointer.raw().attribute = CFI_attribute_pointer;
71}
72
73void 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
89void 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
127int RTDEF(PointerAllocate)(Descriptor &pointer, bool hasStat,
128 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
129 Terminator terminator{sourceFile, sourceLine};
130 if (!pointer.IsPointer()) {
131 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
132 }
133 std::size_t elementBytes{pointer.ElementBytes()};
134 if (static_cast<std::int64_t>(elementBytes) < 0) {
135 // F'2023 7.4.4.2 p5: "If the character length parameter value evaluates
136 // to a negative value, the length of character entities declared is zero."
137 elementBytes = pointer.raw().elem_len = 0;
138 }
139 std::size_t byteSize{pointer.Elements() * elementBytes};
140 // Add space for a footer to validate during DEALLOCATE.
141 constexpr std::size_t align{sizeof(std::uintptr_t)};
142 byteSize = ((byteSize + align - 1) / align) * align;
143 std::size_t total{byteSize + sizeof(std::uintptr_t)};
144 void *p{std::malloc(size: total)};
145 if (!p) {
146 return ReturnError(terminator, CFI_ERROR_MEM_ALLOCATION, errMsg, hasStat);
147 }
148 pointer.set_base_addr(p);
149 pointer.SetByteStrides();
150 // Fill the footer word with the XOR of the ones' complement of
151 // the base address, which is a value that would be highly unlikely
152 // to appear accidentally at the right spot.
153 std::uintptr_t *footer{
154 reinterpret_cast<std::uintptr_t *>(static_cast<char *>(p) + byteSize)};
155 *footer = ~reinterpret_cast<std::uintptr_t>(p);
156 int stat{StatOk};
157 if (const DescriptorAddendum * addendum{pointer.Addendum()}) {
158 if (const auto *derived{addendum->derivedType()}) {
159 if (!derived->noInitializationNeeded()) {
160 stat = Initialize(pointer, *derived, terminator, hasStat, errMsg);
161 }
162 }
163 }
164 return ReturnError(terminator, stat, errMsg, hasStat);
165}
166
167int RTDEF(PointerAllocateSource)(Descriptor &pointer, const Descriptor &source,
168 bool hasStat, const Descriptor *errMsg, const char *sourceFile,
169 int sourceLine) {
170 int stat{RTNAME(PointerAllocate)(
171 pointer, hasStat, errMsg, sourceFile, sourceLine)};
172 if (stat == StatOk) {
173 Terminator terminator{sourceFile, sourceLine};
174 DoFromSourceAssign(pointer, source, terminator);
175 }
176 return stat;
177}
178
179int RTDEF(PointerDeallocate)(Descriptor &pointer, bool hasStat,
180 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
181 Terminator terminator{sourceFile, sourceLine};
182 if (!pointer.IsPointer()) {
183 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
184 }
185 if (!pointer.IsAllocated()) {
186 return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
187 }
188 if (executionEnvironment.checkPointerDeallocation) {
189 // Validate the footer. This should fail if the pointer doesn't
190 // span the entire object, or the object was not allocated as a
191 // pointer.
192 std::size_t byteSize{pointer.Elements() * pointer.ElementBytes()};
193 constexpr std::size_t align{sizeof(std::uintptr_t)};
194 byteSize = ((byteSize + align - 1) / align) * align;
195 void *p{pointer.raw().base_addr};
196 std::uintptr_t *footer{
197 reinterpret_cast<std::uintptr_t *>(static_cast<char *>(p) + byteSize)};
198 if (*footer != ~reinterpret_cast<std::uintptr_t>(p)) {
199 return ReturnError(
200 terminator, StatBadPointerDeallocation, errMsg, hasStat);
201 }
202 }
203 return ReturnError(terminator,
204 pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator),
205 errMsg, hasStat);
206}
207
208int RTDEF(PointerDeallocatePolymorphic)(Descriptor &pointer,
209 const typeInfo::DerivedType *derivedType, bool hasStat,
210 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
211 int stat{RTNAME(PointerDeallocate)(
212 pointer, hasStat, errMsg, sourceFile, sourceLine)};
213 if (stat == StatOk) {
214 if (DescriptorAddendum * addendum{pointer.Addendum()}) {
215 addendum->set_derivedType(derivedType);
216 pointer.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
217 } else {
218 // Unlimited polymorphic descriptors initialized with
219 // PointerNullifyIntrinsic do not have an addendum. Make sure the
220 // derivedType is null in that case.
221 INTERNAL_CHECK(!derivedType);
222 pointer.raw().type = CFI_type_other;
223 }
224 }
225 return stat;
226}
227
228bool RTDEF(PointerIsAssociated)(const Descriptor &pointer) {
229 return pointer.raw().base_addr != nullptr;
230}
231
232bool RTDEF(PointerIsAssociatedWith)(
233 const Descriptor &pointer, const Descriptor *target) {
234 if (!target) {
235 return pointer.raw().base_addr != nullptr;
236 }
237 if (!target->raw().base_addr ||
238 (target->raw().type != CFI_type_struct && target->ElementBytes() == 0)) {
239 return false;
240 }
241 int rank{pointer.rank()};
242 if (pointer.raw().base_addr != target->raw().base_addr ||
243 pointer.ElementBytes() != target->ElementBytes() ||
244 rank != target->rank()) {
245 return false;
246 }
247 for (int j{0}; j < rank; ++j) {
248 const Dimension &pDim{pointer.GetDimension(j)};
249 const Dimension &tDim{target->GetDimension(j)};
250 auto pExtent{pDim.Extent()};
251 if (pExtent == 0 || pExtent != tDim.Extent() ||
252 (pExtent != 1 && pDim.ByteStride() != tDim.ByteStride())) {
253 return false;
254 }
255 }
256 return true;
257}
258
259// TODO: PointerCheckLengthParameter
260
261RT_EXT_API_GROUP_END
262} // extern "C"
263} // namespace Fortran::runtime
264

source code of flang/runtime/pointer.cpp