[Ada] Improve performance of Ada.Containers.Doubly_Linked_Lists.Generic_Sorting.Sort

gcc/ada/

	* libgnat/a-cdlili.adb: Reimplement
	Ada.Containers.Doubly_Linked_Lists.Generic_Sorting.Sort using
	Mergesort instead of the previous Quicksort variant.

1 files changed, 161 insertions, 58 deletions

diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb
index 75961a2..d989751 100644
--- a/gcc/ada/libgnat/a-cdlili.adb
+++ b/gcc/ada/libgnat/a-cdlili.adb
@@ -675,68 +675,152 @@ is
 
       procedure Sort (Container : in out List) is
 
-         procedure Partition (Pivot : Node_Access; Back : Node_Access);
-
-         procedure Sort (Front, Back : Node_Access);
-
-         ---------------
-         -- Partition --
-         ---------------
+         type List_Descriptor is
+            record
+               First, Last : Node_Access;
+               Length      : Count_Type;
+            end record;
+
+         function Merge_Sort (Arg : List_Descriptor) return List_Descriptor;
+         --  Sort list of given length using MergeSort; length must be >= 2.
+         --  As required by RM, the sort is stable.
+
+         ----------------
+         -- Merge_Sort --
+         ----------------
+
+         function Merge_Sort (Arg : List_Descriptor) return List_Descriptor
+         is
+            procedure Split_List
+              (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor);
+            --  Split list into two parts for divide-and-conquer.
+            --  Unsplit.Length must be >= 2.
+
+            function Merge_Parts
+              (Part1, Part2 : List_Descriptor) return List_Descriptor;
+            --  Merge two sorted lists, preserving sorted property.
+
+            ----------------
+            -- Split_List --
+            ----------------
+
+            procedure Split_List
+              (Unsplit : List_Descriptor; Part1, Part2 : out List_Descriptor)
+            is
+               Rover : Node_Access := Unsplit.First;
+               Bump_Count : constant Count_Type := (Unsplit.Length - 1) / 2;
+            begin
+               for Iter in 1 .. Bump_Count loop
+                  Rover := Rover.Next;
+               end loop;
+
+               Part1 := (First  => Unsplit.First,
+                         Last   => Rover,
+                         Length => Bump_Count + 1);
+
+               Part2 := (First => Rover.Next,
+                         Last  => Unsplit.Last,
+                         Length => Unsplit.Length - Part1.Length);
+
+               --  Detach
+               Part1.Last.Next := null;
+               Part2.First.Prev := null;
+            end Split_List;
+
+            -----------------
+            -- Merge_Parts --
+            -----------------
+
+            function Merge_Parts
+              (Part1, Part2 : List_Descriptor) return List_Descriptor
+            is
+               Empty  : constant List_Descriptor := (null, null, 0);
+
+               procedure Detach_First (Source   : in out List_Descriptor;
+                                       Detached : out Node_Access);
+               --  Detach the first element from a non-empty list and
+               --  return the detached node via the Detached parameter.
+
+               ------------------
+               -- Detach_First --
+               ------------------
+
+               procedure Detach_First (Source   : in out List_Descriptor;
+                                       Detached : out Node_Access) is
+               begin
+                  Detached := Source.First;
+
+                  if Source.Length = 1 then
+                     Source := Empty;
+                  else
+                     Source := (Source.First.Next,
+                                Source.Last,
+                                Source.Length - 1);
+
+                     Detached.Next.Prev := null;
+                     Detached.Next := null;
+                  end if;
+               end Detach_First;
+
+               P1     : List_Descriptor := Part1;
+               P2     : List_Descriptor := Part2;
+               Merged : List_Descriptor := Empty;
+
+               Take_From_P2 : Boolean;
+               Detached     : Node_Access;
+
+            --  Start of processing for Merge_Parts
 
