* [Patch, fortran] PR87359 [9 regression] pointer being freed was not allocated
[not found] ` <bug-87359-10374-A3nXZb7g3f@http.gcc.gnu.org/bugzilla/>
@ 2018-09-30 14:00 ` Paul Richard Thomas
0 siblings, 0 replies; 2+ messages in thread
From: Paul Richard Thomas @ 2018-09-30 14:00 UTC (permalink / raw)
To: fortran, gcc-patches; +Cc: Dominique Dhumieres, Jürgen Reuter
[-- Attachment #1: Type: text/plain, Size: 513 bytes --]
After testing by Dominique and Juergen. Committed as revision 264725.
Thanks to Dominique and juergen for doing all the hard work!
Cheers
Paul
2018-09-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/87359
* trans-array.c (gfc_is_reallocatable_lhs): Correct the problem
introduced by r264358, which prevented components of associate
names from being reallocated on assignment.
2018-09-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/87359
* gfortran.dg/associate_40.f90 : New test.
[-- Attachment #2: regression.diff --]
[-- Type: text/x-patch, Size: 5251 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 264724)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_is_reallocatable_lhs (gfc_expr *expr
*** 9574,9584 ****
sym = expr->symtree->n.sym;
! if (sym->attr.associate_var)
return false;
/* An allocatable class variable with no reference. */
if (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable
&& expr->ref && expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0
--- 9574,9585 ----
sym = expr->symtree->n.sym;
! if (sym->attr.associate_var && !expr->ref)
return false;
/* An allocatable class variable with no reference. */
if (sym->ts.type == BT_CLASS
+ && !sym->attr.associate_var
&& CLASS_DATA (sym)->attr.allocatable
&& expr->ref && expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0
*************** gfc_is_reallocatable_lhs (gfc_expr *expr
*** 9587,9595 ****
/* An allocatable variable. */
if (sym->attr.allocatable
! && expr->ref
! && expr->ref->type == REF_ARRAY
! && expr->ref->u.ar.type == AR_FULL)
return true;
/* All that can be left are allocatable components. */
--- 9588,9597 ----
/* An allocatable variable. */
if (sym->attr.allocatable
! && !sym->attr.associate_var
! && expr->ref
! && expr->ref->type == REF_ARRAY
! && expr->ref->u.ar.type == AR_FULL)
return true;
/* All that can be left are allocatable components. */
Index: gcc/testsuite/gfortran.dg/associate_40.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associate_40.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/associate_40.f90 (working copy)
***************
*** 0 ****
--- 1,96 ----
+ ! { dg-do compile }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for the second part of PR87359 in which the reallocation on
+ ! assignment for components of associate names was disallowed by r264358.
+ ! -fcheck-all exposed the mismatch in array shapes. The deallocations at
+ ! the end of the main program are there to make sure that valgrind does
+ ! not report an memory leaks.
+ !
+ ! Contributed by Juergen Reuter <juergen.reuter@desy.de>
+ !
+ module phs_fks
+ implicit none
+ private
+ public :: phs_identifier_t
+ public :: phs_fks_t
+ type :: phs_identifier_t
+ integer, dimension(:), allocatable :: contributors
+ contains
+ procedure :: init => phs_identifier_init
+ end type phs_identifier_t
+
+ type :: phs_fks_t
+ type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
+ end type phs_fks_t
+ contains
+
+ subroutine phs_identifier_init &
+ (phs_id, contributors)
+ class(phs_identifier_t), intent(out) :: phs_id
+ integer, intent(in), dimension(:) :: contributors
+ allocate (phs_id%contributors (size (contributors)))
+ phs_id%contributors = contributors
+ end subroutine phs_identifier_init
+
+ end module phs_fks
+
+ !!!!!
+
+ module instances
+ use phs_fks
+ implicit none
+ private
+ public :: process_instance_t
+
+ type :: nlo_event_deps_t
+ type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
+ end type nlo_event_deps_t
+
+ type :: process_instance_t
+ type(phs_fks_t), pointer :: phs => null ()
+ type(nlo_event_deps_t) :: event_deps
+ contains
+ procedure :: init => process_instance_init
+ procedure :: setup_real_event_kinematics => pi_setup_real_event_kinematics
+ end type process_instance_t
+
+ contains
+
+ subroutine process_instance_init (instance)
+ class(process_instance_t), intent(out), target :: instance
+ integer :: i
+ integer :: i_born, i_real
+ allocate (instance%phs)
+ end subroutine process_instance_init
+
+ subroutine pi_setup_real_event_kinematics (process_instance)
+ class(process_instance_t), intent(inout) :: process_instance
+ integer :: i_real, i
+ associate (event_deps => process_instance%event_deps)
+ i_real = 2
+ associate (phs => process_instance%phs)
+ allocate (phs%phs_identifiers (3))
+ call phs%phs_identifiers(1)%init ([1])
+ call phs%phs_identifiers(2)%init ([1,2])
+ call phs%phs_identifiers(3)%init ([1,2,3])
+ process_instance%event_deps%phs_identifiers = phs%phs_identifiers ! Error: mismatch in array shapes.
+ end associate
+ end associate
+ end subroutine pi_setup_real_event_kinematics
+
+ end module instances
+
+ !!!!!
+
+ program main
+ use instances, only: process_instance_t
+ implicit none
+ type(process_instance_t), allocatable, target :: process_instance
+ allocate (process_instance)
+ call process_instance%init ()
+ call process_instance%setup_real_event_kinematics ()
+ if (associated (process_instance%phs)) deallocate (process_instance%phs)
+ if (allocated (process_instance)) deallocate (process_instance)
+ end program main
+ ! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } }
^ permalink raw reply [flat|nested] 2+ messages in thread
* [Patch, fortran] PR87359 [9 regression] pointer being freed was not allocated
@ 2018-09-21 17:40 Paul Richard Thomas
0 siblings, 0 replies; 2+ messages in thread
From: Paul Richard Thomas @ 2018-09-21 17:40 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1022 bytes --]
This bug was something of a disaster for Jeurgen Reuter and so I set
to it right away. Jeurgen's reduction of the failing programs save a
huge amount of time and the fix turned out to be a one-liner.
Committed after testing by Dominique.
Bootstrapped and regtested on FC28/x86_64.
Paul
Author: pault
Date: Fri Sep 21 17:26:23 2018
New Revision: 264485
URL: https://gcc.gnu.org/viewcvs?rev=264485&root=gcc&view=rev
Log:
2018-09-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/87359
* trans-stmt.c (gfc_trans_allocate): Don't deallocate alloc
components if must_finalize is set for expr3.
2018-09-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/87359
* gfortran.dg/finalize_33.f90 : New test.
Added:
trunk/gcc/testsuite/gfortran.dg/finalize_33.f90
Modified:
trunk/gcc/fortran/ChangeLog
trunk/gcc/fortran/trans-stmt.c
trunk/gcc/testsuite/ChangeLog
--
You are receiving this mail because:
You are on the CC list for the bug.
You are the assignee for the bug.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 5317 bytes --]
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 264426)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5996,6002 ****
if ((code->expr3->ts.type == BT_DERIVED
|| code->expr3->ts.type == BT_CLASS)
&& (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
! && code->expr3->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
expr3, code->expr3->rank);
--- 5996,6003 ----
if ((code->expr3->ts.type == BT_DERIVED
|| code->expr3->ts.type == BT_CLASS)
&& (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
! && code->expr3->ts.u.derived->attr.alloc_comp
! && !code->expr3->must_finalize)
{
tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
expr3, code->expr3->rank);
Index: gcc/testsuite/gfortran.dg/finalize_33.f90
===================================================================
*** gcc/testsuite/gfortran.dg/finalize_33.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/finalize_33.f90 (working copy)
***************
*** 0 ****
--- 1,119 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Tests the fix for PR87359 in which the finalization of
+ ! 'source=process%component%extract_mci_template()' in the allocation
+ ! of 'process%mci' caused invalid reads and freeing of already freed
+ ! memory. This test is a greatly reduced version of the original code.
+ !
+ ! Contributed by Juergen Reuter <juergen.reuter@desy.de>
+ !
+ module mci_base
+ implicit none
+ private
+ public :: mci_t
+ public :: mci_midpoint_t
+ public :: cnt
+ integer :: cnt = 0
+ type, abstract :: mci_t
+ integer, dimension(:), allocatable :: chain
+ end type mci_t
+ type, extends (mci_t) :: mci_midpoint_t
+ contains
+ final :: mci_midpoint_final
+ end type mci_midpoint_t
+ contains
+ IMPURE ELEMENTAL SUBROUTINE mci_midpoint_final(arg)
+ TYPE(mci_midpoint_t), INTENT(INOUT) :: arg
+ cnt = cnt + 1
+ END SUBROUTINE mci_midpoint_final
+ end module mci_base
+
+ !!!!!
+
+ module process_config
+ use mci_base
+ implicit none
+ private
+ public :: process_component_t
+ type :: process_component_t
+ class(mci_t), allocatable :: mci_template
+ contains
+ procedure :: init => process_component_init
+ procedure :: extract_mci_template => process_component_extract_mci_template
+ end type process_component_t
+
+ contains
+
+ subroutine process_component_init (component, mci_template)
+ class(process_component_t), intent(out) :: component
+ class(mci_t), intent(in), allocatable :: mci_template
+ if (allocated (mci_template)) &
+ allocate (component%mci_template, source = mci_template)
+ end subroutine process_component_init
+
+ function process_component_extract_mci_template (component) &
+ result (mci_template)
+ class(mci_t), allocatable :: mci_template
+ class(process_component_t), intent(in) :: component
+ if (allocated (component%mci_template)) &
+ allocate (mci_template, source = component%mci_template)
+ end function process_component_extract_mci_template
+ end module process_config
+
+ !!!!!
+
+ module process
+ use mci_base
+ use process_config
+ implicit none
+ private
+ public :: process_t
+ type :: process_t
+ private
+ type(process_component_t) :: component
+ class(mci_t), allocatable :: mci
+ contains
+ procedure :: init_component => process_init_component
+ procedure :: setup_mci => process_setup_mci
+ end type process_t
+ contains
+ subroutine process_init_component &
+ (process, mci_template)
+ class(process_t), intent(inout), target :: process
+ class(mci_t), intent(in), allocatable :: mci_template
+ call process%component%init (mci_template)
+ end subroutine process_init_component
+
+ subroutine process_setup_mci (process)
+ class(process_t), intent(inout) :: process
+ allocate (process%mci, source=process%component%extract_mci_template ())
+ end subroutine process_setup_mci
+
+ end module process
+
+ !!!!!
+
+ program main_ut
+ use mci_base
+ use process, only: process_t
+ implicit none
+ call event_transforms_1 ()
+ if (cnt .ne. 4) stop 2
+ contains
+
+ subroutine event_transforms_1 ()
+ class(mci_t), allocatable :: mci_template
+ type(process_t), allocatable, target :: process
+ allocate (process)
+ allocate (mci_midpoint_t :: mci_template)
+ call process%init_component (mci_template)
+ call process%setup_mci () ! generates 1 final call from call to extract_mci_template
+ if (cnt .ne. 1) stop 1
+ end subroutine event_transforms_1 ! generates 3 final calls to mci_midpoint_final:
+ ! (i) process%component%mci_template
+ ! (ii) process%mci
+ ! (iii) mci_template
+ end program main_ut
+ ! { dg-final { scan-tree-dump-times "__builtin_malloc" 17 "original" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_free" 20 "original" } }
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2018-09-30 14:00 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
[not found] <bug-87359-10374@http.gcc.gnu.org/bugzilla/>
[not found] ` <bug-87359-10374-A3nXZb7g3f@http.gcc.gnu.org/bugzilla/>
2018-09-30 14:00 ` [Patch, fortran] PR87359 [9 regression] pointer being freed was not allocated Paul Richard Thomas
2018-09-21 17:40 Paul Richard Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).