diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 26 | ||||
| -rw-r--r-- | gcc/ada/alloc.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/atree.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/g-dyntab.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/g-table.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/g-table.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/nlists.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sinput.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/table.ads | 1 |
12 files changed, 93 insertions, 72 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1be7e3e..30dbbfc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2017-04-27 Bob Duff <duff@adacore.com> + + * sinput.adb: Minor code cleanup. + * namet.adb (Append): Create faster versions of + Append(String) and Append(Name_Id) by using slice assignment + instead of loops. + * sem_util.adb (In_Instance): Speed this up by removing + unnecessary tests; Is_Generic_Instance is defined for all + entities. + * sem_util.ads, sem_util.adb (In_Parameter_Specification): + Remove unused function. + * alloc.ads (Nodes_Initial): Use a much larger value, because + the compiler was spending a lot of time copying the nodes table + when it grows. This number was chosen in 1996, so is rather out + of date with current memory sizes. Anyway, it's virtual memory. + Get rid of Orig_Nodes_...; use Node_... instead. + * atree.adb (Lock): Do not release the Nodes tables; it's a + waste of time. + Orig_Nodes_ ==> Nodes_ + * nlists.adb: Orig_Nodes_ ==> Nodes_ + * g-table.adb: Remove unused "with" clause. + * g-table.ads, table.ads: Remove Big_Table_Type, which should + not be used by clients. + * g-dyntab.adb (Last_Allocated): New function + to encapsulate T.P.Last_Allocated, which I'm thinking of changing. + 2017-04-27 Hristian Kirtchev <kirtchev@adacore.com> * sem_eval.adb (Subtypes_Statically_Compatible): Remove duplicated diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index 7112fab..74885fd 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -100,7 +100,7 @@ package Alloc is Names_Initial : constant := 6_000; -- Namet Names_Increment : constant := 100; - Nodes_Initial : constant := 50_000; -- Atree + Nodes_Initial : constant := 5_000_000; -- Atree Nodes_Increment : constant := 100; Nodes_Release_Threshold : constant := 100_000; @@ -110,10 +110,6 @@ package Alloc is Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag Obsolescent_Warnings_Increment : constant := 200; - Orig_Nodes_Initial : constant := 50_000; -- Atree - Orig_Nodes_Increment : constant := 100; - Orig_Nodes_Release_Threshold : constant := 100_000; - Pending_Instantiations_Initial : constant := 10; -- Inline Pending_Instantiations_Increment : constant := 100; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 0505b86..16feee0 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -519,9 +519,9 @@ package body Atree is Table_Component_Type => Node_Id, Table_Index_Type => Node_Id'Base, Table_Low_Bound => First_Node_Id, - Table_Initial => Alloc.Orig_Nodes_Initial, - Table_Increment => Alloc.Orig_Nodes_Increment, - Release_Threshold => Alloc.Orig_Nodes_Release_Threshold, + Table_Initial => Alloc.Nodes_Initial, + Table_Increment => Alloc.Nodes_Increment, + Release_Threshold => Alloc.Nodes_Release_Threshold, Table_Name => "Orig_Nodes"); -------------------------- @@ -1579,11 +1579,15 @@ package body Atree is procedure Lock is begin - Nodes.Release; + -- We used to Release the tables, as in the comments below, but that is + -- a waste of time. We're only wasting virtual memory here, and the + -- release calls copy large amounts of data. + + -- Nodes.Release; Nodes.Locked := True; - Flags.Release; + -- Flags.Release; Flags.Locked := True; - Orig_Nodes.Release; + -- Orig_Nodes.Release; Orig_Nodes.Locked := True; end Lock; diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index eed1365..f975e6c 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -42,6 +42,10 @@ package body GNAT.Dynamic_Tables is -- Local Subprograms -- ----------------------- + function Last_Allocated (T : Instance) return Table_Last_Type; + pragma Inline (Last_Allocated); + -- Return the index of the last allocated element + procedure Grow (T : in out Instance; New_Last : Table_Last_Type); -- This is called when we are about to set the value of Last to a value -- that is larger than Last_Allocated. This reallocates the table to the @@ -68,7 +72,7 @@ package body GNAT.Dynamic_Tables is pragma Assert (not T.Locked); New_Last : constant Table_Last_Type := Last (T) + 1; begin - if New_Last <= T.P.Last_Allocated then + if New_Last <= Last_Allocated (T) then -- fast path T.P.Last := New_Last; T.Table (New_Last) := New_Val; @@ -115,7 +119,7 @@ package body GNAT.Dynamic_Tables is procedure For_Each (Table : Instance) is Quit : Boolean := False; begin - for Index in Table_Low_Bound .. Table.P.Last loop + for Index in First .. Last (Table) loop Action (Index, Table.Table (Index), Quit); exit when Quit; end loop; @@ -135,12 +139,12 @@ package body GNAT.Dynamic_Tables is -- storage. Fortunately, GNAT doesn't do that. pragma Assert (not T.Locked); - pragma Assert (New_Last > T.P.Last_Allocated); + pragma Assert (New_Last > Last_Allocated (T)); subtype Table_Length_Type is Table_Index_Type'Base range 0 .. Table_Index_Type'Base'Last; - Old_Last_Allocated : constant Table_Last_Type := T.P.Last_Allocated; + Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); Old_Allocated_Length : constant Table_Length_Type := Old_Last_Allocated - First + 1; @@ -200,7 +204,7 @@ package body GNAT.Dynamic_Tables is T.Table := To_Table_Ptr (New_Table); end; - pragma Assert (New_Last <= T.P.Last_Allocated); + pragma Assert (New_Last <= Last_Allocated (T)); pragma Assert (T.Table /= null); pragma Assert (T.Table /= Empty_Table_Ptr); end Grow; @@ -221,7 +225,7 @@ package body GNAT.Dynamic_Tables is procedure Init (T : in out Instance) is pragma Assert (not T.Locked); - subtype Alloc_Type is Table_Type (First .. T.P.Last_Allocated); + subtype Alloc_Type is Table_Type (First .. Last_Allocated (T)); type Alloc_Ptr is access all Alloc_Type; procedure Free is new Ada.Unchecked_Deallocation (Alloc_Type, Alloc_Ptr); @@ -247,7 +251,7 @@ package body GNAT.Dynamic_Tables is function Is_Empty (T : Instance) return Boolean is begin - return Last (T) = Table_Low_Bound - 1; + return Last (T) = First - 1; end Is_Empty; ---------- @@ -259,6 +263,15 @@ package body GNAT.Dynamic_Tables is return T.P.Last; end Last; + -------------------- + -- Last_Allocated -- + -------------------- + + function Last_Allocated (T : Instance) return Table_Last_Type is + begin + return T.P.Last_Allocated; + end Last_Allocated; + ---------- -- Move -- ---------- @@ -272,8 +285,8 @@ package body GNAT.Dynamic_Tables is From.Table := Empty_Table_Ptr; From.Locked := False; - From.P.Last_Allocated := Table_Low_Bound - 1; - From.P.Last := Table_Low_Bound - 1; + From.P.Last_Allocated := First - 1; + From.P.Last := First - 1; pragma Assert (Is_Empty (From)); end Move; @@ -283,7 +296,7 @@ package body GNAT.Dynamic_Tables is procedure Release (T : in out Instance) is pragma Assert (not T.Locked); - Old_Last_Allocated : constant Table_Last_Type := T.P.Last_Allocated; + Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); function New_Last_Allocated return Table_Last_Type; -- Compute the new value of Last_Allocated. This is normally equal to @@ -325,8 +338,8 @@ package body GNAT.Dynamic_Tables is -- Start of processing for Release begin - if New_Last_Alloc < T.P.Last_Allocated then - pragma Assert (Last (T) < T.P.Last_Allocated); + if New_Last_Alloc < Last_Allocated (T) then + pragma Assert (Last (T) < Last_Allocated (T)); pragma Assert (T.Table /= Empty_Table_Ptr); declare @@ -373,7 +386,7 @@ package body GNAT.Dynamic_Tables is -- passed by reference. Without the copy, we would deallocate the array -- containing Item, leaving a dangling pointer. - if Index > T.P.Last_Allocated then + if Index > Last_Allocated (T) then declare Item_Copy : constant Table_Component_Type := Item; begin @@ -397,7 +410,7 @@ package body GNAT.Dynamic_Tables is procedure Set_Last (T : in out Instance; New_Val : Table_Last_Type) is begin pragma Assert (not T.Locked); - if New_Val > T.P.Last_Allocated then + if New_Val > Last_Allocated (T) then Grow (T, New_Val); end if; diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb index 1c122d7..ac33bc3 100644 --- a/gcc/ada/g-table.adb +++ b/gcc/ada/g-table.adb @@ -32,8 +32,6 @@ with System; use System; with System.Memory; use System.Memory; -with Ada.Unchecked_Conversion; - package body GNAT.Table is -------------- diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads index 77e5baf..ab53813 100644 --- a/gcc/ada/g-table.ads +++ b/gcc/ada/g-table.ads @@ -71,7 +71,6 @@ package GNAT.Table is subtype Table_Last_Type is Tab.Table_Last_Type; subtype Table_Type is Tab.Table_Type; function "=" (X, Y : Table_Type) return Boolean renames Tab."="; - subtype Big_Table_Type is Tab.Big_Table_Type; subtype Table_Ptr is Tab.Table_Ptr; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index b87dd91..4e6a69a 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -116,14 +116,15 @@ package body Namet is procedure Append (Buf : in out Bounded_String; C : Character) is begin - if Buf.Length >= Buf.Chars'Last then + Buf.Length := Buf.Length + 1; + + if Buf.Length > Buf.Chars'Last then Write_Str ("Name buffer overflow; Max_Length = "); Write_Int (Int (Buf.Max_Length)); Write_Line (""); raise Program_Error; end if; - Buf.Length := Buf.Length + 1; Buf.Chars (Buf.Length) := C; end Append; @@ -137,10 +138,20 @@ package body Namet is end Append; procedure Append (Buf : in out Bounded_String; S : String) is + First : constant Natural := Buf.Length + 1; begin - for J in S'Range loop - Append (Buf, S (J)); - end loop; + Buf.Length := Buf.Length + S'Length; + + if Buf.Length > Buf.Chars'Last then + Write_Str ("Name buffer overflow; Max_Length = "); + Write_Int (Int (Buf.Max_Length)); + Write_Line (""); + raise Program_Error; + end if; + + Buf.Chars (First .. Buf.Length) := S; + -- A loop calling Append(Character) would be cleaner, but this slice + -- assignment is substantially faster. end Append; procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String) is @@ -150,12 +161,12 @@ package body Namet is procedure Append (Buf : in out Bounded_String; Id : Name_Id) is pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); - S : constant Int := Name_Entries.Table (Id).Name_Chars_Index; - + Index : constant Int := Name_Entries.Table (Id).Name_Chars_Index; + Len : constant Short := Name_Entries.Table (Id).Name_Len; + Chars : Name_Chars.Table_Type renames + Name_Chars.Table (Index + 1 .. Index + Int (Len)); begin - for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop - Append (Buf, Name_Chars.Table (S + Int (J))); - end loop; + Append (Buf, String (Chars)); end Append; -------------------- diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 7050c3e..0f111d8 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -92,17 +92,17 @@ package body Nlists is Table_Component_Type => Node_Or_Entity_Id, Table_Index_Type => Node_Or_Entity_Id'Base, Table_Low_Bound => First_Node_Id, - Table_Initial => Alloc.Orig_Nodes_Initial, - Table_Increment => Alloc.Orig_Nodes_Increment, - Release_Threshold => Alloc.Orig_Nodes_Release_Threshold, + Table_Initial => Alloc.Nodes_Initial, + Table_Increment => Alloc.Nodes_Increment, + Release_Threshold => Alloc.Nodes_Release_Threshold, Table_Name => "Next_Node"); package Prev_Node is new Table.Table ( Table_Component_Type => Node_Or_Entity_Id, Table_Index_Type => Node_Or_Entity_Id'Base, Table_Low_Bound => First_Node_Id, - Table_Initial => Alloc.Orig_Nodes_Initial, - Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Initial => Alloc.Nodes_Initial, + Table_Increment => Alloc.Nodes_Increment, Table_Name => "Prev_Node"); ----------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b01ee08..1a3b042 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11250,9 +11250,7 @@ package body Sem_Util is begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - if Ekind_In (S, E_Function, E_Package, E_Procedure) - and then Is_Generic_Instance (S) - then + if Is_Generic_Instance (S) then -- A child instance is always compiled in the context of a parent -- instance. Nevertheless, the actuals are not analyzed in an -- instance context. We detect this case by examining the current @@ -11376,26 +11374,6 @@ package body Sem_Util is return False; end In_Package_Body; - -------------------------------- - -- In_Parameter_Specification -- - -------------------------------- - - function In_Parameter_Specification (N : Node_Id) return Boolean is - PN : Node_Id; - - begin - PN := Parent (N); - while Present (PN) loop - if Nkind (PN) = N_Parameter_Specification then - return True; - end if; - - PN := Parent (PN); - end loop; - - return False; - end In_Parameter_Specification; - -------------------------- -- In_Pragma_Expression -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b1dc68a..3cc3df4 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1326,9 +1326,6 @@ package Sem_Util is function In_Package_Body return Boolean; -- Returns True if current scope is within a package body - function In_Parameter_Specification (N : Node_Id) return Boolean; - -- Returns True if node N belongs to a parameter specification - function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean; -- Returns true if the expression N occurs within a pragma with name Nam diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index a5f345d..bab55c1 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -882,7 +882,7 @@ package body Sinput is is -- A fat pointer is a pair consisting of data pointer and dope pointer, -- in that order. So we want to overwrite the second word. - Dope : Address; + Dope : System.Address; pragma Import (Ada, Dope); use System.Storage_Elements; for Dope'Address use Src + System.Address'Size / 8; diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads index 7311f6f..8782f11 100644 --- a/gcc/ada/table.ads +++ b/gcc/ada/table.ads @@ -71,7 +71,6 @@ package Table is subtype Valid_Table_Index_Type is Tab.Valid_Table_Index_Type; subtype Table_Last_Type is Tab.Table_Last_Type; subtype Table_Type is Tab.Table_Type; - subtype Big_Table_Type is Tab.Big_Table_Type; subtype Table_Ptr is Tab.Table_Ptr; |