diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 9875e37393ef8..8eb5e6865b832 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -677,18 +677,27 @@ class FirConverter : public Fortran::lower::AbstractConverter { if (auto seqTy = symType.dyn_cast()) { fir::ExtendedValue read = fir::factory::genMutableBoxRead( *builder, loc, box, /*mayBePolymorphic=*/false); - auto read_box = read.getBoxOf(); - fir::factory::genInlinedAllocation( - *builder, loc, *new_box, read_box->getLBounds(), - read_box->getExtents(), - /*lenParams=*/std::nullopt, name, - /*mustBeHeap=*/true); + if (auto read_arr_box = read.getBoxOf()) { + fir::factory::genInlinedAllocation( + *builder, loc, *new_box, read_arr_box->getLBounds(), + read_arr_box->getExtents(), + /*lenParams=*/std::nullopt, name, + /*mustBeHeap=*/true); + } else if (auto read_char_arr_box = + read.getBoxOf()) { + fir::factory::genInlinedAllocation( + *builder, loc, *new_box, read_char_arr_box->getLBounds(), + read_char_arr_box->getExtents(), + read_char_arr_box->getLen(), name, + /*mustBeHeap=*/true); + } else { + TODO(loc, "Unhandled allocatable box type"); + } } else { fir::factory::genInlinedAllocation( - *builder, loc, *new_box, - new_box->getMutableProperties().lbounds, - new_box->getMutableProperties().extents, - /*lenParams=*/std::nullopt, name, + *builder, loc, *new_box, box.getMutableProperties().lbounds, + box.getMutableProperties().extents, + box.nonDeferredLenParams(), name, /*mustBeHeap=*/true); } }); diff --git a/flang/test/Lower/OpenMP/parallel-private-clause-str.f90 b/flang/test/Lower/OpenMP/parallel-private-clause-str.f90 new file mode 100644 index 0000000000000..c19147e07c85c --- /dev/null +++ b/flang/test/Lower/OpenMP/parallel-private-clause-str.f90 @@ -0,0 +1,61 @@ +! This test checks lowering of OpenMP parallel Directive with +! `PRIVATE` clause present for strings + +! REQUIRES: shell +! RUN: bbc -fopenmp -emit-hlfir %s -o - | FileCheck %s +!RUN: %flang_fc1 -emit-hlfir -fopenmp %s -o - | FileCheck %s + +!CHECK: func.func @_QPtest_allocatable_string(%{{.*}}: !fir.ref {fir.bindc_name = "n"}) { +!CHECK: %[[C_BOX_REF:.*]] = fir.alloca !fir.box>> {bindc_name = "c", uniq_name = "_QFtest_allocatable_stringEc"} +!CHECK: %[[C_DECL:.*]]:2 = hlfir.declare %[[C_BOX_REF]] typeparams %{{.*}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_allocatable_stringEc"} : (!fir.ref>>>, i32) -> (!fir.ref>>>, !fir.ref>>>) +!CHECK: omp.parallel { +!CHECK: %[[C_PVT_BOX_REF:.*]] = fir.alloca !fir.box>> {bindc_name = "c", pinned, uniq_name = "_QFtest_allocatable_stringEc"} +!CHECK: %[[C_BOX:.*]] = fir.load %[[C_DECL]]#1 : !fir.ref>>> +!CHECK: fir.if %{{.*}} { +!CHECK: %[[C_PVT_MEM:.*]] = fir.allocmem !fir.char<1,?>(%{{.*}} : index) {fir.must_be_heap = true, uniq_name = "_QFtest_allocatable_stringEc.alloc"} +!CHECK: %[[C_PVT_BOX:.*]] = fir.embox %[[C_PVT_MEM]] typeparams %{{.*}} : (!fir.heap>, index) -> !fir.box>> +!CHECK: fir.store %[[C_PVT_BOX]] to %[[C_PVT_BOX_REF]] : !fir.ref>>> +!CHECK: } +!CHECK: %[[C_PVT_DECL:.*]]:2 = hlfir.declare %[[C_PVT_BOX_REF]] {uniq_name = "_QFtest_allocatable_stringEc"} : (!fir.ref>>>) -> (!fir.ref>>>, !fir.ref>>>) +!CHECK: fir.if %{{.*}} { +!CHECK: %[[C_PVT_BOX:.*]] = fir.load %[[C_PVT_DECL]]#1 : !fir.ref>>> +!CHECK: %[[C_PVT_BOX_ADDR:.*]] = fir.box_addr %[[C_PVT_BOX]] : (!fir.box>>) -> !fir.heap> +!CHECK: fir.freemem %[[C_PVT_BOX_ADDR]] : !fir.heap> +!CHECK: } +!CHECK: omp.terminator +!CHECK: } +subroutine test_allocatable_string(n) + character(n), allocatable :: c + !$omp parallel private(c) + !$omp end parallel +end subroutine + +!CHECK: func.func @_QPtest_allocatable_string_array(%{{.*}}: !fir.ref {fir.bindc_name = "n"}) { +!CHECK: %0:2 = hlfir.declare %arg0 {uniq_name = "_QFtest_allocatable_string_arrayEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +!CHECK: %[[C_BOX_REF:.*]] = fir.alloca !fir.box>>> {bindc_name = "c", uniq_name = "_QFtest_allocatable_string_arrayEc"} +!CHECK: %[[C_BOX:.*]] = fir.embox %{{.*}}(%{{.*}}) typeparams %{{.*}} : (!fir.heap>>, !fir.shape<1>, i32) -> !fir.box>>> +!CHECK: fir.store %[[C_BOX]] to %[[C_BOX_REF]] : !fir.ref>>>> +!CHECK: %[[C_DECL:.*]]:2 = hlfir.declare %[[C_BOX_REF]] typeparams %{{.*}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_allocatable_string_arrayEc"} : (!fir.ref>>>>, i32) -> (!fir.ref>>>>, !fir.ref>>>>) +!CHECK: omp.parallel { +!CHECK: %[[C_PVT_BOX_REF:.*]] = fir.alloca !fir.box>>> {bindc_name = "c", pinned, uniq_name = "_QFtest_allocatable_string_arrayEc"} +!CHECK: %{{.*}} = fir.load %[[C_DECL]]#1 : !fir.ref>>>> +!CHECK: fir.if %{{.*}} { +!CHECK: %[[C_PVT_ALLOC:.*]] = fir.allocmem !fir.array>(%{{.*}} : index), %{{.*}} {fir.must_be_heap = true, uniq_name = "_QFtest_allocatable_string_arrayEc.alloc"} +!CHECK: %[[C_PVT_BOX:.*]] = fir.embox %[[C_PVT_ALLOC]](%{{.*}}) typeparams %{{.*}} : (!fir.heap>>, !fir.shapeshift<1>, index) -> !fir.box>>> +!CHECK: fir.store %[[C_PVT_BOX]] to %[[C_PVT_BOX_REF]] : !fir.ref>>>> +!CHECK: } +!CHECK: %[[C_PVT_DECL:.*]]:2 = hlfir.declare %[[C_PVT_BOX_REF]] {uniq_name = "_QFtest_allocatable_string_arrayEc"} : (!fir.ref>>>>) -> (!fir.ref>>>>, !fir.ref>>>>) +!CHECK: %{{.*}} = fir.load %[[C_PVT_DECL]]#1 : !fir.ref>>>> +!CHECK: fir.if %{{.*}} { +!CHECK: %[[C_PVT_BOX:.*]] = fir.load %[[C_PVT_DECL]]#1 : !fir.ref>>>> +!CHECK: %[[C_PVT_ADDR:.*]] = fir.box_addr %[[C_PVT_BOX]] : (!fir.box>>>) -> !fir.heap>> +!CHECK: fir.freemem %[[C_PVT_ADDR]] : !fir.heap>> +!CHECK: } +!CHECK: omp.terminator +!CHECK: } + +subroutine test_allocatable_string_array(n) + character(n), allocatable :: c(:) + !$omp parallel private(c) + !$omp end parallel +end subroutine