[flang] Fold TRANSFER()

[klausler]

Summary

Fold usage of the raw data reinterpretation intrinsic function TRANSFER().

flang/include/flang/Evaluate/constant.h

 
   Constant Reshape(ConstantSubscripts &&) const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
-  static constexpr DynamicType GetType() {
-    return {TypeCategory::Character, KIND};
-  }
+  DynamicType GetType() const { return {KIND, length_}; }
   std::size_t CopyFrom(const Constant &source, std::size_t count,
       ConstantSubscripts &resultSubscripts, const std::vector<int> *dimOrder);
 

flang/include/flang/Evaluate/initial-image.h

       } else if (bytes == 0) {
         return Ok;
       } else {
+        // TODO endianness
         std::memcpy(&data_.at(offset), &x.values().at(0), bytes);
         return Ok;
       }

               (scalarBytes > elementBytes && elements != 0)) {
             return SizeMismatch;
           }
+          // TODO endianness
           std::memcpy(&data_.at(offset), scalar.data(), elementBytes);
           offset += elementBytes;
         }

 
   // Conversions to constant initializers
   std::optional<Expr<SomeType>> AsConstant(FoldingContext &,
-      const DynamicType &, const ConstantSubscripts &,
+      const DynamicType &, const ConstantSubscripts &, bool padWithZero = false,
       ConstantSubscript offset = 0) const;
   std::optional<Expr<SomeType>> AsConstantPointer(
       ConstantSubscript offset = 0) const;

flang/lib/Evaluate/fold-character.cpp

           CharacterUtils<KIND>::TRIM(std::get<Scalar<T>>(*scalar))}};
     }
   }
-  // TODO: transfer
   return Expr<T>{std::move(funcRef)};
 }
 

flang/lib/Evaluate/fold-complex.cpp

   } else if (name == "sum") {
     return FoldSum<T>(context, std::move(funcRef));
   }
-  // TODO: dot_product, matmul, transfer
+  // TODO: dot_product, matmul
   return Expr<T>{std::move(funcRef)};
 }
 

flang/lib/Evaluate/fold-implementation.h

   Expr<T> TRANSPOSE(FunctionRef<T> &&);
   Expr<T> UNPACK(FunctionRef<T> &&);
 
+  Expr<T> TRANSFER(FunctionRef<T> &&);
+
 private:
   FoldingContext &context_;
 };

       PackageConstant<T>(std::move(resultElements), *vector, mask->shape())};
 }
 
+std::optional<Expr<SomeType>> FoldTransfer(
+    FoldingContext &, const ActualArguments &);
+
+template <typename T> Expr<T> Folder<T>::TRANSFER(FunctionRef<T> &&funcRef) {
+  if (auto folded{FoldTransfer(context_, funcRef.arguments())}) {
+    return DEREF(UnwrapExpr<Expr<T>>(*folded));
+  } else {
+    return Expr<T>{std::move(funcRef)};
+  }
+}
+
 template <typename T>
 Expr<T> FoldMINorMAX(
     FoldingContext &context, FunctionRef<T> &&funcRef, Ordering order) {

       return Folder<T>{context}.RESHAPE(std::move(funcRef));
     } else if (name == "spread") {
       return Folder<T>{context}.SPREAD(std::move(funcRef));
+    } else if (name == "transfer") {
+      return Folder<T>{context}.TRANSFER(std::move(funcRef));
     } else if (name == "transpose") {
       return Folder<T>{context}.TRANSPOSE(std::move(funcRef));
     } else if (name == "unpack") {

flang/lib/Evaluate/fold-integer.cpp

   } else if (name == "ubound") {
     return UBOUND(context, std::move(funcRef));
   }
-  // TODO: dot_product, ishftc, matmul, sign, transfer
+  // TODO: dot_product, ishftc, matmul, sign
   return Expr<T>{std::move(funcRef)};
 }
 

flang/lib/Evaluate/fold-logical.cpp

   }
   // TODO: dot_product, is_iostat_end,
   // is_iostat_eor, logical, matmul, out_of_range,
-  // parity, transfer
+  // parity
   return Expr<T>{std::move(funcRef)};
 }
 

flang/lib/Evaluate/fold-real.cpp

           return result.value;
         }));
   }
-  // TODO: dot_product, fraction, matmul, norm2, set_exponent, transfer
+  // TODO: dot_product, fraction, matmul, norm2, set_exponent
   return Expr<T>{std::move(funcRef)};
 }
 

flang/lib/Evaluate/fold.cpp

 #include "flang/Evaluate/fold.h"
 #include "fold-implementation.h"
 #include "flang/Evaluate/characteristics.h"
+#include "flang/Evaluate/initial-image.h"
 
 namespace Fortran::evaluate {
 

   }
 }
 
