From f24ea9120d7b97d0b6b047de94865f7f190e6daa Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 22 Jun 2016 12:00:24 +0200 Subject: [PATCH] [multiple changes] 2016-06-22 Ed Schonberg * sem_ch13.adb (Is_Predicate_Static): An inherited predicate can be static only if it applies to a scalar type. 2016-06-22 Ed Schonberg * exp_util.adb (Adjust_Result_Type): Convert operand to base type to prevent spurious constraint checks on subtypes of Boolean. 2016-06-22 Bob Duff * debug.adb: Document debug switch -gnatd.o. * sem_elab.adb (Check_Internal_Call): Debug switch -gnatd.o now causes a more conservative treatment of indirect calls, treating P'Access as a call to P in more cases. We Can't make this the default, because it breaks common idioms, for example the soft links. * sem_util.adb: Add an Assert. 2016-06-22 Bob Duff * a-cuprqu.ads, a-cuprqu.adb: Completely rewrite this package. Use red-black trees, which gives O(lg N) worst-case performance on Enqueue and Dequeue. The previous version had O(N) Enqueue in the worst case. 2016-06-22 Arnaud Charlet * sem_warn.adb: minor style fix in comment. * spark_xrefs.ads (Scope_Num): type refined to positive integers. * lib-xref-spark_specific.adb (Detect_And_Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs. (Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs; now uses Dspec and Scope_Id from Collect_SPARK_Xrefs. (Collect_SPARK_Xrefs): refactored to avoid retraversing the list of scopes. * sem_ch3.adb (Build_Discriminal): Set Parent of the discriminal. From-SVN: r237687 --- gcc/ada/ChangeLog | 39 +++++++ gcc/ada/a-cuprqu.adb | 254 +++++-------------------------------------- gcc/ada/a-cuprqu.ads | 93 +++++++--------- gcc/ada/debug.adb | 5 +- gcc/ada/exp_util.adb | 9 +- gcc/ada/sem_ch13.adb | 5 +- gcc/ada/sem_ch3.adb | 1 + gcc/ada/sem_elab.adb | 3 +- gcc/ada/sem_util.adb | 1 + gcc/ada/sem_warn.adb | 2 +- 10 files changed, 128 insertions(+), 284 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dd2f6796335..0302b488863 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2016-06-22 Ed Schonberg + + * sem_ch13.adb (Is_Predicate_Static): An inherited predicate + can be static only if it applies to a scalar type. + +2016-06-22 Ed Schonberg + + * exp_util.adb (Adjust_Result_Type): Convert operand to base + type to prevent spurious constraint checks on subtypes of Boolean. + +2016-06-22 Bob Duff + + * debug.adb: Document debug switch -gnatd.o. + * sem_elab.adb (Check_Internal_Call): Debug switch -gnatd.o + now causes a more conservative treatment of indirect calls, + treating P'Access as a call to P in more cases. We Can't make + this the default, because it breaks common idioms, for example + the soft links. + * sem_util.adb: Add an Assert. + +2016-06-22 Bob Duff + + * a-cuprqu.ads, a-cuprqu.adb: Completely rewrite this package. Use + red-black trees, which gives O(lg N) worst-case performance on + Enqueue and Dequeue. The previous version had O(N) Enqueue in + the worst case. + +2016-06-22 Arnaud Charlet + + * sem_warn.adb: minor style fix in comment. + * spark_xrefs.ads (Scope_Num): type refined to positive integers. + * lib-xref-spark_specific.adb (Detect_And_Add_SPARK_Scope): + moved into scope of Collect_SPARK_Xrefs. + (Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs; + now uses Dspec and Scope_Id from Collect_SPARK_Xrefs. + (Collect_SPARK_Xrefs): refactored to avoid retraversing the list + of scopes. + * sem_ch3.adb (Build_Discriminal): Set Parent of the discriminal. + 2016-06-22 Arnaud Charlet * lib-xref-spark_specific.adb (Generate_Dereference): Assignment to not diff --git a/gcc/ada/a-cuprqu.adb b/gcc/ada/a-cuprqu.adb index 5fb74cc098f..5d1bbacfc63 100644 --- a/gcc/ada/a-cuprqu.adb +++ b/gcc/ada/a-cuprqu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,225 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Deallocation; - package body Ada.Containers.Unbounded_Priority_Queues is - package body Implementation is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Before_Or_Equal (X, Y : Queue_Priority) return Boolean; - -- True if X is before or equal to Y. Equal means both Before(X,Y) and - -- Before(Y,X) are False. - - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - --------------------- - -- Before_Or_Equal -- - --------------------- - - function Before_Or_Equal (X, Y : Queue_Priority) return Boolean is - begin - return (if Before (X, Y) then True else not Before (Y, X)); - end Before_Or_Equal; - - ------------- - -- Dequeue -- - ------------- - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type) - is - H : constant Node_Access := List.Header'Unchecked_Access; - pragma Assert (List.Length /= 0); - pragma Assert (List.Header.Next /= H); - -- List can't be empty; see the barrier - - pragma Assert - (List.Header.Next.Next = H or else - Before_Or_Equal (Get_Priority (List.Header.Next.Element), - Get_Priority (List.Header.Next.Next.Element))); - -- The first item is before-or-equal to the second - - pragma Assert - (List.Header.Next.Next_Unequal = H or else - Before (Get_Priority (List.Header.Next.Element), - Get_Priority (List.Header.Next.Next_Unequal.Element))); - -- The first item is before its Next_Unequal item - - -- The highest-priority item is always first; just remove it and - -- return that element. - - X : Node_Access := List.Header.Next; - - -- Start of processing for Dequeue - - begin - Element := X.Element; - X.Next.Prev := H; - List.Header.Next := X.Next; - List.Header.Next_Unequal := X.Next; - List.Length := List.Length - 1; - Free (X); - end Dequeue; - - procedure Dequeue - (List : in out List_Type; - At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean) - is - begin - -- This operation dequeues a high priority item if it exists in the - -- queue. By "high priority" we mean an item whose priority is equal - -- or greater than the value At_Least. The generic formal operation - -- Before has the meaning "has higher priority than". To dequeue an - -- item (meaning that we return True as our Success value), we need - -- as our predicate the equivalent of "has equal or higher priority - -- than", but we cannot say that directly, so we require some logical - -- gymnastics to make it so. - - -- If E is the element at the head of the queue, and symbol ">" - -- refers to the "is higher priority than" function Before, then we - -- derive our predicate as follows: - -- original: P(E) >= At_Least - -- same as: not (P(E) < At_Least) - -- same as: not (At_Least > P(E)) - -- same as: not Before (At_Least, P(E)) - - -- But that predicate needs to be true in order to successfully - -- dequeue an item. If it's false, it means no item is dequeued, and - -- we return False as the Success value. - - Success := List.Length > 0 - and then - not Before (At_Least, Get_Priority (List.Header.Next.Element)); - - if Success then - List.Dequeue (Element); - end if; - end Dequeue; - - ------------- - -- Enqueue -- - ------------- - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type) - is - P : constant Queue_Priority := Get_Priority (New_Item); - H : constant Node_Access := List.Header'Unchecked_Access; - - function Next return Node_Access; - -- The node before which we wish to insert the new node - - ---------- - -- Next -- - ---------- - - function Next return Node_Access is - begin - return Result : Node_Access := H.Next_Unequal do - while Result /= H - and then not Before (P, Get_Priority (Result.Element)) - loop - Result := Result.Next_Unequal; - end loop; - end return; - end Next; - - -- Local varaibles - - Prev : constant Node_Access := Next.Prev; - -- The node after which we wish to insert the new node. So Prev must - -- be the header, or be higher or equal priority to the new item. - -- Prev.Next must be the header, or be lower priority than the - -- new item. - - pragma Assert - (Prev = H or else Before_Or_Equal (Get_Priority (Prev.Element), P)); - pragma Assert - (Prev.Next = H - or else Before (P, Get_Priority (Prev.Next.Element))); - pragma Assert (Prev.Next = Prev.Next_Unequal); - - Node : constant Node_Access := - new Node_Type'(New_Item, - Prev => Prev, - Next => Prev.Next, - Next_Unequal => Prev.Next); - - -- Start of processing for Enqueue - - begin - Prev.Next.Prev := Node; - Prev.Next := Node; - - if Prev = H then - - -- Make sure Next_Unequal of the Header always points to the first - -- "real" node. Here, we've inserted a new first "real" node, so - -- must update. - - List.Header.Next_Unequal := Node; - - elsif Before (Get_Priority (Prev.Element), P) then - - -- If the new item inserted has a unique priority in queue (not - -- same priority as precedent), set Next_Unequal of precedent - -- element to the new element instead of old next element, since - -- Before (P, Get_Priority (Next.Element) or Next = H). - - Prev.Next_Unequal := Node; - end if; - - pragma Assert (List.Header.Next_Unequal = List.Header.Next); - - List.Length := List.Length + 1; - - if List.Length > List.Max_Length then - List.Max_Length := List.Length; - end if; - end Enqueue; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (List : in out List_Type) is - Ignore : Queue_Interfaces.Element_Type; - begin - while List.Length > 0 loop - List.Dequeue (Ignore); - end loop; - end Finalize; - - ------------ - -- Length -- - ------------ - - function Length (List : List_Type) return Count_Type is - begin - return List.Length; - end Length; - - ---------------- - -- Max_Length -- - ---------------- - - function Max_Length (List : List_Type) return Count_Type is - begin - return List.Max_Length; - end Max_Length; - - end Implementation; - protected body Queue is ----------------- @@ -254,7 +37,7 @@ package body Ada.Containers.Unbounded_Priority_Queues is function Current_Use return Count_Type is begin - return List.Length; + return Q_Elems.Length; end Current_Use; ------------- @@ -262,10 +45,14 @@ package body Ada.Containers.Unbounded_Priority_Queues is ------------- entry Dequeue (Element : out Queue_Interfaces.Element_Type) - when List.Length > 0 + when Q_Elems.Length > 0 is + -- Grab the first item of the set, and remove it from the set + + C : constant Cursor := First (Q_Elems); begin - List.Dequeue (Element); + Element := Sets.Element (C).Item; + Delete_First (Q_Elems); end Dequeue; -------------------------------- @@ -277,8 +64,19 @@ package body Ada.Containers.Unbounded_Priority_Queues is Element : in out Queue_Interfaces.Element_Type; Success : out Boolean) is + -- Grab the first item. If it exists and has appropriate priority, + -- set Success to True, and remove that item. Otherwise, set Success + -- to False. + + C : constant Cursor := First (Q_Elems); begin - List.Dequeue (At_Least, Element, Success); + Success := Has_Element (C) and then + not Before (At_Least, Get_Priority (Sets.Element (C).Item)); + + if Success then + Element := Sets.Element (C).Item; + Delete_First (Q_Elems); + end if; end Dequeue_Only_High_Priority; ------------- @@ -287,7 +85,15 @@ package body Ada.Containers.Unbounded_Priority_Queues is entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is begin - List.Enqueue (New_Item); + Insert (Q_Elems, (Next_Sequence_Number, New_Item)); + Next_Sequence_Number := Next_Sequence_Number + 1; + + -- If we reached a new high-water mark, increase Max_Length + + if Q_Elems.Length > Max_Length then + pragma Assert (Max_Length + 1 = Q_Elems.Length); + Max_Length := Q_Elems.Length; + end if; end Enqueue; -------------- @@ -296,7 +102,7 @@ package body Ada.Containers.Unbounded_Priority_Queues is function Peak_Use return Count_Type is begin - return List.Max_Length; + return Max_Length; end Peak_Use; end Queue; diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads index 1a239837b1e..44735e0bed0 100644 --- a/gcc/ada/a-cuprqu.ads +++ b/gcc/ada/a-cuprqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -32,8 +32,8 @@ ------------------------------------------------------------------------------ with System; +with Ada.Containers.Ordered_Sets; with Ada.Containers.Synchronized_Queue_Interfaces; -with Ada.Finalization; generic with package Queue_Interfaces is @@ -59,63 +59,44 @@ package Ada.Containers.Unbounded_Priority_Queues is pragma Implementation_Defined; - type List_Type is tagged limited private; - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type); - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type); - - procedure Dequeue - (List : in out List_Type; - At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean); - - function Length (List : List_Type) return Count_Type; + -- We use an ordered set to hold the queue elements. This gives O(lg N) + -- performance in the worst case for Enqueue and Dequeue. + -- Sequence_Number is used to distinguish equivalent items. Each Enqueue + -- uses a higher Sequence_Number, so that a new item is placed after + -- already-enqueued equivalent items. + -- + -- At any time, the first set element is the one to be dequeued next (if + -- the queue is not empty). - function Max_Length (List : List_Type) return Count_Type; + type Set_Elem is record + Sequence_Number : Count_Type; + Item : Queue_Interfaces.Element_Type; + end record; - private + function "=" (X, Y : Queue_Interfaces.Element_Type) return Boolean is + (not Before (Get_Priority (X), Get_Priority (Y)) + and then not Before (Get_Priority (Y), Get_Priority (X))); + -- Elements are equal if neither is Before the other - -- List_Type is implemented as a circular doubly-linked list with a - -- dummy header node; Prev and Next are the links. The list is in - -- decreasing priority order, so the highest-priority item is always - -- first. (If there are multiple items with the highest priority, the - -- oldest one is first.) Header.Element is undefined and not used. - -- - -- In addition, Next_Unequal points to the next item with a different - -- (i.e. strictly lower) priority. This is used to speed up the search - -- for the next lower-priority item, in cases where there are many items - -- with the same priority. - -- - -- An empty list has Header.Prev, Header.Next, and Header.Next_Unequal - -- all pointing to Header. A nonempty list has Header.Next_Unequal - -- pointing to the first "real" item, and the last item has Next_Unequal - -- pointing back to Header. - - type Node_Type; - type Node_Access is access all Node_Type; - - type Node_Type is limited record - Element : Queue_Interfaces.Element_Type; - Prev, Next : Node_Access := Node_Type'Unchecked_Access; - Next_Unequal : Node_Access := Node_Type'Unchecked_Access; - end record; + function "=" (X, Y : Set_Elem) return Boolean is + (X.Sequence_Number = Y.Sequence_Number and then X.Item = Y.Item); + -- Set_Elems are equal if the elements are equal, and the + -- Sequence_Numbers are equal. This is passed to Ordered_Sets. - type List_Type is new Ada.Finalization.Limited_Controlled with record - Header : aliased Node_Type; - Length : Count_Type := 0; - Max_Length : Count_Type := 0; - end record; + function "<" (X, Y : Set_Elem) return Boolean is + (if X.Item = Y.Item + then X.Sequence_Number < Y.Sequence_Number + else Before (Get_Priority (X.Item), Get_Priority (Y.Item))); + -- If the items are equal, Sequence_Number breaks the tie. Otherwise, + -- use Before. This is passed to Ordered_Sets. - overriding procedure Finalize (List : in out List_Type); + pragma Suppress (Container_Checks); + package Sets is new Ada.Containers.Ordered_Sets (Set_Elem); end Implementation; + use Implementation, Implementation.Sets; + protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling) with Priority => Ceiling @@ -142,7 +123,15 @@ package Ada.Containers.Unbounded_Priority_Queues is overriding function Peak_Use return Count_Type; private - List : Implementation.List_Type; + Q_Elems : Set; + -- Elements of the queue + + Max_Length : Count_Type := 0; + -- The current length of the queue is the Length of Q_Elems. This is the + -- maximum value of that, so far. Updated by Enqueue. + + Next_Sequence_Number : Count_Type := 0; + -- Steadily increasing counter end Queue; end Ada.Containers.Unbounded_Priority_Queues; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index a4e83a9fad7..e3c53dda462 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -105,7 +105,7 @@ package body Debug is -- d.l Use Ada 95 semantics for limited function returns -- d.m For -gnatl, print full source only for main unit -- d.n Print source file names - -- d.o + -- d.o Conservative elaboration order for indirect calls -- d.p -- d.q -- d.r Enable OK_To_Reorder_Components in non-variant records @@ -556,6 +556,9 @@ package body Debug is -- compiler has a bug -- these are the files that need to be included -- in a bug report. + -- d.o Conservative elaboration order for indirect calls. This causes + -- P'Access to be treated as a call in more cases. + -- d.r Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have no discriminants. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a0ec3256649..b52fcccbdb4 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -355,12 +355,15 @@ package body Exp_Util is return; -- Otherwise we perform a conversion from the current type, which - -- must be Standard.Boolean, to the desired type. + -- must be Standard.Boolean, to the desired type. Use the base + -- type to prevent spurious constraint checks that are extraneous + -- to the transformation. The type and its base have the same + -- representation, standard or otherwise. else Set_Analyzed (N); - Rewrite (N, Convert_To (T, N)); - Analyze_And_Resolve (N, T); + Rewrite (N, Convert_To (Base_Type (T), N)); + Analyze_And_Resolve (N, Base_Type (T)); end if; end; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 06367aff002..599ce451c1e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8552,8 +8552,7 @@ package body Sem_Ch13 is Expression => Expr)))); -- If declaration has not been analyzed yet, Insert declaration - -- before freeze node. - -- Insert body after freeze node. + -- before freeze node. Insert body itself after freeze node. if not Analyzed (FDecl) then Insert_Before_And_Analyze (N, FDecl); @@ -11644,9 +11643,11 @@ package body Sem_Ch13 is -- to specify a static predicate for a subtype which is inheriting a -- dynamic predicate, so the static predicate validation here ignores -- the inherited predicate even if it is dynamic. + -- In all cases, a static predicate can only apply to a scalar type. elsif Nkind (Expr) = N_Function_Call and then Is_Predicate_Function (Entity (Name (Expr))) + and then Is_Scalar_Type (Etype (First_Entity (Entity (Name (Expr))))) then return True; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9fe05eb9511..d34db0210d2 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9182,6 +9182,7 @@ package body Sem_Ch3 is Set_Mechanism (D_Minal, Default_Mechanism); Set_Etype (D_Minal, Etype (Discrim)); Set_Scope (D_Minal, Current_Scope); + Set_Parent (D_Minal, Parent (Discrim)); Set_Discriminal (Discrim, D_Minal); Set_Discriminal_Link (D_Minal, Discrim); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index fd5a70360cf..1b3015aaf42 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2139,7 +2139,8 @@ package body Sem_Elab is -- node comes from source. if Nkind (N) = N_Attribute_Reference - and then (not Warn_On_Elab_Access or else not Comes_From_Source (N)) + and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) + or else not Comes_From_Source (N)) then return; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d66205167b8..de0f987d4a3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6314,6 +6314,7 @@ package body Sem_Util is Encl_Unit := Library_Unit (Encl_Unit); end loop; + pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit); return Encl_Unit; end Enclosing_Lib_Unit_Node; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index c8bf23a6ec6..cb0a09293aa 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3367,7 +3367,7 @@ package body Sem_Warn is P := Parent (C); loop -- If tree is not attached, do not issue warning (this is very - -- peculiar, and probably arises from some other error condition) + -- peculiar, and probably arises from some other error condition). if No (P) then return; -- 2.30.2