+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
-- --
-- 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- --
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;
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;
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");
--------------------------
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;
-- 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
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;
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;
-- 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;
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;
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);
function Is_Empty (T : Instance) return Boolean is
begin
- return Last (T) = Table_Low_Bound - 1;
+ return Last (T) = First - 1;
end Is_Empty;
----------
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 --
----------
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;
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
-- 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
-- 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
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;
with System; use System;
with System.Memory; use System.Memory;
-with Ada.Unchecked_Conversion;
-
package body 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;
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;
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
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;
--------------------
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");
-----------------------
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
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 --
--------------------------
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
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;
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;
projects / gcc.git / commitdiff