+// TRANSFER (F'2018 16.9.193)
+std::optional<Expr<SomeType>> FoldTransfer(
+    FoldingContext &context, const ActualArguments &arguments) {
+  CHECK(arguments.size() == 2 || arguments.size() == 3);
+  const auto *source{UnwrapExpr<Expr<SomeType>>(arguments[0])};
+  std::optional<std::size_t> sourceBytes;
+  if (source) {
+    if (auto sourceTypeAndShape{
+            characteristics::TypeAndShape::Characterize(*source, context)}) {
+      if (auto sourceBytesExpr{
+              sourceTypeAndShape->MeasureSizeInBytes(context)}) {
+        sourceBytes = ToInt64(*sourceBytesExpr);
+      }
+    }
+  }
+  std::optional<DynamicType> moldType;
+  if (arguments[1]) {
+    moldType = arguments[1]->GetType();
+  }
+  std::optional<ConstantSubscripts> extents;
+  if (arguments.size() == 2) { // no SIZE=
+    if (moldType && sourceBytes) {
+      if (arguments[1]->Rank() == 0) { // scalar MOLD=
+        extents = ConstantSubscripts{}; // empty extents (scalar result)
+      } else if (auto moldBytesExpr{
+                     moldType->MeasureSizeInBytes(context, true)}) {
+        if (auto moldBytes{ToInt64(Fold(context, std::move(*moldBytesExpr)))};
+            *moldBytes > 0) {
+          extents = ConstantSubscripts{
+              static_cast<ConstantSubscript>((*sourceBytes) + *moldBytes - 1) /
+              *moldBytes};
+        }
+      }
+    }
+  } else if (arguments[2]) { // SIZE= is present
+    if (const auto *sizeExpr{arguments[2]->UnwrapExpr()}) {
+      if (auto sizeValue{ToInt64(*sizeExpr)}) {
+        extents = ConstantSubscripts{*sizeValue};
+      }
+    }
+  }
+  if (sourceBytes && IsActuallyConstant(*source) && moldType && extents) {
+    InitialImage image{*sourceBytes};
+    InitialImage::Result imageResult{
+        image.Add(0, *sourceBytes, *source, context)};
+    CHECK(imageResult == InitialImage::Ok);
+    return image.AsConstant(context, *moldType, *extents, true /*pad with 0*/);
+  } else {
+    return std::nullopt;
+  }
+}
+
 template class ExpressionBase<SomeDerived>;
 template class ExpressionBase<SomeType>;
 

flang/lib/Evaluate/initial-image.cpp

   using Types = AllTypes;
   AsConstantHelper(FoldingContext &context, const DynamicType &type,
       const ConstantSubscripts &extents, const InitialImage &image,
-      ConstantSubscript offset = 0)
+      bool padWithZero = false, ConstantSubscript offset = 0)
       : context_{context}, type_{type}, image_{image}, extents_{extents},
