From patchwork Fri May 31 16:39:11 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 247986 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]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 215952C007B for ; Sat, 1 Jun 2013 02:39:37 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=wVg3YKvtY/R2zuPj7B4WP7Lye7WbYEqj0FH3SrhH4j7uT7 sEPd/F6pF/Q6Xm8V0aWv/4ZrgXRLcO4aJcNYHaIIcbw8WudPjNbGlarkqDykspJc BDxMK0IZYuQi235W9Jm5PUoIXH+3mRvS/D4VS36pxKa4bLa6twTM1QuE2Hk+8= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=0ktEo+p3xHgB9lanQjTd462/rP4=; b=Vksh/IrJuaDCkrckx9UE IjFRveiTAzWY8fDvu4RYSxJMO9xvISd/YSxj5Maaf/SPMsUywAe4YfXHFbPMYxrQ iETM1ZLfWWHP/QWu4BtAiE+jN6Kg1RMYEDj+T9r5tmzCyhSSYdqH9vqjwwm2/0fR ma04b6bLGsfBPxaaCWFhcE8= Received: (qmail 31087 invoked by alias); 31 May 2013 16:39:25 -0000 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 Received: (qmail 31042 invoked by uid 89); 31 May 2013 16:39:18 -0000 X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_TM autolearn=ham version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Fri, 31 May 2013 16:39:17 +0000 Received: from archimedes.net-b.de (port-92-195-106-97.dynamic.qsc.de [92.195.106.97]) by mx02.qsc.de (Postfix) with ESMTP id 89747247BC; Fri, 31 May 2013 18:39:12 +0200 (CEST) Message-ID: <51A8D22F.6040801@net-b.de> Date: Fri, 31 May 2013 18:39:11 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130510 Thunderbird/17.0.6 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Finalize nonallocatables with INTENT(out) X-Virus-Found: No This patch adds finalization support for INTENT(out) for nonallocatable dummy arguments. Additionally, it addresses a missed optimization: The previous code tried to deallocate allocatable components even if the dummy argument was already an allocatable. That's a missed optimization as gfortran deallocates allocatables in the caller. OK for the trunk? Note: This patch depends on http://gcc.gnu.org/ml/fortran/2013-05/msg00134.html Tobias PS: There are many more places where finalization should happen, e.g. intrinsic assignment (LHS + RHS func/constructor finalization), end-of-scope of nonallocatables. And some issues related coarrays, elemental+optional, etc. However, I stop here for the moment as I run out of time - and writing on-top patches of not reviewed/committed patches starts to become a chore. 2013-05-31 Tobias Burnus PR fortran/37336 * trans-decl.c (init_intent_out_dt): Call finalizer when approriate. 2013-05-31 Tobias Burnus PR fortran/37336 * gfortran.dg/finalize_10.f90: New. diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 100ec18..7521dee 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3501,38 +3503,56 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) && !f->sym->attr.pointer && f->sym->ts.type == BT_DERIVED) { - if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) + tmp = NULL_TREE; + + /* Note: Allocatables are excluded as they are already handled + by the caller. */ + if (!f->sym->attr.allocatable + && gfc_is_finalizable (f->sym->ts.u.derived, NULL)) { - tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, - f->sym->backend_decl, - f->sym->as ? f->sym->as->rank : 0); + stmtblock_t block; + gfc_expr *e; + + f->sym->attr.referenced = 1; + e = gfc_lval_expr_from_sym (f->sym); + gfc_add_finalizer_call (&block, e); + gfc_free_expr (e); + tmp = gfc_finish_block (&block); + } - if (f->sym->attr.optional - || f->sym->ns->proc_name->attr.entry_master) - { - present = gfc_conv_expr_present (f->sym); - tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), - present, tmp, - build_empty_stmt (input_location)); - } + if (tmp == NULL_TREE && !f->sym->attr.allocatable + && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) + tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, + f->sym->backend_decl, + f->sym->as ? f->sym->as->rank : 0); - gfc_add_expr_to_block (&init, tmp); + if (tmp != NULL_TREE && (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master)) + { + present = gfc_conv_expr_present (f->sym); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, build_empty_stmt (input_location)); } - else if (f->sym->value) + + if (tmp != NULL_TREE) + gfc_add_expr_to_block (&init, tmp); + else if (f->sym->value && !f->sym->attr.allocatable) gfc_init_default_dt (f->sym, &init, true); } else if (f->sym && f->sym->attr.intent == INTENT_OUT && f->sym->ts.type == BT_CLASS && !CLASS_DATA (f->sym)->attr.class_pointer - && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp) + && !CLASS_DATA (f->sym)->attr.allocatable) { - tmp = gfc_class_data_get (f->sym->backend_decl); - if (CLASS_DATA (f->sym)->as == NULL) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived, - tmp, - CLASS_DATA (f->sym)->as ? - CLASS_DATA (f->sym)->as->rank : 0); + stmtblock_t block; + gfc_expr *e; + + gfc_init_block (&block); + f->sym->attr.referenced = 1; + e = gfc_lval_expr_from_sym (f->sym); + gfc_add_finalizer_call (&block, e); + gfc_free_expr (e); + tmp = gfc_finish_block (&block); if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master) { --- /dev/null 2013-05-31 08:03:29.909107813 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-05-31 16:23:06.377019214 +0200 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/37336 +! +! Finalize nonallocatable INTENT(OUT) +! +module m + type t + end type t + type t2 + contains + final :: fini + end type t2 +contains + elemental subroutine fini(var) + type(t2), intent(inout) :: var + end subroutine fini +end module m + +subroutine foo(x,y,aa,bb) + use m + class(t), intent(out) :: x(:),y + type(t2), intent(out) :: aa(:),bb +end subroutine foo + +! Finalize CLASS + set default init +! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } } + +! FINALIZE TYPE: +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } +! { dg!final { scan-tree-dump-times "__final_m_T2 (&parm.\[0-9\]+, 0, 0);" 1 "original" } } +! { dg!final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } } +! { dg!final { scan-tree-dump-times "__final_m_T2 (&desc.\[0-9\]+, 0, 0);" 1 "original" } } + +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 index d261973..04ee7f2 100644 --- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 @@ -11,11 +11,12 @@ type :: t integer, allocatable :: i(:) end type +block ! New block as the main program implies SAVE type(t) :: a call init(a) call init(a) - +end block contains subroutine init(x) @@ -25,5 +26,6 @@ contains end program -! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } } ! { dg-final { cleanup-tree-dump "original" } }