1 //===-- runtime/ISO_Fortran_binding.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 // Implements the required interoperability API from ISO_Fortran_binding.h
10 // as specified in section 18.5.5 of Fortran 2018.
11 
12 #include "flang/ISO_Fortran_binding.h"
13 #include "flang/Runtime/descriptor.h"
14 #include <cstdlib>
15 
16 namespace Fortran::ISO {
17 extern "C" {
18 
IsCharacterType(CFI_type_t ty)19 static inline constexpr bool IsCharacterType(CFI_type_t ty) {
20   return ty == CFI_type_char || ty == CFI_type_char16_t ||
21       ty == CFI_type_char32_t;
22 }
IsAssumedSize(const CFI_cdesc_t * dv)23 static inline constexpr bool IsAssumedSize(const CFI_cdesc_t *dv) {
24   return dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1;
25 }
26 
CFI_address(const CFI_cdesc_t * descriptor,const CFI_index_t subscripts[])27 void *CFI_address(
28     const CFI_cdesc_t *descriptor, const CFI_index_t subscripts[]) {
29   char *p{static_cast<char *>(descriptor->base_addr)};
30   const CFI_rank_t rank{descriptor->rank};
31   const CFI_dim_t *dim{descriptor->dim};
32   for (CFI_rank_t j{0}; j < rank; ++j, ++dim) {
33     p += (subscripts[j] - dim->lower_bound) * dim->sm;
34   }
35   return p;
36 }
37 
CFI_allocate(CFI_cdesc_t * descriptor,const CFI_index_t lower_bounds[],const CFI_index_t upper_bounds[],std::size_t elem_len)38 int CFI_allocate(CFI_cdesc_t *descriptor, const CFI_index_t lower_bounds[],
39     const CFI_index_t upper_bounds[], std::size_t elem_len) {
40   if (!descriptor) {
41     return CFI_INVALID_DESCRIPTOR;
42   }
43   if (descriptor->version != CFI_VERSION) {
44     return CFI_INVALID_DESCRIPTOR;
45   }
46   if (descriptor->attribute != CFI_attribute_allocatable &&
47       descriptor->attribute != CFI_attribute_pointer) {
48     // Non-interoperable object
49     return CFI_INVALID_ATTRIBUTE;
50   }
51   if (descriptor->attribute == CFI_attribute_allocatable &&
52       descriptor->base_addr) {
53     return CFI_ERROR_BASE_ADDR_NOT_NULL;
54   }
55   if (descriptor->rank > CFI_MAX_RANK) {
56     return CFI_INVALID_RANK;
57   }
58   if (descriptor->type < CFI_type_signed_char ||
59       descriptor->type > CFI_TYPE_LAST) {
60     return CFI_INVALID_TYPE;
61   }
62   if (!IsCharacterType(descriptor->type)) {
63     elem_len = descriptor->elem_len;
64     if (elem_len <= 0) {
65       return CFI_INVALID_ELEM_LEN;
66     }
67   }
68   std::size_t rank{descriptor->rank};
69   CFI_dim_t *dim{descriptor->dim};
70   std::size_t byteSize{elem_len};
71   for (std::size_t j{0}; j < rank; ++j, ++dim) {
72     CFI_index_t lb{lower_bounds[j]};
73     CFI_index_t ub{upper_bounds[j]};
74     CFI_index_t extent{ub >= lb ? ub - lb + 1 : 0};
75     dim->lower_bound = extent == 0 ? 1 : lb;
76     dim->extent = extent;
77     dim->sm = byteSize;
78     byteSize *= extent;
79   }
80   void *p{std::malloc(byteSize)};
81   if (!p && byteSize) {
82     return CFI_ERROR_MEM_ALLOCATION;
83   }
84   descriptor->base_addr = p;
85   descriptor->elem_len = elem_len;
86   return CFI_SUCCESS;
87 }
88 
CFI_deallocate(CFI_cdesc_t * descriptor)89 int CFI_deallocate(CFI_cdesc_t *descriptor) {
90   if (!descriptor) {
91     return CFI_INVALID_DESCRIPTOR;
92   }
93   if (descriptor->version != CFI_VERSION) {
94     return CFI_INVALID_DESCRIPTOR;
95   }
96   if (descriptor->attribute != CFI_attribute_allocatable &&
97       descriptor->attribute != CFI_attribute_pointer) {
98     // Non-interoperable object
99     return CFI_INVALID_DESCRIPTOR;
100   }
101   if (!descriptor->base_addr) {
102     return CFI_ERROR_BASE_ADDR_NULL;
103   }
104   std::free(descriptor->base_addr);
105   descriptor->base_addr = nullptr;
106   return CFI_SUCCESS;
107 }
108 
MinElemLen(CFI_type_t type)109 static constexpr std::size_t MinElemLen(CFI_type_t type) {
110   std::size_t minElemLen{0};
111   switch (type) {
112   case CFI_type_signed_char:
113     minElemLen = sizeof(signed char);
114     break;
115   case CFI_type_short:
116     minElemLen = sizeof(short);
117     break;
118   case CFI_type_int:
119     minElemLen = sizeof(int);
120     break;
121   case CFI_type_long:
122     minElemLen = sizeof(long);
123     break;
124   case CFI_type_long_long:
125     minElemLen = sizeof(long long);
126     break;
127   case CFI_type_size_t:
128     minElemLen = sizeof(std::size_t);
129     break;
130   case CFI_type_int8_t:
131     minElemLen = sizeof(std::int8_t);
132     break;
133   case CFI_type_int16_t:
134     minElemLen = sizeof(std::int16_t);
135     break;
136   case CFI_type_int32_t:
137     minElemLen = sizeof(std::int32_t);
138     break;
139   case CFI_type_int64_t:
140     minElemLen = sizeof(std::int64_t);
141     break;
142   case CFI_type_int128_t:
143     minElemLen = 2 * sizeof(std::int64_t);
144     break;
145   case CFI_type_int_least8_t:
146     minElemLen = sizeof(std::int_least8_t);
147     break;
148   case CFI_type_int_least16_t:
149     minElemLen = sizeof(std::int_least16_t);
150     break;
151   case CFI_type_int_least32_t:
152     minElemLen = sizeof(std::int_least32_t);
153     break;
154   case CFI_type_int_least64_t:
155     minElemLen = sizeof(std::int_least64_t);
156     break;
157   case CFI_type_int_least128_t:
158     minElemLen = 2 * sizeof(std::int_least64_t);
159     break;
160   case CFI_type_int_fast8_t:
161     minElemLen = sizeof(std::int_fast8_t);
162     break;
163   case CFI_type_int_fast16_t:
164     minElemLen = sizeof(std::int_fast16_t);
165     break;
166   case CFI_type_int_fast32_t:
167     minElemLen = sizeof(std::int_fast32_t);
168     break;
169   case CFI_type_int_fast64_t:
170     minElemLen = sizeof(std::int_fast64_t);
171     break;
172   case CFI_type_intmax_t:
173     minElemLen = sizeof(std::intmax_t);
174     break;
175   case CFI_type_intptr_t:
176     minElemLen = sizeof(std::intptr_t);
177     break;
178   case CFI_type_ptrdiff_t:
179     minElemLen = sizeof(std::ptrdiff_t);
180     break;
181   case CFI_type_half_float:
182     minElemLen = 2;
183     break;
184   case CFI_type_bfloat:
185     minElemLen = 2;
186     break;
187   case CFI_type_float:
188     minElemLen = sizeof(float);
189     break;
190   case CFI_type_double:
191     minElemLen = sizeof(double);
192     break;
193   case CFI_type_extended_double:
194     minElemLen = 10;
195     break;
196   case CFI_type_long_double:
197     minElemLen = sizeof(long double);
198     break;
199   case CFI_type_float128:
200     minElemLen = 16;
201     break;
202   case CFI_type_half_float_Complex:
203     minElemLen = 2 * MinElemLen(CFI_type_half_float);
204     break;
205   case CFI_type_bfloat_Complex:
206     minElemLen = 2 * MinElemLen(CFI_type_bfloat);
207     break;
208   case CFI_type_float_Complex:
209     minElemLen = 2 * sizeof(float);
210     break;
211   case CFI_type_double_Complex:
212     minElemLen = 2 * sizeof(double);
213     break;
214   case CFI_type_extended_double_Complex:
215     minElemLen = 2 * MinElemLen(CFI_type_extended_double);
216     break;
217   case CFI_type_long_double_Complex:
218     minElemLen = 2 * sizeof(long double);
219     break;
220   case CFI_type_float128_Complex:
221     minElemLen = 2 * MinElemLen(CFI_type_float128);
222     break;
223   case CFI_type_Bool:
224     minElemLen = 1;
225     break;
226   case CFI_type_cptr:
227     minElemLen = sizeof(void *);
228     break;
229   case CFI_type_char16_t:
230     minElemLen = sizeof(char16_t);
231     break;
232   case CFI_type_char32_t:
233     minElemLen = sizeof(char32_t);
234     break;
235   }
236   return minElemLen;
237 }
238 
CFI_establish(CFI_cdesc_t * descriptor,void * base_addr,CFI_attribute_t attribute,CFI_type_t type,std::size_t elem_len,CFI_rank_t rank,const CFI_index_t extents[])239 int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr,
240     CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len,
241     CFI_rank_t rank, const CFI_index_t extents[]) {
242   if (attribute != CFI_attribute_other && attribute != CFI_attribute_pointer &&
243       attribute != CFI_attribute_allocatable) {
244     return CFI_INVALID_ATTRIBUTE;
245   }
246   if (rank > CFI_MAX_RANK) {
247     return CFI_INVALID_RANK;
248   }
249   if (base_addr && attribute == CFI_attribute_allocatable) {
250     return CFI_ERROR_BASE_ADDR_NOT_NULL;
251   }
252   if (rank > 0 && base_addr && !extents) {
253     return CFI_INVALID_EXTENT;
254   }
255   if (type < CFI_type_signed_char || type > CFI_TYPE_LAST) {
256     return CFI_INVALID_TYPE;
257   }
258   if (!descriptor) {
259     return CFI_INVALID_DESCRIPTOR;
260   }
261   if (type == CFI_type_struct || type == CFI_type_other ||
262       IsCharacterType(type)) {
263     if (elem_len <= 0) {
264       return CFI_INVALID_ELEM_LEN;
265     }
266   } else {
267     elem_len = MinElemLen(type);
268     assert(elem_len > 0 && "Unknown element length for type");
269   }
270   descriptor->base_addr = base_addr;
271   descriptor->elem_len = elem_len;
272   descriptor->version = CFI_VERSION;
273   descriptor->rank = rank;
274   descriptor->type = type;
275   descriptor->attribute = attribute;
276   descriptor->f18Addendum = 0;
277   std::size_t byteSize{elem_len};
278   constexpr std::size_t lower_bound{0};
279   if (base_addr) {
280     for (std::size_t j{0}; j < rank; ++j) {
281       descriptor->dim[j].lower_bound = lower_bound;
282       descriptor->dim[j].extent = extents[j];
283       descriptor->dim[j].sm = byteSize;
284       byteSize *= extents[j];
285     }
286   }
287   return CFI_SUCCESS;
288 }
289 
CFI_is_contiguous(const CFI_cdesc_t * descriptor)290 int CFI_is_contiguous(const CFI_cdesc_t *descriptor) {
291   CFI_index_t bytes = descriptor->elem_len;
292   for (int j{0}; j < descriptor->rank; ++j) {
293     if (bytes != descriptor->dim[j].sm) {
294       return 0;
295     }
296     bytes *= descriptor->dim[j].extent;
297   }
298   return 1;
299 }
300 
CFI_section(CFI_cdesc_t * result,const CFI_cdesc_t * source,const CFI_index_t lower_bounds[],const CFI_index_t upper_bounds[],const CFI_index_t strides[])301 int CFI_section(CFI_cdesc_t *result, const CFI_cdesc_t *source,
302     const CFI_index_t lower_bounds[], const CFI_index_t upper_bounds[],
303     const CFI_index_t strides[]) {
304   CFI_index_t extent[CFI_MAX_RANK];
305   CFI_index_t actualStride[CFI_MAX_RANK];
306   CFI_rank_t resRank{0};
307 
308   if (!result || !source) {
309     return CFI_INVALID_DESCRIPTOR;
310   }
311   if (source->rank == 0) {
312     return CFI_INVALID_RANK;
313   }
314   if (IsAssumedSize(source) && !upper_bounds) {
315     return CFI_INVALID_DESCRIPTOR;
316   }
317   if ((result->type != source->type) ||
318       (result->elem_len != source->elem_len)) {
319     return CFI_INVALID_DESCRIPTOR;
320   }
321   if (result->attribute == CFI_attribute_allocatable) {
322     return CFI_INVALID_ATTRIBUTE;
323   }
324   if (!source->base_addr) {
325     return CFI_ERROR_BASE_ADDR_NULL;
326   }
327 
328   char *shiftedBaseAddr{static_cast<char *>(source->base_addr)};
329   bool isZeroSized{false};
330   for (int j{0}; j < source->rank; ++j) {
331     const CFI_dim_t &dim{source->dim[j]};
332     const CFI_index_t srcLB{dim.lower_bound};
333     const CFI_index_t srcUB{srcLB + dim.extent - 1};
334     const CFI_index_t lb{lower_bounds ? lower_bounds[j] : srcLB};
335     const CFI_index_t ub{upper_bounds ? upper_bounds[j] : srcUB};
336     const CFI_index_t stride{strides ? strides[j] : 1};
337 
338     if (stride == 0 && lb != ub) {
339       return CFI_ERROR_OUT_OF_BOUNDS;
340     }
341     if ((lb <= ub && stride >= 0) || (lb >= ub && stride < 0)) {
342       if ((lb < srcLB) || (lb > srcUB) || (ub < srcLB) || (ub > srcUB)) {
343         return CFI_ERROR_OUT_OF_BOUNDS;
344       }
345       shiftedBaseAddr += (lb - srcLB) * dim.sm;
346       extent[j] = stride != 0 ? 1 + (ub - lb) / stride : 1;
347     } else {
348       isZeroSized = true;
349       extent[j] = 0;
350     }
351     actualStride[j] = stride;
352     resRank += (stride != 0);
353   }
354   if (resRank != result->rank) {
355     return CFI_INVALID_DESCRIPTOR;
356   }
357 
358   // For zero-sized arrays, base_addr is processor-dependent (see 18.5.3).
359   // We keep it on the source base_addr
360   result->base_addr = isZeroSized ? source->base_addr : shiftedBaseAddr;
361   resRank = 0;
362   for (int j{0}; j < source->rank; ++j) {
363     if (actualStride[j] != 0) {
364       result->dim[resRank].extent = extent[j];
365       result->dim[resRank].lower_bound = extent[j] == 0 ? 1
366           : lower_bounds                                ? lower_bounds[j]
367                          : source->dim[j].lower_bound;
368       result->dim[resRank].sm = actualStride[j] * source->dim[j].sm;
369       ++resRank;
370     }
371   }
372   return CFI_SUCCESS;
373 }
374 
CFI_select_part(CFI_cdesc_t * result,const CFI_cdesc_t * source,std::size_t displacement,std::size_t elem_len)375 int CFI_select_part(CFI_cdesc_t *result, const CFI_cdesc_t *source,
376     std::size_t displacement, std::size_t elem_len) {
377   if (!result || !source) {
378     return CFI_INVALID_DESCRIPTOR;
379   }
380   if (result->rank != source->rank) {
381     return CFI_INVALID_RANK;
382   }
383   if (result->attribute == CFI_attribute_allocatable) {
384     return CFI_INVALID_ATTRIBUTE;
385   }
386   if (!source->base_addr) {
387     return CFI_ERROR_BASE_ADDR_NULL;
388   }
389   if (IsAssumedSize(source)) {
390     return CFI_INVALID_DESCRIPTOR;
391   }
392 
393   if (!IsCharacterType(result->type)) {
394     elem_len = result->elem_len;
395   }
396   if (displacement + elem_len > source->elem_len) {
397     return CFI_INVALID_ELEM_LEN;
398   }
399 
400   result->base_addr = displacement + static_cast<char *>(source->base_addr);
401   result->elem_len = elem_len;
402   for (int j{0}; j < source->rank; ++j) {
403     result->dim[j].lower_bound = 0;
404     result->dim[j].extent = source->dim[j].extent;
405     result->dim[j].sm = source->dim[j].sm;
406   }
407   return CFI_SUCCESS;
408 }
409 
CFI_setpointer(CFI_cdesc_t * result,const CFI_cdesc_t * source,const CFI_index_t lower_bounds[])410 int CFI_setpointer(CFI_cdesc_t *result, const CFI_cdesc_t *source,
411     const CFI_index_t lower_bounds[]) {
412   if (!result) {
413     return CFI_INVALID_DESCRIPTOR;
414   }
415   if (result->attribute != CFI_attribute_pointer) {
416     return CFI_INVALID_ATTRIBUTE;
417   }
418   if (!source) {
419     result->base_addr = nullptr;
420     return CFI_SUCCESS;
421   }
422   if (source->rank != result->rank) {
423     return CFI_INVALID_RANK;
424   }
425   if (source->type != result->type) {
426     return CFI_INVALID_TYPE;
427   }
428   if (source->elem_len != result->elem_len) {
429     return CFI_INVALID_ELEM_LEN;
430   }
431   if (!source->base_addr && source->attribute != CFI_attribute_pointer) {
432     return CFI_ERROR_BASE_ADDR_NULL;
433   }
434   if (IsAssumedSize(source)) {
435     return CFI_INVALID_DESCRIPTOR;
436   }
437 
438   const bool copySrcLB{!lower_bounds};
439   result->base_addr = source->base_addr;
440   if (source->base_addr) {
441     for (int j{0}; j < result->rank; ++j) {
442       CFI_index_t extent{source->dim[j].extent};
443       result->dim[j].extent = extent;
444       result->dim[j].sm = source->dim[j].sm;
445       result->dim[j].lower_bound = extent == 0 ? 1
446           : copySrcLB                          ? source->dim[j].lower_bound
447                                                : lower_bounds[j];
448     }
449   }
450   return CFI_SUCCESS;
451 }
452 } // extern "C"
453 } // namespace Fortran::ISO
454