-        offset_{offset} {
+        padWithZero_{padWithZero}, offset_{offset} {
     CHECK(!type.IsPolymorphic());
   }
   template <typename T> Result Test() {

         ToInt64(type_.MeasureSizeInBytes(context_, GetRank(extents_) > 0))};
     CHECK(elemBytes && *elemBytes >= 0);
     std::size_t stride{static_cast<std::size_t>(*elemBytes)};
-    CHECK(offset_ + elements * stride <= image_.data_.size());
+    CHECK(offset_ + elements * stride <= image_.data_.size() || padWithZero_);
     if constexpr (T::category == TypeCategory::Derived) {
       const semantics::DerivedTypeSpec &derived{type_.GetDerivedTypeSpec()};
       for (auto iter : DEREF(derived.scope())) {

             auto componentExtents{GetConstantExtents(context_, component)};
             CHECK(componentExtents.has_value());
             for (std::size_t j{0}; j < elements; ++j, at += stride) {
-              if (Result value{image_.AsConstant(
-                      context_, *componentType, *componentExtents, at)}) {
+              if (Result value{image_.AsConstant(context_, *componentType,
+                      *componentExtents, padWithZero_, at)}) {
                 typedValue[j].emplace(component, std::move(*value));
               }
             }

       auto length{static_cast<ConstantSubscript>(stride) / T::kind};
       for (std::size_t j{0}; j < elements; ++j) {
         using Char = typename Scalar::value_type;
-        const Char *data{reinterpret_cast<const Char *>(
-            &image_.data_[offset_ + j * stride])};
+        auto at{static_cast<std::size_t>(offset_ + j * stride)};
+        if (at + length > image_.data_.size()) {
+          CHECK(padWithZero_);
+          break;
+        }
+        const Char *data{reinterpret_cast<const Char *>(&image_.data_[at])};
         typedValue[j].assign(data, length);
       }
       return AsGenericExpr(

       // Lengthless intrinsic type
       CHECK(sizeof(Scalar) <= stride);
       for (std::size_t j{0}; j < elements; ++j) {
-        std::memcpy(&typedValue[j], &image_.data_[offset_ + j * stride],
-            sizeof(Scalar));
+        auto at{static_cast<std::size_t>(offset_ + j * stride)};
+        std::size_t chunk{sizeof(Scalar)};
+        if (at + chunk > image_.data_.size()) {
+          CHECK(padWithZero_);
+          if (at >= image_.data_.size()) {
+            break;
+          }
+          chunk = image_.data_.size() - at;
+        }
+        // TODO endianness
+        std::memcpy(&typedValue[j], &image_.data_[at], chunk);
       }
       return AsGenericExpr(Const{std::move(typedValue), std::move(extents_)});
     }

   const DynamicType &type_;
   const InitialImage &image_;
   ConstantSubscripts extents_; // a copy
+  bool padWithZero_;
   ConstantSubscript offset_;
 };
 
 std::optional<Expr<SomeType>> InitialImage::AsConstant(FoldingContext &context,
     const DynamicType &type, const ConstantSubscripts &extents,
-    ConstantSubscript offset) const {
+    bool padWithZero, ConstantSubscript offset) const {
   return common::SearchTypes(
-      AsConstantHelper{context, type, extents, *this, offset});
+      AsConstantHelper{context, type, extents, *this, padWithZero, offset});
 }
 
 std::optional<Expr<SomeType>> InitialImage::AsConstantPointer(

flang/lib/Semantics/data-to-inits.cpp

             if (auto dyType{evaluate::DynamicType::From(component)}) {
               if (auto extents{evaluate::GetConstantExtents(
                       foldingContext, component)}) {
-                if (auto extant{init.image.AsConstant(
-                        foldingContext, *dyType, *extents, componentOffset)}) {
+                if (auto extant{init.image.AsConstant(foldingContext, *dyType,
+                        *extents, false /*don't pad*/, componentOffset)}) {
                   initialized = !(*extant == *object->init());
                 }
               }

flang/test/Evaluate/fold-transfer.f90

+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of TRANSFER(...)
+
+module m
+  logical, parameter :: test_r2i_s_1 = transfer(1., 0) == int(z'3f800000')
+  logical, parameter :: test_r2i_v_1 = all(transfer(1., [integer::]) == [int(z'3f800000')])
+  logical, parameter :: test_r2i_v_2 = all(transfer([1., 2.], [integer::]) == [int(z'3f800000'), int(z'40000000')])
+  logical, parameter :: test_r2i_vs_1 = all(transfer([1., 2.], [integer::], 1) == [int(z'3f800000')])
+
+  type :: t
+    real :: x = 0.
+  end type t
+  logical, parameter :: test_t2i_s_1 = transfer(t(1.), 0) == int(z'3f800000')
+  logical, parameter :: test_t2i_v_1 = all(transfer(t(1.), [integer::]) == [int(z'3f800000')])
+  logical, parameter :: test_t2i_v_2 = all(transfer([t(1.), t(2.)], [integer::]) == [int(z'3f800000'), int(z'40000000')])
+  logical, parameter :: test_t2i_vs_1 = all(transfer([t(1.), t(2.)], [integer::], 1) == [int(z'3f800000')])
+
+  type(t), parameter :: t1 = transfer(1., t())
+  logical, parameter :: test_r2t_s_1 = t1%x == 1.
+  type(t), parameter :: t2(*) = transfer(1., [t::])
+  logical, parameter :: test_r2t_v_1 = all(t2%x == [1.])
+  type(t), parameter :: t3(*) = transfer([1., 2.], [t::])
+  logical, parameter :: test_r2t_v_2 = all(t3%x == [1., 2.])
+  type(t), parameter :: t4(*) = transfer([1., 2.], t(), 1)
+  logical, parameter :: test_r2t_vs_1 = all(t4%x == [1.])
+
+  logical, parameter :: test_nan = transfer(int(z'7ff8000000000000', 8), 0._8) /= transfer(int(z'7ff8000000000000', 8), 0._8)
+
+  integer, parameter :: jc1 = transfer("abcd", 0)
+  logical, parameter :: test_c2i_s_1 = jc1 == int(z'61626364') .or. jc1 == int(z'64636261')
+  integer, parameter :: jc2(*) = transfer("abcd", [integer::])
+  logical, parameter :: test_c2i_v_1 = all(jc2 == int(z'61626364') .or. jc1 == int(z'64636261'))
+  integer, parameter :: jc3(*) = transfer(["abcd", "efgh"], [integer::])
+  logical, parameter :: test_c2i_v_2 = all(jc3 == [int(z'61626364'), int(z'65666768')]) .or. all(jc3 == [int(z'64636261'), int(z'68676665')])
+  integer, parameter :: jc4(*) = transfer(["abcd", "efgh"], 0, 1)
+  logical, parameter :: test_c2i_vs_1 = all(jc4 == [int(z'61626364')]) .or. all(jc4 == [int(z'64636261')])
+end module

flang/test/Evaluate/folding10.f90

 ! RUN: %python %S/test_folding.py %s %flang_fc1
 ! Tests folding of SHAPE(TRANSFER(...))
+! Adjusted to allow for folding (or not) of TRANSFER().
 
 module m
+  integer :: j
+  real :: a(3)
+  logical, parameter :: test_size_v1 = size(shape(transfer(j, 0_1,size=4))) == 1
+  logical, parameter :: test_size_v2 = all(shape(transfer(j, 0_1,size=4)) == [4])
+  logical, parameter :: test_scalar_v1 = size(shape(transfer(j, 0_1))) == 0
+  logical, parameter :: test_vector_v1 = size(shape(transfer(j, [0_1]))) == 1
+  logical, parameter :: test_vector_v2 = all(shape(transfer(j, [0_1])) == [4])
+  logical, parameter :: test_array_v1 = size(shape(transfer(j, reshape([0_1],[1,1])))) == 1
+  logical, parameter :: test_array_v2 = all(shape(transfer(j, reshape([0_1],[1,1]))) == [4])
+  logical, parameter :: test_array_v3 = all(shape(transfer(a, [(0.,0.)])) == [2])
+
   logical, parameter :: test_size_1 = size(shape(transfer(123456789,0_1,size=4))) == 1
   logical, parameter :: test_size_2 = all(shape(transfer(123456789,0_1,size=4)) == [4])
   logical, parameter :: test_scalar_1 = size(shape(transfer(123456789, 0_1))) == 0

flang/test/Semantics/array-constr-values.f90

   ! C7111
   !ERROR: Value in array constructor of type 'LOGICAL(4)' could not be converted to the type of the array 'INTEGER(4)'
   intarray = [integer:: .true., 2, 3, 4, 5]
-  !ERROR: Value in array constructor of type 'CHARACTER(1)' could not be converted to the type of the array 'INTEGER(4)'
+  !ERROR: Value in array constructor of type 'CHARACTER(KIND=1,LEN=22_8)' could not be converted to the type of the array 'INTEGER(4)'
   intarray = [integer:: "RAM stores information", 2, 3, 4, 5]
   !ERROR: Value in array constructor of type 'employee' could not be converted to the type of the array 'INTEGER(4)'
   intarray = [integer:: EMPLOYEE (19, "Jack"), 2, 3, 4, 5]

flang/test/Semantics/case01.f90

 
   ! C1147
   select case (grade2)
-     !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
      case (:'Z')
      case default
    end select

      case (.true. :)
      !ERROR: CASE value has type 'REAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
      case (1.0)
-     !ERROR: CASE value has type 'CHARACTER(1)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=3_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
      case ('wow')
   end select
 
   select case (ASCII_parm1)
      case (ASCII_parm2)
-     !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (UCS32_parm)
-     !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (UCS16_parm)
-     !ERROR: CASE value has type 'CHARACTER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (4_"ucs-32")
-     !ERROR: CASE value has type 'CHARACTER(2)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(1)'
+     !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
      case (2_"ucs-16")
      case default
    end select

flang/test/Semantics/select-rank.f90

         RANK(1.0)
     !ERROR: Must be a constant value
         RANK(RANK(x))
-    !ERROR: Must have INTEGER type, but is CHARACTER(1)
+    !ERROR: Must have INTEGER type, but is CHARACTER(KIND=1,LEN=6_8)
         RANK("STRING")
     END SELECT
    end subroutine

flang/test/Semantics/structconst02.f90

 !    call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true._4))
     call scalararg(scalar(4)(ix=5.,rx=6,zx=(7._8,8._2),cx=4_'b',lx=.true.))
     call scalararg(scalar(4)(5.,6,(7._8,8._2),4_'b',.true.))
-    !ERROR: Value in structure constructor of type 'CHARACTER(1)' is incompatible with component 'ix' of type 'INTEGER(4)'
+    !ERROR: Value in structure constructor of type 'CHARACTER(KIND=1,LEN=1_8)' is incompatible with component 'ix' of type 'INTEGER(4)'
     call scalararg(scalar(4)(ix='a'))
     !ERROR: Value in structure constructor of type 'LOGICAL(4)' is incompatible with component 'ix' of type 'INTEGER(4)'
     call scalararg(scalar(4)(ix=.false.))