shylie/llvm-project
1
0
Fork 0
Code Issues Pull Requests Actions 6 Packages Projects Releases Wiki Activity
llvm-project/flang/test/Lower/select-case-statement.f90
V Donaldson 2c1433453d [flang] Block construct 
A block construct is an execution control construct that supports
declaration scopes contained within a parent subprogram scope or another
block scope. (blocks may be nested.) This is implemented by applying
basic scope processing to the block level.

Name uniquing/mangling is extended to support this. The term "block" is
heavily overloaded in Fortran standards. Prior name uniquing used tag `B`
for common block objects. Existing tag choices were modified to free up `B`
for block construct entities, and `C` for common blocks, and resolve
additional issues with other tags. The "old tag -> new tag" changes can
be summarized as:

     -> B  -- block construct -> new
  B  -> C  -- common block
  C  -> YI -- intrinsic type descriptor; not currently generated
  CT -> Y  -- nonintrinsic type descriptor; not currently generated
  G  -> N  -- namelist group
  L  ->    -- block data; not needed -> deleted

Existing name uniquing components consist of a tag followed by a name
from user source code, such as a module, subprogram, or variable name.
Block constructs are different in that they may be anonymous. (Like other
constructs, a block may have a `block-construct-name` that can be used
in exit statements, but this name is optional.) So blocks are given a
numeric compiler-generated preorder index starting with `B1`, `B2`,
and so on, on a per-procedure basis.

Name uniquing is also modified to include component names for all
containing procedures rather than for just the immediate host. This
fixes an existing name clash bug with same-named entities in same-named
host subprograms contained in different-named containing subprograms,
and variations of the bug involving modules and submodules.

F18 clause 9.7.3.1 (Deallocation of allocatable variables) paragraph 1
has a requirement that an allocated, unsaved allocatable local variable
must be deallocated on procedure exit. The following paragraph 2 states:

  When a BLOCK construct terminates, any unsaved allocated allocatable
  local variable of the construct is deallocated.

Similarly, F18 clause 7.5.6.3 (When finalization occurs) paragraph 3
has a requirement that a nonpointer, nonallocatable object must be
finalized on procedure exit. The following paragraph 4 states:

  A nonpointer nonallocatable local variable of a BLOCK construct
  is finalized immediately before it would become undefined due to
  termination of the BLOCK construct.

These deallocation and finalization requirements, along with stack
restoration requirements, require knowledge of block exits. In addition
to normal block termination at an end-block-stmt, a block may be
terminated by executing a branching statement that targets a statement
outside of the block. This includes

Single-target branch statements:
 - goto
 - exit
 - cycle
 - return

Bounded multiple-target branch statements:
 - arithmetic goto
 - IO statement with END, EOR, or ERR specifiers

Unbounded multiple-target branch statements:
 - call with alternate return specs
 - computed goto
 - assigned goto

Lowering code is extended to determine if one of these branches exits
one or more relevant blocks or other constructs, and adds a mechanism to
insert any necessary deallocation, finalization, or stack restoration
code at the source of the branch. For a single-target branch it suffices
to generate the exit code just prior to taking the indicated branch.
Each target of a multiple-target branch must be analyzed individually.
Where necessary, the code must first branch to an intermediate basic
block that contains exit code, followed by a branch to the original target
statement.

This patch implements an `activeConstructStack` construct exit mechanism
that queries a new `activeConstruct` PFT bit to insert stack restoration
code at block exits. It ties in to existing code in ConvertVariable.cpp
routine `instantiateLocal` which has code for finalization, making block
exit finalization on par with subprogram exit finalization. Deallocation
is as yet unimplemented for subprograms or blocks. This may result in
memory leaks for affected objects at either the subprogram or block level.
Deallocation cases can be addressed uniformly for both scopes in a future
patch, presumably with code insertion in routine `instantiateLocal`.

The exit code mechanism is not limited to block construct exits. It is
also available for use with other constructs. In particular, it is used
to replace custom deallocation code for a select case construct character
selector expression where applicable. This functionality is also added
to select type and associate constructs. It is available for use with
other constructs, such as select rank and image control constructs,
if that turns out to be necessary.

Overlapping nonfunctional changes include eliminating "FIR" from some
routine names and eliminating obsolete spaces in comments.
2023-02-28 09:55:10 -08:00

487 lines
15 KiB
Fortran
Raw Blame History

