From patchwork Fri Jul 9 12:38:36 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1503112 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (2048-bit key; unprotected) header.d=adacore-com.20150623.gappssmtp.com header.i=@adacore-com.20150623.gappssmtp.com header.a=rsa-sha256 header.s=20150623 header.b=h0Pjjrlj; dkim-atps=neutral Received: from sourceware.org (ip-8-43-85-97.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4GLtML1dz6z9sRN for ; Fri, 9 Jul 2021 22:51:26 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9B2753988028 for ; Fri, 9 Jul 2021 12:51:23 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lj1-x22e.google.com (mail-lj1-x22e.google.com [IPv6:2a00:1450:4864:20::22e]) by sourceware.org (Postfix) with ESMTPS id 14382398B0E1 for ; Fri, 9 Jul 2021 12:38:39 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 14382398B0E1 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-lj1-x22e.google.com with SMTP id e20so7789693ljn.8 for ; Fri, 09 Jul 2021 05:38:39 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore-com.20150623.gappssmtp.com; s=20150623; h=date:from:to:cc:subject:message-id:mime-version:content-disposition; bh=i9lC5VTY7Q/Jl/8tEdmU3csgTy3ExGnVVUJzInNeIsE=; b=h0PjjrljMyvF/Ljn+WYiAK5DMNLzjzJwR26ZDnxw57pPx1uXeEjIyMo3TNDzFp+0c+ qnsGTGUJyIdr1EsW9tQOjX37+Sy/2/0iTj8THPlCmnt60oWRT/oywFMTP3E9s8kvHzSO uuTLDZmlzj3myp2zOmxYEDHbWNQEq1pJoqtbx+CgLdmlr0RPY0PTRJcArM6fw7WM7RoR He72+uVk3xm2xNQyOSR0YGV64/Liy7ZKNOaDKB9pKllvHxxSZLZdLVoXK814cEaDO1kp /K1EWWCHSsVKtJrv0Lxg2IE/Y2wchXu1+1HL85IDyjZJZjYt+zCt1KfHrbZ1HpKU4eXs XOjg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=i9lC5VTY7Q/Jl/8tEdmU3csgTy3ExGnVVUJzInNeIsE=; b=nDAyo5ni6yFM7IsQaIOj314Tbn8gtu7N8vxJWoCQQHjOJ7Q9zrpp1MwMWUz6EfsCto NRHu8N9UJkMEXYB9BkVgnFxK5w4qkrGDAEQV20PJebFMAzB+IaTfSdnpOWJsYN28hfG2 mzoHiIiRBjjs+6l4sKP5vmGj4a3IgNoAxNJiyExKZtf1rhv/M4fdDyZ8/ruxnX3MTPLj 7P1h7JevY4SOqw6wACUfxx8MnDYgPYldCY11N1zUhmqDV4ms/UlE/0U1M6DSB8UACDXk vw8ulG3GP2Ao7KYsGN2bw0TK2uxMs7YPB2l+et1dYDFAxOjjrtifdA6pG0K15CXiC9fI gSMA== X-Gm-Message-State: AOAM530sV6u7bVE0zXULW0WF7iLjHoXVR3aIE6DosmDYYm7k4fpRO9wE 0QoXB/SI+RDGAe0Wp0nQ0NF3z80WilK/fQ== X-Google-Smtp-Source: ABdhPJy8zwxUg0uslLxYRsuT9vuhDEG7LBqqS2nUwiw0Ovx/W2PGSys/bYWHsJqFKzxqb+iQaH/Bow== X-Received: by 2002:a2e:8e2a:: with SMTP id r10mr29319739ljk.202.1625834317888; Fri, 09 Jul 2021 05:38:37 -0700 (PDT) Received: from adacore.com ([2a02:2ab8:224:2ce:72b5:e8ff:feef:ee60]) by smtp.gmail.com with ESMTPSA id n17sm457904lft.74.2021.07.09.05.38.36 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 09 Jul 2021 05:38:37 -0700 (PDT) Date: Fri, 9 Jul 2021 12:38:36 +0000 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Improve performance of Ada.Containers.Doubly_Linked_Lists.Generic_Sorting.Sort Message-ID: <20210709123836.GA3875950@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.0 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Steve Baird Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" The previous implementation could exhibit quadratic behavior in some cases (e.g., if the input was already sorted or almost sorted). The new implementation uses an N log N worst case algorithm. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * libgnat/a-cdlili.adb: Reimplement Ada.Containers.Doubly_Linked_Lists.Generic_Sorting.Sort using Mergesort instead of the previous Quicksort variant. diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb --- 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);