flang/test/Fir/dispatch.f90

   1 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | tco | FileCheck %s
   2 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s --check-prefix=BT
   3
   4 ! Tests codegen of fir.dispatch operation. This test is intentionally run from
   5 ! Fortran through bbc and tco so we have all the binding tables lowered to FIR
   6 ! from semantics.
   7
   8 module dispatch1
   9
  10   type p1
  11     integer :: a
  12     integer :: b
  13   contains
  14     procedure :: aproc
  15     procedure :: display1 => display1_p1
  16     procedure :: display2 => display2_p1
  17     procedure :: get_value => get_value_p1
  18     procedure :: proc_with_values => proc_p1
  19     procedure, nopass :: proc_nopass => proc_nopass_p1
  20     procedure, pass(this) :: proc_pass => proc_pass_p1
  21   end type
  22
  23   type, extends(p1) :: p2
  24     integer :: c
  25   contains
  26     procedure :: display1 => display1_p2
  27     procedure :: display2 => display2_p2
  28     procedure :: display3
  29     procedure :: get_value => get_value_p2
  30     procedure :: proc_with_values => proc_p2
  31     procedure, nopass :: proc_nopass => proc_nopass_p2
  32     procedure, pass(this) :: proc_pass => proc_pass_p2
  33   end type
  34
  35   type, abstract :: a1
  36     integer a
  37   contains
  38     procedure :: a1_proc
  39   end type
  40
  41   type, extends(a1) :: a2
  42     integer b
  43   contains
  44     procedure :: a1_proc => a2_proc
  45   end type
  46
  47   type ty_kind(i, j)
  48     integer, kind :: i, j
  49     integer :: a(i)
  50   end Type
  51
  52   type, extends(ty_kind) :: ty_kind_ex
  53     integer :: b(j)
  54   end type
  55   type(ty_kind(10,20)) :: tk1
  56   type(ty_kind_ex(10,20)) :: tke1
  57 contains
  58
  59   subroutine display1_p1(this)
  60     class(p1) :: this
  61     print*,'call display1_p1'
  62   end subroutine
  63
  64   subroutine display2_p1(this)
  65     class(p1) :: this
  66     print*,'call display2_p1'
  67   end subroutine
  68
  69   subroutine display1_p2(this)
  70     class(p2) :: this
  71     print*,'call display1_p2'
  72   end subroutine
  73
  74   subroutine display2_p2(this)
  75     class(p2) :: this
  76     print*,'call display2_p2'
  77   end subroutine
  78
  79   subroutine aproc(this)
  80     class(p1) :: this
  81     print*,'call aproc'
  82   end subroutine
  83
  84   subroutine display3(this)
  85     class(p2) :: this
  86     print*,'call display3'
  87   end subroutine
  88
  89   function get_value_p1(this)
  90     class(p1) :: this
  91     integer :: get_value_p1
  92     get_value_p1 = 10
  93   end function
  94
  95   function get_value_p2(this)
  96     class(p2) :: this
  97     integer :: get_value_p2
  98     get_value_p2 = 10
  99   end function
 100
 101   subroutine proc_p1(this, v)
 102     class(p1) :: this
 103     real :: v
 104     print*, 'call proc1 with ', v
 105   end subroutine
 106
 107   subroutine proc_p2(this, v)
 108     class(p2) :: this
 109     real :: v
 110     print*, 'call proc1 with ', v
 111   end subroutine
 112
 113   subroutine proc_nopass_p1()
 114     print*, 'call proc_nopass_p1'
 115   end subroutine
 116
 117   subroutine proc_nopass_p2()
 118     print*, 'call proc_nopass_p2'
 119   end subroutine
 120
 121   subroutine proc_pass_p1(i, this)
 122     integer :: i
 123     class(p1) :: this
 124     print*, 'call proc_nopass_p1'
 125   end subroutine
 126
 127   subroutine proc_pass_p2(i, this)
 128     integer :: i
 129     class(p2) :: this
 130     print*, 'call proc_nopass_p2'
 131   end subroutine
 132
 133   subroutine display_class(p)
 134     class(p1) :: p
 135     integer :: i
 136     call p%display2()
 137     call p%display1()
 138     call p%aproc()
 139     i = p%get_value()
 140     call p%proc_with_values(2.5)
 141     call p%proc_nopass()
 142     call p%proc_pass(1)
 143   end subroutine
 144
 145   subroutine no_pass_array(a)
 146     class(p1) :: a(:)
 147     call a(1)%proc_nopass()
 148   end subroutine
 149
 150   subroutine no_pass_array_allocatable(a)
 151     class(p1), allocatable :: a(:)
 152     call a(1)%proc_nopass()
 153   end subroutine
 154
 155   subroutine no_pass_array_pointer(a)
 156     class(p1), allocatable :: a(:)
 157     call a(1)%proc_nopass()
 158   end subroutine
 159
 160   subroutine a1_proc(this)
 161     class(a1) :: this
 162   end subroutine
 163
 164   subroutine a2_proc(this)
 165     class(a2) :: this
 166   end subroutine
 167
 168   subroutine call_a1_proc(p)
 169     class(a1), pointer :: p
 170     call p%a1_proc()
 171   end subroutine
 172
 173 end module
 174
 175 program test_type_to_class
 176   use dispatch1
 177   type(p1) :: t1 = p1(1,2)
 178   type(p2) :: t2 = p2(1,2,3)
 179
 180   call display_class(t1)
 181   call display_class(t2)
 182 end
 183
 184
 185 ! CHECK-LABEL: define void @_QMdispatch1Pdisplay_class(
 186 ! CHECK-SAME: ptr %[[CLASS:.*]])
 187
 188 ! CHECK-DAG: %[[INT32:.*]] = alloca i32, i64 1
 189 ! CHECK-DAG: %[[REAL:.*]] = alloca float, i64 1
 190 ! CHECK-DAG: %[[I:.*]] = alloca i32, i64 1
 191
 192 ! Check dynamic dispatch equal to `call p%display2()` with binding index = 2.
 193 ! CHECK: %[[LOADED_CLASS:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[CLASS]]
 194 ! CHECK: %[[TYPEDESCPTR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOADED_CLASS]], 7
 195 ! CHECK: %[[LOADED_TYPEDESC:.*]] = load %_QM__fortran_type_infoTderivedtype, ptr %[[TYPEDESCPTR]]
 196 ! CHECK: %[[DT:.*]] = extractvalue %_QM__fortran_type_infoTderivedtype %[[LOADED_TYPEDESC]], 0
 197 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 198 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 2
 199 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 200 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 201 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 202 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 203 ! CHECK: call void %[[FUNC_PTR]](ptr %[[CLASS]])
 204
 205 ! Check dynamic dispatch equal to `call p%display1()` with binding index = 1.
 206 ! CHECK: %[[LOADED_CLASS:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[CLASS]]
 207 ! CHECK: %[[TYPEDESCPTR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOADED_CLASS]], 7
 208 ! CHECK: %[[LOADED_TYPEDESC:.*]] = load %_QM__fortran_type_infoTderivedtype, ptr %[[TYPEDESCPTR]]
 209 ! CHECK: %[[DT:.*]] = extractvalue %_QM__fortran_type_infoTderivedtype %[[LOADED_TYPEDESC]], 0
 210 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 211 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 1
 212 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 213 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 214 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 215 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 216 ! CHECK: call void %[[FUNC_PTR]](ptr %[[CLASS]])
 217
 218 ! Check dynamic dispatch equal to `call p%aproc()` with binding index = 0.
 219 ! CHECK: %[[LOADED_CLASS:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[CLASS]]
 220 ! CHECK: %[[TYPEDESCPTR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOADED_CLASS]], 7
 221 ! CHECK: %[[LOADED_TYPEDESC:.*]] = load %_QM__fortran_type_infoTderivedtype, ptr %[[TYPEDESCPTR]]
 222 ! CHECK: %[[DT:.*]] = extractvalue %_QM__fortran_type_infoTderivedtype %[[LOADED_TYPEDESC]], 0
 223 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 224 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 0
 225 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 226 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 227 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 228 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 229 ! CHECK: call void %[[FUNC_PTR]](ptr %[[CLASS]])
 230
 231 ! Check dynamic dispatch of a function with result.
 232 ! CHECK: %[[LOADED_CLASS:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[CLASS]]
 233 ! CHECK: %[[TYPEDESCPTR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOADED_CLASS]], 7
 234 ! CHECK: %[[LOADED_TYPEDESC:.*]] = load %_QM__fortran_type_infoTderivedtype, ptr %[[TYPEDESCPTR]]
 235 ! CHECK: %[[DT:.*]] = extractvalue %_QM__fortran_type_infoTderivedtype %[[LOADED_TYPEDESC]], 0
 236 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 237 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 3
 238 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 239 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 240 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 241 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 242 ! CHECK: %[[RET:.*]] = call i32 %[[FUNC_PTR]](ptr %[[CLASS]])
 243 ! CHECK: store i32 %[[RET]], ptr %[[I]]
 244
 245 ! Check dynamic dispatch of call with passed-object and additional argument
 246 ! CHECK: store float 2.500000e+00, ptr %[[REAL]]
 247 ! CHECK: %[[LOADED_CLASS:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[CLASS]]
 248 ! CHECK: %[[TYPEDESCPTR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOADED_CLASS]], 7
 249 ! CHECK: %[[LOADED_TYPEDESC:.*]] = load %_QM__fortran_type_infoTderivedtype, ptr %[[TYPEDESCPTR]]
 250 ! CHECK: %[[DT:.*]] = extractvalue %_QM__fortran_type_infoTderivedtype %[[LOADED_TYPEDESC]], 0
 251 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 252 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 6
 253 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 254 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 255 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 256 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 257 ! CHECK: call void %[[FUNC_PTR]](ptr %[[CLASS]], ptr %[[REAL]])
 258
 259 ! Check dynamic dispatch of a call with NOPASS
 260 ! CHECK: %[[LOADED_CLASS:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[CLASS]]
 261 ! CHECK: %[[TYPEDESCPTR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOADED_CLASS]], 7
 262 ! CHECK: %[[LOADED_TYPEDESC:.*]] = load %_QM__fortran_type_infoTderivedtype, ptr %[[TYPEDESCPTR]]
 263 ! CHECK: %[[DT:.*]] = extractvalue %_QM__fortran_type_infoTderivedtype %[[LOADED_TYPEDESC]], 0
 264 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 265 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 4
 266 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 267 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 268 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 269 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 270 ! CHECK: call void %[[FUNC_PTR]]()
 271
 272 ! CHECK: store i32 1, ptr %[[INT32]]
 273 ! CHECK: %[[LOADED_CLASS:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[CLASS]]
 274 ! CHECK: %[[TYPEDESCPTR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOADED_CLASS]], 7
 275 ! CHECK: %[[LOADED_TYPEDESC:.*]] = load %_QM__fortran_type_infoTderivedtype, ptr %[[TYPEDESCPTR]]
 276 ! CHECK: %[[DT:.*]] = extractvalue %_QM__fortran_type_infoTderivedtype %[[LOADED_TYPEDESC]], 0
 277 ! CHECK: %[[BINDING_BASE_ADDR:.*]] = extractvalue { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[DT]], 0
 278 ! CHECK: %[[BINDING_PTR:.*]] = getelementptr %_QM__fortran_type_infoTbinding, ptr %[[BINDING_BASE_ADDR]], i32 5
 279 ! CHECK: %[[LOADED_BINDING:.*]] = load %_QM__fortran_type_infoTbinding, ptr %[[BINDING_PTR]]
 280 ! CHECK: %[[BUILTIN_FUNC_PTR:.*]] = extractvalue %_QM__fortran_type_infoTbinding %[[LOADED_BINDING]], 0
 281 ! CHECK: %[[FUNC_ADDR:.*]] = extractvalue %_QM__fortran_builtinsT__builtin_c_funptr %[[BUILTIN_FUNC_PTR]], 0
 282 ! CHECK: %[[FUNC_PTR:.*]] = inttoptr i64 %[[FUNC_ADDR]] to ptr
 283 ! CHECK: call void %[[FUNC_PTR]](ptr %[[INT32]], ptr %[[CLASS]])
 284
 285 ! CHECK-LABEL: _QMdispatch1Pno_pass_array
 286 ! CHECK-LABEL: _QMdispatch1Pno_pass_array_allocatable
 287 ! CHECK-LABEL: _QMdispatch1Pno_pass_array_pointer
 288 ! CHECK-LABEL: _QMdispatch1Pcall_a1_proc
 289
 290 ! Check the layout of the binding table. This is easier to do in FIR than in
 291 ! LLVM IR.
 292
 293 ! BT-LABEL: fir.dispatch_table @_QMdispatch1Tty_kindK10K20
 294 ! BT-LABEL: fir.dispatch_table @_QMdispatch1Tty_kind_exK10K20 extends("_QMdispatch1Tty_kindK10K20")
 295
 296 ! BT-LABEL: fir.dispatch_table @_QMdispatch1Tp1 {
 297 ! BT: fir.dt_entry "aproc", @_QMdispatch1Paproc
 298 ! BT: fir.dt_entry "display1", @_QMdispatch1Pdisplay1_p1
 299 ! BT: fir.dt_entry "display2", @_QMdispatch1Pdisplay2_p1
 300 ! BT: fir.dt_entry "get_value", @_QMdispatch1Pget_value_p1
 301 ! BT: fir.dt_entry "proc_nopass", @_QMdispatch1Pproc_nopass_p1
 302 ! BT: fir.dt_entry "proc_pass", @_QMdispatch1Pproc_pass_p1
 303 ! BT: fir.dt_entry "proc_with_values", @_QMdispatch1Pproc_p1
 304 ! BT: }
 305
 306 ! BT-LABEL: fir.dispatch_table @_QMdispatch1Ta1 {
 307 ! BT: fir.dt_entry "a1_proc", @_QMdispatch1Pa1_proc
 308 ! BT: }
 309
 310 ! BT-LABEL: fir.dispatch_table @_QMdispatch1Ta2 extends("_QMdispatch1Ta1") {
 311 ! BT:  fir.dt_entry "a1_proc", @_QMdispatch1Pa2_proc
 312 ! BT: }
 313
 314 ! BT-LABEL: fir.dispatch_table @_QMdispatch1Tp2 extends("_QMdispatch1Tp1") {
 315 ! BT:  fir.dt_entry "aproc", @_QMdispatch1Paproc
 316 ! BT:  fir.dt_entry "display1", @_QMdispatch1Pdisplay1_p2
 317 ! BT:  fir.dt_entry "display2", @_QMdispatch1Pdisplay2_p2
 318 ! BT:  fir.dt_entry "get_value", @_QMdispatch1Pget_value_p2
 319 ! BT:  fir.dt_entry "proc_nopass", @_QMdispatch1Pproc_nopass_p2
 320 ! BT:  fir.dt_entry "proc_pass", @_QMdispatch1Pproc_pass_p2
 321 ! BT:  fir.dt_entry "proc_with_values", @_QMdispatch1Pproc_p2
 322 ! BT:  fir.dt_entry "display3", @_QMdispatch1Pdisplay3
 323 ! BT: }