[flang] Use fir.rebox for tbp fir.dispatch call with allocatable or pointer

[clementval]

Summary

Polymorphic entities with allocatable or pointer attribute cannot be passed
directly as passed-object when the type-bound procedure is expecting a
simply dummy polymorphic entity. Use fir.rebox to adapt the fir.class box
to the tbp type.

Depends on D135649

[jeanPerier]

LGTM

[clementval]

clang-format

[clementval]

Rebase

flang/include/flang/Optimizer/Dialect/FIROps.td

```mlir
       %1 = fir.shift %c0 : (index) -> !fir.shift<1>
       %2 = fir.rebox %x(%1) [%0] : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>, !fir.slice<1>) -> !fir.box<!fir.array<?xf32>>
       %3 = fir.shape %c3, %c4 : (index, index) -> !fir.shape<2>
       %4 = fir.rebox %2(%3) : (!fir.box<!fir.array<?xf32>>, !fir.shape<2>) -> !fir.box<!fir.array<?x?xf32>>
     ```
   }];
 
   let arguments = (ins
-    fir_BoxType:$box,
+    BoxOrClassType:$box,
     Optional<AnyShapeOrShiftType>:$shape,
     Optional<fir_SliceType>:$slice
   );
 
-  let results = (outs fir_BoxType);
+  let results = (outs BoxOrClassType);
 
   let assemblyFormat = [{
     $box (`(` $shape^ `)`)? (`[` $slice^ `]`)? attr-dict `:` functional-type(operands, results)
   }];
 
   let hasVerifier = 1;
 }
 

flang/lib/Optimizer/Builder/FIRBuilder.cpp

if (fir::isa_ref_type(toTy) && fir::isa_box_type(fromTy)) {
     // Call is expecting a raw data pointer, not a box. Get the data pointer out
     // of the box and pass that.
     assert((fir::unwrapRefType(toTy) ==
                 fir::unwrapRefType(fir::unwrapPassByRefType(fromTy)) &&
             "element types expected to match"));
     return create<fir::BoxAddrOp>(loc, toTy, val);
   }
 
+  if (fir::isPolymorphicType(fromTy) && fir::isPolymorphicType(toTy)) {
+    return create<fir::ReboxOp>(loc, toTy, val, mlir::Value{},
+                                /*slice=*/mlir::Value{});
+  }
+
   return createConvert(loc, toTy, val);
 }
 
 mlir::Value fir::FirOpBuilder::createConvert(mlir::Location loc,
                                              mlir::Type toTy, mlir::Value val) {
   if (val.getType() != toTy) {
     assert(!fir::isa_derived(toTy));
     return create<fir::ConvertOp>(loc, toTy, val);

flang/test/Fir/invalid.fir

 // expected-error@+1{{'fir.string_lit' op values in initializer must be integers}}
 %2 = fir.string_lit [158, 2.0](2) : !fir.char<2>
 
 // -----
 
 func.func @bad_rebox_1(%arg0: !fir.ref<!fir.array<?x?xf32>>) {
   %c10 = arith.constant 10 : index
   %0 = fir.shape %c10 : (index) -> !fir.shape<1>
-  // expected-error@+1{{op operand #0 must be The type of a Fortran descriptor, but got '!fir.ref<!fir.array<?x?xf32>>'}}
+  // expected-error@+1{{op operand #0 must be box or class, but got '!fir.ref<!fir.array<?x?xf32>>'}}
   %1 = fir.rebox %arg0(%0) : (!fir.ref<!fir.array<?x?xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<?xf32>>
   return
 }
 
 // -----
 
 func.func @bad_rebox_2(%arg0: !fir.box<!fir.array<?x?xf32>>) {
   %c10 = arith.constant 10 : index
   %0 = fir.shape %c10 : (index) -> !fir.shape<1>
-  // expected-error@+1{{op result #0 must be The type of a Fortran descriptor, but got '!fir.ref<!fir.array<?xf32>>'}}
+  // expected-error@+1{{op result #0 must be box or class, but got '!fir.ref<!fir.array<?xf32>>'}}
   %1 = fir.rebox %arg0(%0) : (!fir.box<!fir.array<?x?xf32>>, !fir.shape<1>) -> !fir.ref<!fir.array<?xf32>>
   return
 }
 
 // -----
 
 func.func @bad_rebox_3(%arg0: !fir.box<!fir.array<*:f32>>) {
   %c10 = arith.constant 10 : index

flang/test/Lower/dispatch.f90

subroutine check_dispatch_deferred(a, x)
     call a%nopassd(x)
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_deferred(
 ! CHECK-SAME: %[[ARG0:.*]]: !fir.class<!fir.type<_QMcall_dispatchTa1{a:f32,b:f32}>> {fir.bindc_name = "a"}, 
 ! CHECK-SAME: %[[ARG1:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "x"}) {
 ! CHECK: fir.dispatch "nopassd"(%[[ARG0]] : !fir.class<!fir.type<_QMcall_dispatchTa1{a:f32,b:f32}>>) (%[[ARG1]] : !fir.box<!fir.array<?xf32>>)
 
+    subroutine check_dispatch_scalar_allocatable(p)
+      class(p1), allocatable :: p
+      call p%tbp_pass()
+    end subroutine
+
+! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_scalar_allocatable(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>>> {fir.bindc_name = "p"}) {
+! CHECK: %[[LOAD:.*]] = fir.load %[[ARG0]] : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>>>
+! CHECK: %[[REBOX:.*]] = fir.rebox %[[LOAD]] : (!fir.class<!fir.heap<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>>) -> !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>
+! CHECK: fir.dispatch "tbp_pass"(%[[REBOX]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%1 : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 0 : i32}
+
+    subroutine check_dispatch_scalar_pointer(p)
+      class(p1), pointer :: p
+      call p%tbp_pass()
+    end subroutine
+
+! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_scalar_pointer(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>>> {fir.bindc_name = "p"}) {
+! CHECK: %[[LOAD:.*]] = fir.load %[[ARG0]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>>>
+! CHECK: %[[REBOX:.*]] = fir.rebox %[[LOAD]] : (!fir.class<!fir.ptr<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>>) -> !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>
+! CHECK: fir.dispatch "tbp_pass"(%[[REBOX]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%1 : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 0 : i32}
+
 ! ------------------------------------------------------------------------------
 ! Test that direct call is emitted when the type is known
 ! ------------------------------------------------------------------------------
 
     subroutine check_nodispatch(t)
       type(p1) :: t
       call t%tbp_nopass()
       call t%tbp_pass()