From patchwork Sat Nov 26 13:50:48 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 127799 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id B69A1B70B7 for ; Sun, 27 Nov 2011 00:51:17 +1100 (EST) Received: (qmail 27194 invoked by alias); 26 Nov 2011 13:51:12 -0000 Received: (qmail 27171 invoked by uid 22791); 26 Nov 2011 13:51:08 -0000 X-SWARE-Spam-Status: No, hits=-1.6 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_BG, TW_TM, TW_VP X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 26 Nov 2011 13:50:51 +0000 Received: from [192.168.178.22] (port-92-204-12-48.dynamic.qsc.de [92.204.12.48]) by mx02.qsc.de (Postfix) with ESMTP id 042821DC3F; Sat, 26 Nov 2011 14:50:48 +0100 (CET) Message-ID: <4ED0EEB8.2060104@net-b.de> Date: Sat, 26 Nov 2011 14:50:48 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:8.0) Gecko/20111105 Thunderbird/8.0 MIME-Version: 1.0 To: gfortran , gcc patches Subject: [Patch, Fortran] MOVE_ALLOC fixes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Dear all, (First, this is *not* for the 4.6/4.7 rejects-valid regression, which is related to intent(in) pointers with allocatable components.) When debugging an issue with with polymorphic arrays and MOVE_ALLOC, I got lost in the code generation of move_alloc - and didn't like the generated code. Thus, I have rewritten the trans*.c part of it. (It turned out that the issue, we had, was unrelated to move_alloc.) Changes: * Replace call to libgfortran by inline code (much faster and shorter code) * For arrays: Deallocate "from" (deep freeing) * For polymorphic arrays: set _vptr. Actually, the required code is rather simple: For move_alloc(from, to), one just needs to do: a) Deallocate "to", taking allocatable components and the polymorphic types into account (the latter is a to-do item, cf. PR 46174). b) Do a simple assignment: to = from namely: If both are scalar variables, those are pointers and one does a pointer assignment. If they are polymorphic and/or an array, one does a (nonpointer) assignment to the class container or the array descriptor. c) Setting "from = NULL" (nonpolymorphic scalars) or "from.data = NULL" (nonpolymorphic arrays) or "from._data = NULL" (polymorphic scalars) or "from._data.data = NULL" (polymorphic arrays). For (b) the current expr-ref-walking function for polymorphic arrays either give access to class._data or to class._vptr. It is extremly difficult to access "class" itself. Thus, I now do two assignments: One nonpointer one to array descriptor and one pointer assignment to the _vptr. Build and regtested with the trunk with Paul's polymorphic array patch applied. (I will do a bootstrap and regtest with a clean trunk before committal.) OK for the trunk? Tobias PS: I'll add _gfortran_move_alloc to the list of functions which can be removed after the ABI breakage. 2011-11-26 Tobias Burnus PR fortran/51306 PR fortran/48700 * check.c (gfc_check_move_alloc): Make sure that from/to are both polymorphic or neither. * trans-intrinsic.c (conv_intrinsic_move_alloc): Cleanup, generate inline code. 2011-11-26 Tobias Burnus PR fortran/51306 PR fortran/48700 * gfortran.dg/move_alloc_5.f90: Add dg-error. * gfortran.dg/select_type_23.f03: Add dg-error. * gfortran.dg/move_alloc_6.f90: New. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index d9b9a9c..e2b0d66 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2691,6 +2709,14 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (same_type_check (to, 1, from, 0) == FAILURE) return FAILURE; + if (to->ts.type != from->ts.type) + { + gfc_error ("The FROM and TO arguments in MOVE_ALLOC call at %L must be " + "either both polymorphic or both nonpolymorphic", + &from->where); + return FAILURE; + } + if (to->rank != from->rank) { gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4244570..37a1ba6 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5892,7 +5892,7 @@ } -/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */ +/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */ static void gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) @@ -7182,50 +7190,122 @@ conv_intrinsic_atomic_ref (gfc_code *code) static tree conv_intrinsic_move_alloc (gfc_code *code) { - if (code->ext.actual->expr->rank == 0) - { - /* Scalar arguments: Generate pointer assignments. */ - gfc_expr *from, *to, *deal; - stmtblock_t block; - tree tmp; - gfc_se se; + stmtblock_t block; + gfc_expr *from_expr, *to_expr; + gfc_expr *to_expr2, *from_expr2; + gfc_se from_se, to_se; + gfc_ss *from_ss, *to_ss; + tree tmp; - from = code->ext.actual->expr; - to = code->ext.actual->next->expr; + gfc_start_block (&block); - gfc_start_block (&block); + from_expr = code->ext.actual->expr; + to_expr = code->ext.actual->next->expr; - /* Deallocate 'TO' argument. */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - deal = gfc_copy_expr (to); - if (deal->ts.type == BT_CLASS) - gfc_add_data_component (deal); - gfc_conv_expr (&se, deal); - tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true, - deal, deal->ts); - gfc_add_expr_to_block (&block, tmp); - gfc_free_expr (deal); + gfc_init_se (&from_se, NULL); + gfc_init_se (&to_se, NULL); - if (to->ts.type == BT_CLASS) - tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN); - else - tmp = gfc_trans_pointer_assignment (to, from); - gfc_add_expr_to_block (&block, tmp); + if (from_expr->rank == 0) + { + /* Deallocate "to". */ - if (from->ts.type == BT_CLASS) - tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL), - EXEC_POINTER_ASSIGN); + if (from_expr->ts.type != BT_CLASS) + to_expr2 = to_expr; else - tmp = gfc_trans_pointer_assignment (from, - gfc_get_null_expr (NULL)); + { + to_expr2 = gfc_copy_expr (to_expr); + gfc_add_data_component (to_expr2); + } + + to_se.want_pointer = 1; + gfc_conv_expr (&to_se, to_expr2); + tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, + to_expr2, to_expr->ts); gfc_add_expr_to_block (&block, tmp); + /* Nonpolymophic - do a pointer assignment: to = from; + Polymophic - do an assignment to the class container: *to = *from. */ + + if (from_expr->ts.type != BT_CLASS) + from_se.want_pointer = 1; + + gfc_conv_expr (&from_se, from_expr); + + if (from_expr->ts.type == BT_CLASS) + { + gfc_init_se (&to_se, NULL); + gfc_conv_expr (&to_se, to_expr); + } + + gfc_add_block_to_block (&block, &from_se.pre); + gfc_add_block_to_block (&block, &to_se.pre); + + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + + /* Set "from" to NULL. */ + + if (from_expr->ts.type == BT_CLASS) + { + gfc_init_se (&from_se, NULL); + from_se.want_pointer = 1; + from_expr = gfc_copy_expr (from_expr); + gfc_add_data_component (from_expr); + gfc_conv_expr (&from_se, from_expr); + gfc_free_expr (from_expr); + } + + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), null_pointer_node)); + + gfc_add_block_to_block (&block, &from_se.post); + gfc_add_block_to_block (&block, &to_se.post); + return gfc_finish_block (&block); } - else - /* Array arguments: Generate library code. */ - return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false); + + /* Update _vptr component. */ + if (from_expr->ts.type == BT_CLASS) + { + from_se.want_pointer = 1; + to_se.want_pointer = 1; + + from_expr2 = gfc_copy_expr (from_expr); + to_expr2 = gfc_copy_expr (to_expr); + gfc_add_vptr_component (from_expr2); + gfc_add_vptr_component (to_expr2); + + gfc_conv_expr (&from_se, from_expr2); + gfc_conv_expr (&to_se, to_expr2); + + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + gfc_free_expr (to_expr2); + gfc_free_expr (from_expr2); + + gfc_init_se (&from_se, NULL); + gfc_init_se (&to_se, NULL); + } + + /* Deallocate "to". */ + to_ss = gfc_walk_expr (to_expr); + from_ss = gfc_walk_expr (from_expr); + gfc_conv_expr_descriptor (&to_se, to_expr, to_ss); + gfc_conv_expr_descriptor (&from_se, from_expr, from_ss); + + tmp = gfc_conv_descriptor_data_get (to_se.expr); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, to_expr); + gfc_add_expr_to_block (&block, tmp); + + /* Move the pointer and update the array descriptor data. */ + gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr); + + /* Set "to" to NULL. */ + tmp = gfc_conv_descriptor_data_get (from_se.expr); + gfc_add_modify_loc (input_location, &block, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); + + return gfc_finish_block (&block); } diff --git a/gcc/testsuite/gfortran.dg/move_alloc_5.f90 b/gcc/testsuite/gfortran.dg/move_alloc_5.f90 index b2759de..7663275 100644 --- a/gcc/testsuite/gfortran.dg/move_alloc_5.f90 +++ b/gcc/testsuite/gfortran.dg/move_alloc_5.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do compile } ! ! PR 48699: [4.6/4.7 Regression] [OOP] MOVE_ALLOC inside SELECT TYPE ! @@ -16,7 +16,7 @@ program testmv1 type(bar2), allocatable :: sm2 allocate (sm2) - call move_alloc (sm2,sm) + call move_alloc (sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" } if (allocated(sm2)) call abort() if (.not. allocated(sm)) call abort() --- /dev/null 2011-11-22 07:52:35.375586753 +0100 +++ gcc/gcc/testsuite/gfortran.dg/move_alloc_6.f90 2011-11-26 14:14:27.000000000 +0100 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! Test move_alloc for polymorphic scalars +! +! +module myalloc + implicit none + + type :: base_type + integer :: i =2 + end type base_type + + type, extends(base_type) :: extended_type + integer :: j = 77 + end type extended_type +contains + subroutine myallocate (a) + class(base_type), allocatable, intent(inout) :: a + class(base_type), allocatable :: tmp + + allocate (extended_type :: tmp) + + select type(tmp) + type is(base_type) + call abort () + type is(extended_type) + if (tmp%i /= 2 .or. tmp%j /= 77) call abort() + tmp%i = 5 + tmp%j = 88 + end select + + select type(a) + type is(base_type) + if (a%i /= -44) call abort() + a%i = -99 + class default + call abort () + end select + + call move_alloc (from=tmp, to=a) + + select type(a) + type is(extended_type) + if (a%i /= 5) call abort() + if (a%j /= 88) call abort() + a%i = 123 + a%j = 9498 + class default + call abort () + end select + + if (allocated (tmp)) call abort() + end subroutine myallocate +end module myalloc + +program main + use myalloc + implicit none + class(base_type), allocatable :: a + + allocate (a) + + select type(a) + type is(base_type) + if (a%i /= 2) call abort() + a%i = -44 + class default + call abort () + end select + + call myallocate (a) + + select type(a) + type is(extended_type) + if (a%i /= 123) call abort() + if (a%j /= 9498) call abort() + class default + call abort () + end select +end program main diff --git a/gcc/testsuite/gfortran.dg/select_type_23.f03 b/gcc/testsuite/gfortran.dg/select_type_23.f03 index d7788d2..2479f1d 100644 --- a/gcc/testsuite/gfortran.dg/select_type_23.f03 +++ b/gcc/testsuite/gfortran.dg/select_type_23.f03 @@ -3,6 +3,10 @@ ! PR 48699: [OOP] MOVE_ALLOC inside SELECT TYPE ! ! Contributed by Salvatore Filippone +! +! Note that per Fortran 2008, 8.1.9.2, "within the block following +! a TYPE IS type guard statement, the associating entity (16.5.5) is not polymorphic" +! program testmv2 @@ -16,7 +20,7 @@ program testmv2 select type(sm2) type is (bar) - call move_alloc(sm2,sm) + call move_alloc(sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" } end select end program testmv2