From: Steve Baird <ba...@adacore.com>
Fix memory leaks in containers' Reference_Preserving_Key functions
Make the same change in each of 3 Ada.Containers child units: Ordered_Sets,
Indefinite_Ordered_Sets, and Bounded_Ordered_Sets. The function
Reference_Preserving_Key evaluates an allocator of type Key_Access whose
storage was not being reclaimed. Update the Finalize procedure for
type Reference_Control_Type to free that storage. But this change introduces
a possible erroneous double-free situation if an object is copied (because
the original and the copy will each be finalized at some point). So also
introduce an Adjust procedure which allocates a copy of the allocated object.
Another possible solution to this problem (which is not being implemented
yet) is based on implementing AI22-0082. Also include a fix for a bug in
Sem_Util.Has_Some_Controlled_Component that was discovered while working
on this.
gcc/ada/
* sem_util.adb (Has_Some_Controlled_Component): Fix a bug which
causes (in some cases involving a Disable_Controlled aspect
specification) Needs_Finalization to return different answers for
one type depending on whether the function is called before or
after the type is frozen.
* libgnat/a-coorse.ads: Type Control_Reference_Type gets an Adjust
procedure.
* libgnat/a-cborse.ads: Likewise.
* libgnat/a-ciorse.ads: Likewise
* libgnat/a-coorse.adb:
(Finalize): Reclaim allocated Key_Type object.
(Adjust): New procedure; prevent sharing of non-null Key_Access
values by allocating a copy.
* libgnat/a-cborse.adb: Likewise.
* libgnat/a-ciorse.adb: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/a-cborse.adb | 17 +++++++++++++++++
gcc/ada/libgnat/a-cborse.ads | 3 +++
gcc/ada/libgnat/a-ciorse.adb | 16 +++++++++++++++-
gcc/ada/libgnat/a-ciorse.ads | 3 +++
gcc/ada/libgnat/a-coorse.adb | 16 +++++++++++++++-
gcc/ada/libgnat/a-coorse.ads | 3 +++
gcc/ada/sem_util.adb | 6 +++++-
7 files changed, 61 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb
index b649c5eb6e7..9d2a0216342 100644
--- a/gcc/ada/libgnat/a-cborse.adb
+++ b/gcc/ada/libgnat/a-cborse.adb
@@ -40,6 +40,8 @@ with
Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
pragma Elaborate_All
(Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
+with Ada.Unchecked_Deallocation;
+
with System; use type System.Address;
with System.Put_Images;
@@ -775,6 +777,18 @@ is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ Impl.Reference_Control_Type (Control).Adjust;
+ if Control.Old_Key /= null then
+ Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+ end if;
+ end Adjust;
+
-------------
-- Ceiling --
-------------
@@ -872,6 +886,8 @@ is
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
begin
if Control.Container /= null then
Impl.Reference_Control_Type (Control).Finalize;
@@ -883,6 +899,7 @@ is
end if;
Control.Container := null;
+ Deallocate (Control.Old_Key);
end if;
end Finalize;
diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads
index 2366d1adcc2..650f4a40384 100644
--- a/gcc/ada/libgnat/a-cborse.ads
+++ b/gcc/ada/libgnat/a-cborse.ads
@@ -324,6 +324,9 @@ is
Old_Key : Key_Access;
end record;
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb
index d90fb882b43..fe91345cdd4 100644
--- a/gcc/ada/libgnat/a-ciorse.adb
+++ b/gcc/ada/libgnat/a-ciorse.adb
@@ -807,6 +807,18 @@ is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ Impl.Reference_Control_Type (Control).Adjust;
+ if Control.Old_Key /= null then
+ Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+ end if;
+ end Adjust;
+
-------------
-- Ceiling --
-------------
@@ -906,6 +918,8 @@ is
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
begin
if Control.Container /= null then
Impl.Reference_Control_Type (Control).Finalize;
@@ -917,7 +931,7 @@ is
end if;
Control.Container := null;
- Control.Old_Key := null;
+ Deallocate (Control.Old_Key);
end if;
end Finalize;
diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads
index a8a87cdab3e..5bc9800b5d1 100644
--- a/gcc/ada/libgnat/a-ciorse.ads
+++ b/gcc/ada/libgnat/a-ciorse.ads
@@ -338,6 +338,9 @@ is
Old_Key : Key_Access;
end record;
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb
index ca97fa4e620..a324b54fbef 100644
--- a/gcc/ada/libgnat/a-coorse.adb
+++ b/gcc/ada/libgnat/a-coorse.adb
@@ -729,6 +729,18 @@ is
Is_Less_Key_Node => Is_Less_Key_Node,
Is_Greater_Key_Node => Is_Greater_Key_Node);
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ Impl.Reference_Control_Type (Control).Adjust;
+ if Control.Old_Key /= null then
+ Control.Old_Key := new Key_Type'(Control.Old_Key.all);
+ end if;
+ end Adjust;
+
-------------
-- Ceiling --
-------------
@@ -825,6 +837,8 @@ is
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
begin
if Control.Container /= null then
Impl.Reference_Control_Type (Control).Finalize;
@@ -836,7 +850,7 @@ is
end if;
Control.Container := null;
- Control.Old_Key := null;
+ Deallocate (Control.Old_Key);
end if;
end Finalize;
diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads
index 14708752a83..ab83e1abe43 100644
--- a/gcc/ada/libgnat/a-coorse.ads
+++ b/gcc/ada/libgnat/a-coorse.ads
@@ -323,6 +323,9 @@ is
Old_Key : Key_Access;
end record;
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 01fed402256..dd9f868b696 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -22220,7 +22220,11 @@ package body Sem_Util is
elsif Is_Record_Type (Input_Typ) then
Comp := First_Component (Input_Typ);
while Present (Comp) loop
- if Needs_Finalization (Etype (Comp)) then
+ -- Skip _Parent component like Expand_Freeze_Record_Type
+
+ if Chars (Comp) /= Name_uParent
+ and then Needs_Finalization (Etype (Comp))
+ then
return True;
end if;
--
2.43.2
