diff mbox series

[COMMITTED,16/35] ada: Fix containers' Reference_Preserving_Key functions' memory leaks

Message ID 20240517083207.130391-16-poulhies@adacore.com
State New
Headers show
Series [COMMITTED,01/35] ada: Add support for 'Object_Size to pragma Compile_Time_{Warning, Error} | expand

Commit Message

Marc Poulhiès May 17, 2024, 8:31 a.m. UTC 
From: Steve Baird <baird@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 mbox series

Patch

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;