Skip to content

Commit c20ce35

Browse files
klauslerklausler
committed
test and debug RESHAPE
1 parent 80257ee commit c20ce35

File tree

8 files changed

+244
-113
lines changed

8 files changed

+244
-113
lines changed

‎runtime/ISO_Fortran_binding.cc

Lines changed: 21 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,6 @@
1616
// as specified in section 18.5.5 of Fortran 2018.
1717

1818
#include "descriptor.h"
19-
#include <cstdlib>
2019

2120
namespace Fortran::ISO {
2221
extern "C" {
@@ -37,12 +36,13 @@ int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[],
3736
if (descriptor->version != CFI_VERSION) {
3837
return CFI_INVALID_DESCRIPTOR;
3938
}
40-
if ((descriptor->attribute &
41-
~(CFI_attribute_pointer | CFI_attribute_allocatable)) != 0) {
39+
if (descriptor->attribute != CFI_attribute_allocatable &&
40+
descriptor->attribute != CFI_attribute_pointer) {
4241
// Non-interoperable object
4342
return CFI_INVALID_DESCRIPTOR;
4443
}
45-
if (descriptor->base_addr != nullptr) {
44+
if (descriptor->attribute == CFI_attribute_allocatable &&
45+
descriptor->base_addr != nullptr) {
4646
return CFI_ERROR_BASE_ADDR_NOT_NULL;
4747
}
4848
if (descriptor->rank > CFI_MAX_RANK) {
@@ -70,7 +70,7 @@ int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[],
7070
dim->sm = byteSize;
7171
byteSize *= extent;
7272
}
73-
void *p{std::malloc(byteSize)};
73+
void *p{new char[byteSize]};
7474
if (p == nullptr) {
7575
return CFI_ERROR_MEM_ALLOCATION;
7676
}
@@ -83,15 +83,15 @@ int CFI_deallocate(CFI_cdesc_t *descriptor) {
8383
if (descriptor->version != CFI_VERSION) {
8484
return CFI_INVALID_DESCRIPTOR;
8585
}
86-
if ((descriptor->attribute &
87-
~(CFI_attribute_pointer | CFI_attribute_allocatable)) != 0) {
86+
if (descriptor->attribute != CFI_attribute_allocatable &&
87+
descriptor->attribute != CFI_attribute_pointer) {
8888
// Non-interoperable object
8989
return CFI_INVALID_DESCRIPTOR;
9090
}
9191
if (descriptor->base_addr == nullptr) {
9292
return CFI_ERROR_BASE_ADDR_NULL;
9393
}
94-
std::free(descriptor->base_addr);
94+
delete[] static_cast<char *>(descriptor->base_addr);
9595
descriptor->base_addr = nullptr;
9696
return CFI_SUCCESS;
9797
}
@@ -141,12 +141,16 @@ static constexpr std::size_t MinElemLen(CFI_type_t type) {
141141
int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr,
142142
CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len,
143143
CFI_rank_t rank, const CFI_index_t extents[]) {
144-
if ((attribute & ~(CFI_attribute_pointer | CFI_attribute_allocatable)) != 0) {
144+
if (attribute != CFI_attribute_other && attribute != CFI_attribute_pointer &&
145+
attribute != CFI_attribute_allocatable) {
145146
return CFI_INVALID_ATTRIBUTE;
146147
}
147148
if (rank > CFI_MAX_RANK) {
148149
return CFI_INVALID_RANK;
149150
}
151+
if (base_addr != nullptr && attribute != CFI_attribute_pointer) {
152+
return CFI_ERROR_BASE_ADDR_NOT_NULL;
153+
}
150154
if (rank > 0 && base_addr != nullptr && extents == nullptr) {
151155
return CFI_INVALID_EXTENT;
152156
}
@@ -177,7 +181,14 @@ int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr,
177181
}
178182

179183
int CFI_is_contiguous(const CFI_cdesc_t *descriptor) {
180-
return 0; // TODO
184+
std::size_t bytes{descriptor->elem_len};
185+
for (int j{0}; j < descriptor->rank; ++j) {
186+
if (bytes != descriptor->dim[j].sm) {
187+
return 0;
188+
}
189+
bytes *= descriptor->dim[j].extent;
190+
}
191+
return 1;
181192
}
182193

183194
int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source,

‎runtime/derived-type.cc

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,4 +47,36 @@ bool DerivedType::IsNontrivialAnalysis() const {
4747
}
4848
return false;
4949
}
50+
51+
void DerivedType::Initialize(char *instance) const {
52+
if (typeBoundProcedures_ > InitializerTBP) {
53+
if (auto f{reinterpret_cast<void (*)(char *)>(
54+
typeBoundProcedure_[InitializerTBP].code.host)}) {
55+
f(instance);
56+
}
57+
}
58+
for (std::size_t j{0}; j < components_; ++j) {
59+
if (const Descriptor * descriptor{component_[j].GetDescriptor(instance)}) {
60+
// TODO
61+
}
62+
}
63+
}
64+
65+
void DerivedType::Destroy(char *instance, bool finalize) const {
66+
if (finalize && typeBoundProcedures_ > FinalTBP) {
67+
if (auto f{reinterpret_cast<void (*)(char *)>(
68+
typeBoundProcedure_[FinalTBP].code.host)}) {
69+
f(instance);
70+
}
71+
}
72+
const char *constInstance{instance};
73+
for (std::size_t j{0}; j < components_; ++j) {
74+
if (Descriptor * descriptor{component_[j].GetDescriptor(instance)}) {
75+
descriptor->Deallocate(finalize);
76+
} else if (const Descriptor *
77+
descriptor{component_[j].GetDescriptor(constInstance)}) {
78+
descriptor->Destroy(component_[j].Locate<char>(instance), finalize);
79+
}
80+
}
81+
}
5082
} // namespace Fortran::runtime

‎runtime/derived-type.h

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -77,6 +77,14 @@ class Component {
7777
return reinterpret_cast<const A *>(dtInstance + offset_);
7878
}
7979

80+
Descriptor *GetDescriptor(char *dtInstance) const {
81+
if (IsDescriptor()) {
82+
return Locate<Descriptor>(dtInstance);
83+
} else {
84+
return nullptr;
85+
}
86+
}
87+
8088
const Descriptor *GetDescriptor(const char *dtInstance) const {
8189
if (staticDescriptor_ != nullptr) {
8290
return staticDescriptor_;
@@ -144,14 +152,8 @@ class DerivedType {
144152

145153
std::size_t components() const { return components_; }
146154

147-
// TBP 0 is the initializer: SUBROUTINE INIT(INSTANCE)
148-
static constexpr int initializerTBP{0};
149-
150-
// TBP 1 is the sourced allocation copier: SUBROUTINE COPYINIT(TO, FROM)
151-
static constexpr int copierTBP{1};
152-
153-
// TBP 2 is the FINAL subroutine.
154-
static constexpr int finalTBP{2};
155+
// The first few type-bound procedure indices are special.
156+
enum SpecialTBP { InitializerTBP, CopierTBP, FinalTBP };
155157

156158
std::size_t typeBoundProcedures() const { return typeBoundProcedures_; }
157159
const TypeBoundProcedure &typeBoundProcedure(int n) const {
@@ -176,6 +178,9 @@ class DerivedType {
176178

177179
bool IsSameType(const DerivedType &) const;
178180

181+
void Initialize(char *instance) const;
182+
void Destroy(char *instance, bool finalize = true) const;
183+
179184
private:
180185
enum Flag { SEQUENCE = 1, BIND_C = 2, NONTRIVIAL = 4 };
181186

‎runtime/descriptor.cc

Lines changed: 81 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -20,10 +20,9 @@
2020
namespace Fortran::runtime {
2121

2222
Descriptor::~Descriptor() {
23-
// Descriptors created by Descriptor::Create() must be destroyed by
24-
// Descriptor::Destroy(), not by the default destructor, so that
25-
// the array variant operator delete[] is properly used.
26-
assert(!(Addendum() && (Addendum()->flags() & DescriptorAddendum::Created)));
23+
if (raw_.attribute != CFI_attribute_pointer) {
24+
Deallocate();
25+
}
2726
}
2827

2928
void Descriptor::Establish(TypeCode t, std::size_t elementBytes, void *p,
@@ -60,42 +59,33 @@ void Descriptor::Establish(const DerivedType &dt, void *p, int rank,
6059
new (Addendum()) DescriptorAddendum{&dt};
6160
}
6261

63-
Descriptor *Descriptor::Create(TypeCode t, std::size_t elementBytes, void *p,
64-
int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
62+
std::unique_ptr<Descriptor> Descriptor::Create(TypeCode t,
63+
std::size_t elementBytes, void *p, int rank, const SubscriptValue *extent,
64+
ISO::CFI_attribute_t attribute) {
6565
std::size_t bytes{SizeInBytes(rank, true)};
66-
Descriptor *result{reinterpret_cast<Descriptor *>(std::malloc(bytes))};
66+
Descriptor *result{reinterpret_cast<Descriptor *>(new char[bytes])};
6767
CHECK(result != nullptr);
6868
result->Establish(t, elementBytes, p, rank, extent, attribute, true);
69-
result->Addendum()->flags() |= DescriptorAddendum::Created;
70-
return result;
69+
return std::unique_ptr<Descriptor>{result};
7170
}
7271

73-
Descriptor *Descriptor::Create(TypeCategory c, int kind, void *p, int rank,
74-
const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
72+
std::unique_ptr<Descriptor> Descriptor::Create(TypeCategory c, int kind,
73+
void *p, int rank, const SubscriptValue *extent,
74+
ISO::CFI_attribute_t attribute) {
7575
std::size_t bytes{SizeInBytes(rank, true)};
76-
Descriptor *result{reinterpret_cast<Descriptor *>(std::malloc(bytes))};
76+
Descriptor *result{reinterpret_cast<Descriptor *>(new char[bytes])};
7777
CHECK(result != nullptr);
7878
result->Establish(c, kind, p, rank, extent, attribute, true);
79-
result->Addendum()->flags() |= DescriptorAddendum::Created;
80-
return result;
79+
return std::unique_ptr<Descriptor>{result};
8180
}
8281

83-
Descriptor *Descriptor::Create(const DerivedType &dt, void *p, int rank,
84-
const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
82+
std::unique_ptr<Descriptor> Descriptor::Create(const DerivedType &dt, void *p,
83+
int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
8584
std::size_t bytes{SizeInBytes(rank, true, dt.lenParameters())};
86-
Descriptor *result{reinterpret_cast<Descriptor *>(std::malloc(bytes))};
85+
Descriptor *result{reinterpret_cast<Descriptor *>(new char[bytes])};
8786
CHECK(result != nullptr);
8887
result->Establish(dt, p, rank, extent, attribute);
89-
result->Addendum()->flags() |= DescriptorAddendum::Created;
90-
return result;
91-
}
92-
93-
void Descriptor::Destroy() {
94-
if (const DescriptorAddendum * addendum{Addendum()}) {
95-
if (addendum->flags() & DescriptorAddendum::Created) {
96-
std::free(reinterpret_cast<void *>(this));
97-
}
98-
}
88+
return std::unique_ptr<Descriptor>{result};
9989
}
10090

10191
std::size_t Descriptor::SizeInBytes() const {
@@ -113,11 +103,75 @@ std::size_t Descriptor::Elements() const {
113103
return elements;
114104
}
115105

106+
int Descriptor::Allocate(
107+
const SubscriptValue lb[], const SubscriptValue ub[], std::size_t charLen) {
108+
int result{ISO::CFI_allocate(&raw_, lb, ub, charLen)};
109+
if (result == CFI_SUCCESS) {
110+
// TODO: derived type initialization
111+
}
112+
return result;
113+
}
114+
115+
int Descriptor::Deallocate(bool finalize) {
116+
if (raw_.base_addr != nullptr) {
117+
Destroy(static_cast<char *>(raw_.base_addr), finalize);
118+
}
119+
return ISO::CFI_deallocate(&raw_);
120+
}
121+
122+
void Descriptor::Destroy(char *data, bool finalize) const {
123+
if (data != nullptr) {
124+
if (const DescriptorAddendum * addendum{Addendum()}) {
125+
if (addendum->flags() & DescriptorAddendum::DoNotFinalize) {
126+
finalize = false;
127+
}
128+
if (const DerivedType * dt{addendum->derivedType()}) {
129+
std::size_t elements{Elements()};
130+
std::size_t elementBytes{ElementBytes()};
131+
for (std::size_t j{0}; j < elements; ++j) {
132+
dt->Destroy(data + j * elementBytes, finalize);
133+
}
134+
}
135+
}
136+
}
137+
}
138+
116139
void Descriptor::Check() const {
117140
// TODO
118141
}
119142

143+
std::ostream &Descriptor::Dump(std::ostream &o) const {
144+
o << "Descriptor @ 0x" << std::hex << reinterpret_cast<std::intptr_t>(this)
145+
<< std::dec << ":\n";
146+
o << " base_addr 0x" << std::hex
147+
<< reinterpret_cast<std::intptr_t>(raw_.base_addr) << std::dec << '\n';
148+
o << " elem_len " << raw_.elem_len << '\n';
149+
o << " version " << raw_.version
150+
<< (raw_.version == CFI_VERSION ? "(ok)" : "BAD!") << '\n';
151+
o << " rank " << static_cast<int>(raw_.rank) << '\n';
152+
o << " type " << static_cast<int>(raw_.type) << '\n';
153+
o << " attribute " << static_cast<int>(raw_.attribute) << '\n';
154+
o << " addendum? " << static_cast<bool>(raw_.f18Addendum) << '\n';
155+
for (int j{0}; j < raw_.rank; ++j) {
156+
o << " dim[" << j << "] lower_bound " << raw_.dim[j].lower_bound << '\n';
157+
o << " extent " << raw_.dim[j].extent << '\n';
158+
o << " sm " << raw_.dim[j].sm << '\n';
159+
}
160+
if (const DescriptorAddendum * addendum{Addendum()}) {
161+
addendum->Dump(o);
162+
}
163+
return o;
164+
}
165+
120166
std::size_t DescriptorAddendum::SizeInBytes() const {
121167
return SizeInBytes(LenParameters());
122168
}
169+
170+
std::ostream &DescriptorAddendum::Dump(std::ostream &o) const {
171+
o << " derivedType @ 0x" << std::hex
172+
<< reinterpret_cast<std::intptr_t>(derivedType_) << std::dec << '\n';
173+
o << " flags " << flags_ << '\n';
174+
// TODO: LEN parameter values
175+
return o;
176+
}
123177
} // namespace Fortran::runtime

0 commit comments

Comments
 (0)