! RUN: bbc -emit-fir -o - %s | FileCheck %s
! CHECK-LABEL: sinteger
function sinteger(n)
integer sinteger
nn = -88
! CHECK: fir.select_case {{.*}} : i32
! CHECK-SAME: upper, %c1
! CHECK-SAME: point, %c2
! CHECK-SAME: point, %c3
! CHECK-SAME: interval, %c4{{.*}} %c5
! CHECK-SAME: point, %c6
! CHECK-SAME: point, %c7
! CHECK-SAME: interval, %c8{{.*}} %c15
! CHECK-SAME: lower, %c21
! CHECK-SAME: unit
select case(n)
case (:1)
nn = 1
case (2)
nn = 2
case default
nn = 0
case (3)
nn = 3
case (4:5+1-1)
nn = 4
case (6)
nn = 6
case (7,8:15,21:)
nn = 7
end select
sinteger = nn
end
! CHECK-LABEL: slogical
subroutine slogical(L)
logical :: L
n1 = 0
n2 = 0
n3 = 0
n4 = 0
n5 = 0
n6 = 0
n7 = 0
n8 = 0
select case (L)
end select
select case (L)
! CHECK: cmpi eq, {{.*}} %false
! CHECK: cond_br
case (.false.)
n2 = 1
end select
select case (L)
! CHECK: cmpi eq, {{.*}} %true
! CHECK: cond_br
case (.true.)
n3 = 2
end select
select case (L)
case default
n4 = 3
end select
select case (L)
! CHECK: cmpi eq, {{.*}} %false
! CHECK: cond_br
case (.false.)
n5 = 1
! CHECK: cmpi eq, {{.*}} %true
! CHECK: cond_br
case (.true.)
n5 = 2
end select
select case (L)
! CHECK: cmpi eq, {{.*}} %false
! CHECK: cond_br
case (.false.)
n6 = 1
case default
n6 = 3
end select
select case (L)
! CHECK: cmpi eq, {{.*}} %true
! CHECK: cond_br
case (.true.)
n7 = 2
case default
n7 = 3
end select
select case (L)
! CHECK: cmpi eq, {{.*}} %false
! CHECK: cond_br
case (.false.)
n8 = 1
! CHECK: cmpi eq, {{.*}} %true
! CHECK: cond_br
case (.true.)
n8 = 2
! CHECK-NOT: constant 888
case default ! dead
n8 = 888
end select
print*, n1, n2, n3, n4, n5, n6, n7, n8
end
! CHECK-LABEL: scharacter
subroutine scharacter(c)
character(*) :: c
nn = 0
select case (c)
case default
nn = -1
! CHECK: CharacterCompareScalar1
! CHECK-NEXT: constant 0
! CHECK-NEXT: cmpi sle, {{.*}} %c0
! CHECK-NEXT: cond_br
case (:'d')
nn = 10
! CHECK: CharacterCompareScalar1
! CHECK-NEXT: constant 0
! CHECK-NEXT: cmpi sge, {{.*}} %c0
! CHECK-NEXT: cond_br
! CHECK: CharacterCompareScalar1
! CHECK-NEXT: constant 0
! CHECK-NEXT: cmpi sle, {{.*}} %c0
! CHECK-NEXT: cond_br
case ('ff':'ffff')
nn = 20
! CHECK: CharacterCompareScalar1
! CHECK-NEXT: constant 0
! CHECK-NEXT: cmpi eq, {{.*}} %c0
! CHECK-NEXT: cond_br
case ('m')
nn = 30
! CHECK: CharacterCompareScalar1
! CHECK-NEXT: constant 0
! CHECK-NEXT: cmpi eq, {{.*}} %c0
! CHECK-NEXT: cond_br
case ('qq')
nn = 40
! CHECK: CharacterCompareScalar1
! CHECK-NEXT: constant 0
! CHECK-NEXT: cmpi sge, {{.*}} %c0
! CHECK-NEXT: cond_br
case ('x':)
nn = 50
end select
print*, nn
end
! CHECK-LABEL: func @_QPscharacter1
subroutine scharacter1(s)
! CHECK-DAG: %[[V_0:[0-9]+]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>>
character(len=3) :: s
! CHECK-DAG: %[[V_1:[0-9]+]] = fir.alloca i32 {bindc_name = "n", uniq_name = "_QFscharacter1En"}
! CHECK: fir.store %c0{{.*}} to %[[V_1]] : !fir.ref<i32>
n = 0
! CHECK: %[[V_8:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_9:[0-9]+]] = arith.cmpi sge, %[[V_8]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_9]], ^bb1, ^bb16
! CHECK: ^bb1: // pred: ^bb0
if (lge(s,'00')) then
! CHECK: %[[V_18:[0-9]+]] = fir.load %[[V_0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
! CHECK: %[[V_20:[0-9]+]] = fir.box_addr %[[V_18]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
! CHECK: %[[V_42:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_43:[0-9]+]] = arith.cmpi eq, %[[V_42]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_43]], ^bb3, ^bb2
! CHECK: ^bb2: // pred: ^bb1
select case(trim(s))
case('11')
n = 1
case default
continue
! CHECK: %[[V_48:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_49:[0-9]+]] = arith.cmpi eq, %[[V_48]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_49]], ^bb6, ^bb5
! CHECK: ^bb3: // pred: ^bb1
! CHECK: fir.store %c1{{.*}} to %[[V_1]] : !fir.ref<i32>
! CHECK: ^bb4: // pred: ^bb13
! CHECK: ^bb5: // pred: ^bb2
case('22')
n = 2
! CHECK: %[[V_54:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_55:[0-9]+]] = arith.cmpi eq, %[[V_54]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_55]], ^bb8, ^bb7
! CHECK: ^bb6: // pred: ^bb2
! CHECK: fir.store %c2{{.*}} to %[[V_1]] : !fir.ref<i32>
! CHECK: ^bb7: // pred: ^bb5
case('33')
n = 3
case('44':'55','66':'77','88':)
n = 4
! CHECK: %[[V_60:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_61:[0-9]+]] = arith.cmpi sge, %[[V_60]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_61]], ^bb9, ^bb10
! CHECK: ^bb8: // pred: ^bb5
! CHECK: fir.store %c3{{.*}} to %[[V_1]] : !fir.ref<i32>
! CHECK: ^bb9: // pred: ^bb7
! CHECK: %[[V_66:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_67:[0-9]+]] = arith.cmpi sle, %[[V_66]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_67]], ^bb14, ^bb10
! CHECK: ^bb10: // 2 preds: ^bb7, ^bb9
! CHECK: %[[V_72:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_73:[0-9]+]] = arith.cmpi sge, %[[V_72]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_73]], ^bb11, ^bb12
! CHECK: ^bb11: // pred: ^bb10
! CHECK: %[[V_78:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_79:[0-9]+]] = arith.cmpi sle, %[[V_78]], %c0{{.*}} : i32
! CHECK: ^bb12: // 2 preds: ^bb10, ^bb11
! CHECK: %[[V_84:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[V_85:[0-9]+]] = arith.cmpi sge, %[[V_84]], %c0{{.*}} : i32
! CHECK: cond_br %[[V_85]], ^bb14, ^bb13
! CHECK: ^bb13: // pred: ^bb12
! CHECK: ^bb14: // 3 preds: ^bb9, ^bb11, ^bb12
! CHECK: fir.store %c4{{.*}} to %[[V_1]] : !fir.ref<i32>
! CHECK: ^bb15: // 5 preds: ^bb3, ^bb4, ^bb6, ^bb8, ^bb14
! CHECK: fir.freemem %[[V_20]] : !fir.heap<!fir.char<1,?>>
end select
end if
! CHECK: %[[V_89:[0-9]+]] = fir.load %[[V_1]] : !fir.ref<i32>
print*, n
end subroutine
! CHECK-LABEL: func @_QPscharacter2
subroutine scharacter2(s)
! CHECK-DAG: %[[V_0:[0-9]+]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>>
! CHECK: %[[V_1:[0-9]+]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>>
character(len=3) :: s
n = -10
! CHECK: %[[V_12:[0-9]+]] = fir.load %[[V_1]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
! CHECK: %[[V_13:[0-9]+]] = fir.box_addr %[[V_12]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
! CHECK: br ^bb1
! CHECK: ^bb1: // pred: ^bb0
! CHECK: fir.store %c9{{.*}}
! CHECK: br ^bb2
! CHECK: ^bb2: // pred: ^bb1
! CHECK: fir.freemem %[[V_13]] : !fir.heap<!fir.char<1,?>>
select case(trim(s))
case default
n = 9
end select
print*, n
n = -2
! CHECK: %[[V_28:[0-9]+]] = fir.load %[[V_0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
! CHECK: %[[V_29:[0-9]+]] = fir.box_addr %[[V_28]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
! CHECK: br ^bb3
! CHECK: ^bb3: // pred: ^bb2
! CHECK: fir.freemem %[[V_29]] : !fir.heap<!fir.char<1,?>>
select case(trim(s))
end select
print*, n
end subroutine
! CHECK-LABEL: func @_QPsempty
! empty select case blocks
subroutine sempty(n)
! CHECK: %[[selectI1:[0-9]+]] = fir.load %arg0 : !fir.ref<i32>
! CHECK: fir.select_case %[[selectI1]] : i32 [#fir.point, %c1{{.*}}, ^bb1, #fir.point, %c2{{.*}}, ^bb2, unit, ^bb3]
! CHECK: ^bb1: // pred: ^bb0
! CHECK: fir.call @_FortranAioBeginExternalListOutput
! CHECK: br ^bb4
! CHECK: ^bb2: // pred: ^bb0
! CHECK: br ^bb4
! CHECK: ^bb3: // pred: ^bb0
! CHECK: fir.call @_FortranAioBeginExternalListOutput
! CHECK: br ^bb4
select case (n)
case (1)
print*, n, 'i:case 1'
case (2)
! print*, n, 'i:case 2'
case default
print*, n, 'i:case default'
end select
! CHECK: ^bb4: // 3 preds: ^bb1, ^bb2, ^bb3
! CHECK: %[[cmpC1:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[selectC1:[0-9]+]] = arith.cmpi eq, %[[cmpC1]], %c0{{.*}} : i32
! CHECK: cond_br %[[selectC1]], ^bb6, ^bb5
! CHECK: ^bb5: // pred: ^bb4
! CHECK: %[[cmpC2:[0-9]+]] = fir.call @_FortranACharacterCompareScalar1
! CHECK: %[[selectC2:[0-9]+]] = arith.cmpi eq, %[[cmpC2]], %c0{{.*}} : i32
! CHECK: cond_br %[[selectC2]], ^bb8, ^bb7
! CHECK: ^bb6: // pred: ^bb4
! CHECK: fir.call @_FortranAioBeginExternalListOutput
! print*, n, 'c:case 2'
! CHECK: br ^bb10
! CHECK: ^bb7: // pred: ^bb5
! CHECK: br ^bb9
! CHECK: ^bb8: // pred: ^bb5
! CHECK: br ^bb10
! CHECK: ^bb9: // pred: ^bb7
! CHECK: fir.call @_FortranAioBeginExternalListOutput
! CHECK: br ^bb10
! CHECK: ^bb10: // 3 preds: ^bb6, ^bb8, ^bb9
select case (char(ichar('0')+n))
case ('1')
print*, n, 'c:case 1'
case ('2')
! print*, n, 'c:case 2'
case default
print*, n, 'c:case default'
end select
! CHECK: return
end subroutine
! CHECK-LABEL: func @_QPsgoto
! select case with goto exit
subroutine sgoto
n = 0
do i=1,8
! CHECK: %[[i:[0-9]+]] = fir.alloca {{.*}} "_QFsgotoEi"
! CHECK: ^bb2: // pred: ^bb1
! CHECK: %[[selector:[0-9]+]] = fir.load %[[i]] : !fir.ref<i32>
! CHECK: fir.select_case %[[selector]] : i32 [#fir.upper, %c2{{.*}}, ^bb3, #fir.lower, %c5{{.*}}, ^bb4, unit, ^bb7]
! CHECK: ^bb3: // pred: ^bb2
! CHECK: arith.muli %c10{{[^0]}}
! CHECK: br ^bb8
! CHECK: ^bb4: // pred: ^bb2
! CHECK: arith.muli %c1000{{[^0]}}
! CHECK: cond_br {{.*}}, ^bb5, ^bb6
! CHECK: ^bb5: // pred: ^bb4
! CHECK: br ^bb8
! CHECK: ^bb6: // pred: ^bb4
! CHECK: arith.muli %c10000{{[^0]}}
! CHECK: br ^bb8
! CHECK: ^bb7: // pred: ^bb2
! CHECK: arith.muli %c100{{[^0]}}
! CHECK: br ^bb8
! CHECK: ^bb8: // 4 preds: ^bb3, ^bb5, ^bb6, ^bb7
! CHECK: fir.call @_FortranAioBeginExternalListOutput
! CHECK: br ^bb1
! CHECK: ^bb9: // pred: ^bb1
select case(i)
case (:2)
n = i * 10
case (5:)
n = i * 1000
if (i <= 6) goto 9
n = i * 10000
case default
n = i * 100
9 end select
print*, n
enddo
! CHECK: return
end
! CHECK-LABEL: func @_QPswhere
subroutine swhere(num)
implicit none
integer, intent(in) :: num
real, dimension(1) :: array
array = 0.0
select case (num)
! CHECK: ^bb1: // pred: ^bb0
case (1)
where (array >= 0.0)
array = 42
end where
! CHECK: cf.br ^bb3
! CHECK: ^bb2: // pred: ^bb0
case default
array = -1
end select
! CHECK: cf.br ^bb3
! CHECK: ^bb3: // 2 preds: ^bb1, ^bb2
print*, array(1)
end subroutine swhere
! CHECK-LABEL: func @_QPsforall
subroutine sforall(num)
implicit none
integer, intent(in) :: num
real, dimension(1) :: array
array = 0.0
select case (num)
! CHECK: ^bb1: // pred: ^bb0
case (1)
where (array >= 0.0)
array = 42
end where
! CHECK: cf.br ^bb3
! CHECK: ^bb2: // pred: ^bb0
case default
array = -1
end select
! CHECK: cf.br ^bb3
! CHECK: ^bb3: // 2 preds: ^bb1, ^bb2
print*, array(1)
end subroutine sforall
! CHECK-LABEL: main
program p
integer sinteger, v(10)
n = -10
do j = 1, 4
do k = 1, 10
n = n + 1
v(k) = sinteger(n)
enddo
! expected output: 1 1 1 1 1 1 1 1 1 1
! 1 2 3 4 4 6 7 7 7 7
! 7 7 7 7 7 0 0 0 0 0
! 7 7 7 7 7 7 7 7 7 7
print*, v
enddo
print*
call slogical(.false.) ! expected output: 0 1 0 3 1 1 3 1
call slogical(.true.) ! expected output: 0 0 2 3 2 3 2 2
print*
call scharacter('aa') ! expected output: 10
call scharacter('d') ! expected output: 10
call scharacter('f') ! expected output: -1
call scharacter('ff') ! expected output: 20
call scharacter('fff') ! expected output: 20
call scharacter('ffff') ! expected output: 20
call scharacter('fffff') ! expected output: -1
call scharacter('jj') ! expected output: -1
call scharacter('m') ! expected output: 30
call scharacter('q') ! expected output: -1
call scharacter('qq') ! expected output: 40
call scharacter('qqq') ! expected output: -1
call scharacter('vv') ! expected output: -1
call scharacter('xx') ! expected output: 50
call scharacter('zz') ! expected output: 50
print*
call scharacter1('99 ') ! expected output: 4
call scharacter1('88 ') ! expected output: 4
call scharacter1('77 ') ! expected output: 4
call scharacter1('66 ') ! expected output: 4
call scharacter1('55 ') ! expected output: 4
call scharacter1('44 ') ! expected output: 4
call scharacter1('33 ') ! expected output: 3
call scharacter1('22 ') ! expected output: 2
call scharacter1('11 ') ! expected output: 1
call scharacter1('00 ') ! expected output: 0
call scharacter1('. ') ! expected output: 0
call scharacter1(' ') ! expected output: 0
print*
call scharacter2('99 ') ! expected output: 9 -2
call scharacter2('22 ') ! expected output: 9 -2
call scharacter2('. ') ! expected output: 9 -2
call scharacter2(' ') ! expected output: 9 -2
print*
call sempty(0) ! expected output: 0 i:case default 0; c:case default
call sempty(1) ! expected output: 1 i:case 1; 1 c:case 1
call sempty(2) ! no output
call sempty(3) ! expected output: 3 i:case default; 3 c:case default
print*
call sgoto ! expected output: 10 20 300 400 5000 6000 70000 80000
print*
call swhere(1) ! expected output: 42.
call sforall(1) ! expected output: 42.
end
Reference in New Issue View Git Blame Copy Permalink