-         procedure Partition (Pivot : Node_Access; Back : Node_Access) is
-            Node : Node_Access;
+            begin
+               while (P1.Length /= 0) or (P2.Length /= 0) loop
+                  if P1.Length = 0 then
+                     Take_From_P2 := True;
+                  elsif P2.Length = 0 then
+                     Take_From_P2 := False;
+                  else
+                     --  If the compared elements are equal then Take_From_P2
+                     --  must be False in order to ensure stability.
+
+                     Take_From_P2 := P2.First.Element < P1.First.Element;
+                  end if;
+
+                  if Take_From_P2 then
+                     Detach_First (P2, Detached);
+                  else
+                     Detach_First (P1, Detached);
+                  end if;
+
+                  if Merged.Length = 0 then
+                     Merged := (First | Last => Detached, Length => 1);
+                  else
+                     Detached.Prev := Merged.Last;
+                     Merged.Last.Next := Detached;
+                     Merged.Last := Detached;
+                     Merged.Length := Merged.Length + 1;
+                  end if;
+               end loop;
+               return Merged;
+            end Merge_Parts;
+
+         --  Start of processing for Merge_Sort
 
          begin
-            Node := Pivot.Next;
-            while Node /= Back loop
-               if Node.Element < Pivot.Element then
-                  declare
-                     Prev : constant Node_Access := Node.Prev;
-                     Next : constant Node_Access := Node.Next;
-
-                  begin
-                     Prev.Next := Next;
-
-                     if Next = null then
-                        Container.Last := Prev;
-                     else
-                        Next.Prev := Prev;
-                     end if;
-
-                     Node.Next := Pivot;
-                     Node.Prev := Pivot.Prev;
-
-                     Pivot.Prev := Node;
-
-                     if Node.Prev = null then
-                        Container.First := Node;
-                     else
-                        Node.Prev.Next := Node;
-                     end if;
-
-                     Node := Next;
-                  end;
+            if Arg.Length < 2 then
+               --  already sorted
+               return Arg;
+            end if;
 
-               else
-                  Node := Node.Next;
-               end if;
-            end loop;
-         end Partition;
+            declare
+               Part1, Part2 : List_Descriptor;
+            begin
+               Split_List (Unsplit => Arg, Part1 => Part1, Part2 => Part2);
 
-         ----------
-         -- Sort --
-         ----------
+               Part1 := Merge_Sort (Part1);
+               Part2 := Merge_Sort (Part2);
 
-         procedure Sort (Front, Back : Node_Access) is
-            Pivot : constant Node_Access :=
-              (if Front = null then Container.First else Front.Next);
-         begin
-            if Pivot /= Back then
-               Partition (Pivot, Back);
-               Sort (Front, Pivot);
-               Sort (Pivot, Back);
-            end if;
-         end Sort;
+               return Merge_Parts (Part1, Part2);
+            end;
+         end Merge_Sort;
 
       --  Start of processing for Sort
 
@@ -754,9 +838,28 @@ is
          --  element tampering by a generic actual subprogram.
 
          declare
-            Lock : With_Lock (Container.TC'Unchecked_Access);
+            Lock     : With_Lock (Container.TC'Unchecked_Access);
+
+            Unsorted : constant List_Descriptor :=
+                                  (First  => Container.First,
+                                   Last   => Container.Last,
+                                   Length => Container.Length);
+
+            Sorted   : List_Descriptor;
          begin
-            Sort (Front => null, Back => null);
+            --  If a call to the formal < operator references the container
+            --  during sorting, seeing an empty container seems preferable
+            --  to seeing an internally inconsistent container.
+            --
+            Container.First  := null;
+            Container.Last   := null;
+            Container.Length := 0;
+
+            Sorted := Merge_Sort (Unsorted);
+
+            Container.First  := Sorted.First;
+            Container.Last   := Sorted.Last;
+            Container.Length := Sorted.Length;
          end;
 
          pragma Assert (Container.First.Prev = null);