From patchwork Fri Apr 29 16:55:11 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 93456 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 CAD2A1007D7 for ; Sat, 30 Apr 2011 02:55:46 +1000 (EST) Received: (qmail 10099 invoked by alias); 29 Apr 2011 16:55:33 -0000 Received: (qmail 10077 invoked by uid 22791); 29 Apr 2011 16:55:29 -0000 X-SWARE-Spam-Status: No, hits=-2.2 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, RFC_ABUSE_POST X-Spam-Check-By: sourceware.org Received: from mail-bw0-f47.google.com (HELO mail-bw0-f47.google.com) (209.85.214.47) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 29 Apr 2011 16:55:12 +0000 Received: by bwz5 with SMTP id 5so4044053bwz.20 for ; Fri, 29 Apr 2011 09:55:11 -0700 (PDT) MIME-Version: 1.0 Received: by 10.204.118.211 with SMTP id w19mr902914bkq.83.1304096111130; Fri, 29 Apr 2011 09:55:11 -0700 (PDT) Received: by 10.204.84.142 with HTTP; Fri, 29 Apr 2011 09:55:11 -0700 (PDT) Date: Fri, 29 Apr 2011 18:55:11 +0200 Message-ID: Subject: [Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746 From: Paul Richard Thomas To: fortran@gcc.gnu.org, gcc-patches 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, These are both quite trivial fixes and can be understood from ChangeLogs and comments in the patch. Bootstrapped and regtested on FC9/x86_64 - OK for trunk and 4.6? Cheers Paul 2011-04-29 Paul Thomas PR fortran/48462 * trans-expr.c (arrayfunc_assign_needs_temporary): Deal with automatic reallocation when the lhs is a target. PR fortran/48462 * trans-expr.c (fcncall_realloc_result): Make sure that the result dtype field is set before the function call. 2011-04-29 Paul Thomas PR fortran/48462 * gfortran.dg/realloc_on_assign_7.f03: Modify to test for lhs being a target. PR fortran/48746 * gfortran.dg/realloc_on_assign_7.f03: Add subroutine pr48746. Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 173130) --- gcc/fortran/trans-expr.c (working copy) *************** arrayfunc_assign_needs_temporary (gfc_ex *** 5444,5452 **** return true; /* If we have reached here with an intrinsic function, we do not ! need a temporary. */ if (expr2->value.function.isym) ! return false; /* If the LHS is a dummy, we need a temporary if it is not INTENT(OUT). */ --- 5444,5455 ---- return true; /* If we have reached here with an intrinsic function, we do not ! need a temporary except in the particular case that reallocation ! on assignment is active and the lhs is allocatable and a target. */ if (expr2->value.function.isym) ! return (gfc_option.flag_realloc_lhs ! && sym->attr.allocatable ! && sym->attr.target); /* If the LHS is a dummy, we need a temporary if it is not INTENT(OUT). */ *************** fcncall_realloc_result (gfc_se *se) *** 5547,5552 **** --- 5550,5558 ---- desc = build_fold_indirect_ref_loc (input_location, se->expr); res_desc = gfc_evaluate_now (desc, &se->pre); gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); + /* Unallocated, the descriptor does not have a dtype. */ + tmp = gfc_conv_descriptor_dtype (res_desc); + gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc); /* Free the lhs after the function call and copy the result data to *************** fcncall_realloc_result (gfc_se *se) *** 5556,5565 **** gfc_add_expr_to_block (&se->post, tmp); tmp = gfc_conv_descriptor_data_get (res_desc); gfc_conv_descriptor_data_set (&se->post, desc, tmp); - - /* Unallocated, the descriptor does not have a dtype. */ - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (&se->post, tmp, gfc_get_dtype (TREE_TYPE (desc))); } --- 5562,5567 ---- Index: gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 =================================================================== *** gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 (revision 173130) --- gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 (working copy) *************** *** 1,6 **** --- 1,8 ---- ! { dg-do run } ! Check the fix for PR48462 in which the assignments involving matmul ! seg faulted because a was automatically freed before the assignment. + ! Since it is related, the test for the fix of PR48746 has been added + ! as a subroutine by that name. ! ! Contributed by John Nedney ! *************** program main *** 8,30 **** implicit none integer, parameter :: dp = kind(0.0d0) real(kind=dp), allocatable :: delta(:,:) call foo call bar contains ! ! Original reduced version from comment #2 subroutine foo implicit none - real(kind=dp), allocatable :: a(:,:) real(kind=dp), allocatable :: b(:,:) - allocate(a(3,3)) allocate(b(3,3)) allocate(delta(3,3)) - b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3]) a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]) a = matmul( matmul( a, b ), b ) delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2 --- 10,41 ---- implicit none integer, parameter :: dp = kind(0.0d0) real(kind=dp), allocatable :: delta(:,:) + real(kind=dp), allocatable, target :: a(:,:) + real(kind=dp), pointer :: aptr(:,:) + + allocate(a(3,3)) + aptr => a call foo + if (.not. associated (aptr, a)) call abort () ! reallocated to same size - remains associated call bar + if (.not. associated (aptr, a)) call abort () ! reallocated to smaller size - remains associated + call foobar + if (associated (aptr, a)) call abort () ! reallocated to larger size - disassociates + + call pr48746 contains ! ! Original reduced version from comment #2 subroutine foo implicit none real(kind=dp), allocatable :: b(:,:) allocate(b(3,3)) allocate(delta(3,3)) a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]) + b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3]) a = matmul( matmul( a, b ), b ) delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2 *************** contains *** 47,51 **** if (any (delta > 1d-12)) call abort if (any (lbound (a) .ne. [1, 1])) call abort end subroutine end program main - --- 58,81 ---- if (any (delta > 1d-12)) call abort if (any (lbound (a) .ne. [1, 1])) call abort end subroutine + subroutine foobar + integer :: i + a = reshape ([(real(i, dp), i = 1, 100)],[10,10]) + end subroutine + subroutine pr48746 + ! This is a further wrinkle on the original problem and came about + ! because the dtype field of the result argument, passed to matmul, + ! was not being set. This is needed by matmul for the rank. + ! + ! Contributed by Thomas Koenig + ! + implicit none + integer, parameter :: m=10, n=12, count=4 + real :: optmatmul(m, n) + real :: a(m, count), b(count, n), c(m, n) + real, dimension(:,:), allocatable :: tmp + call random_number(a) + call random_number(b) + tmp = matmul(a,b) + end subroutine end program main