OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_util.adb (New_Copy_Tree): Put back the declarations of the hash tables at library level.

Browse Source 
2017-04-25  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_util.adb (New_Copy_Tree): Put back the declarations of the
	hash tables at library level.  Reinstate the NCT_Hash_Tables_Used
	variable and set it to True whenever the main hash table is
	populated.  Short- circuit the Assoc function if it is false
	and add associated guards.

From-SVN: r247181
This commit is contained in:
Arnaud Charlet 2017-04-25 12:46:54 +02:00
parent 62e45e3e70
commit 1f0bcd44fe
7 changed files with 275 additions and 184 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gcc/ada/ChangeLog
View File

@ -1,3 +1,46 @@
2017-04-25 Eric Botcazou <ebotcazou@adacore.com>
* sem_util.adb (New_Copy_Tree): Put back the declarations of the
hash tables at library level. Reinstate the NCT_Hash_Tables_Used
variable and set it to True whenever the main hash table is
populated. Short- circuit the Assoc function if it is false
and add associated guards.
2017-04-25 Olivier Hainque <hainque@adacore.com>
* bindgen.adb (Gen_Elab_Calls): Also update counter of lone
specs without elaboration code that have an elaboration counter
nevertheless, e.g. when compiled with -fpreserve-control-flow.
* sem_ch10.adb (Analyze_Compilation_Unit):
Set_Elaboration_Entity_Required when requested to preserve
control flow, to ensure the unit elaboration is materialized at
bind time, resulting in the inclusion of the unit object file
in the executable closure at link time.
2017-04-25 Pierre-Marie de Rodat <derodat@adacore.com>
* exp_dbug.adb: In Debug_Renaming_Declaration,
when dealing with indexed component, accept to produce a renaming
symbol when the index is an IN parameter or when it is a name
defined in an outer scope.
2017-04-25 Yannick Moy <moy@adacore.com>
* errout.adb (Error_Msg): Adapt continuation
message in instantiations and inlined bodies for info messages.
2017-04-25 Eric Botcazou <ebotcazou@adacore.com>
* fname.adb (Has_Internal_Extension): Add pragma Inline.
Use direct 4-character slice comparisons.
(Has_Prefix): Add
pragma Inline. (Has_Suffix): Delete.
(Is_Internal_File_Name):
Test Is_Predefined_File_Name first.
(Is_Predefined_File_Name):
Use direct slice comparisons as much as possible and limit all
comparisons to at most 8 characters.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb (Insert_Valid_Check): Code cleanup.

8
gcc/ada/bindgen.adb
View File

@ -1117,9 +1117,13 @@ package body Bindgen is
then
-- In the case of a body with a separate spec, where the
-- separate spec has an elaboration entity defined, this is
-- where we increment the elaboration entity if one exists
-- where we increment the elaboration entity if one exists.
if U.Utype = Is_Body
-- Likewise for lone specs with an elaboration entity defined
-- despite No_Elaboration_Code, e.g. when requested to
-- preserve control flow.
if (U.Utype = Is_Body or else U.Utype = Is_Spec_Only)
and then Units.Table (Unum_Spec).Set_Elab_Entity
and then not CodePeer_Mode
then

26
gcc/ada/errout.adb
View File

@ -423,9 +423,14 @@ package body Errout is
-- or
-- warning: in instantiation at
-- warning: in instantiation at ...
-- warning: original warning message
-- or
-- info: in instantiation at ...
-- info: original info message
-- All these messages are posted at the location of the top level
-- instantiation. If there are nested instantiations, then the
-- instantiation error message can be repeated, pointing to each
@ -440,9 +445,14 @@ package body Errout is
-- or
-- warning: in inlined body at
-- warning: in inlined body at ...
-- warning: original warning message
-- or
-- info: in inlined body at ...
-- info: original info message
-- OK, here we have an instantiation error, and we need to generate the
-- error on the instantiation, rather than on the template.
@ -494,7 +504,11 @@ package body Errout is
-- Case of inlined body
if Inlined_Body (X) then
if Is_Warning_Msg or Is_Style_Msg then
if Is_Info_Msg then
Error_Msg_Internal
("info: in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
elsif Is_Warning_Msg or Is_Style_Msg then
Error_Msg_Internal
(Warn_Insertion & "in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
@ -507,7 +521,11 @@ package body Errout is
-- Case of generic instantiation
else
if Is_Warning_Msg or else Is_Style_Msg then
if Is_Info_Msg then
Error_Msg_Internal
("info: in instantiation #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
elsif Is_Warning_Msg or else Is_Style_Msg then
Error_Msg_Internal
(Warn_Insertion & "in instantiation #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);

25
gcc/ada/exp_dbug.adb
View File

@ -331,6 +331,9 @@ package body Exp_Dbug is
-- output in one of these two forms. The result is prepended to the
-- name stored in Name_Buffer.
function Scope_Contains (Sc : Node_Id; Ent : Entity_Id) return Boolean;
-- Return whether Ent belong to the Sc scope
----------------------------
-- Enable_If_Packed_Array --
----------------------------
@ -354,8 +357,9 @@ package body Exp_Dbug is
Prepend_Uint_To_Buffer (Expr_Value (N));
elsif Nkind (N) = N_Identifier
and then Scope (Entity (N)) = Scope (Ent)
and then Ekind (Entity (N)) = E_Constant
and then Scope_Contains (Scope (Entity (N)), Ent)
and then (Ekind (Entity (N)) = E_Constant
or else Ekind (Entity (N)) = E_In_Parameter)
then
Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
@ -367,6 +371,23 @@ package body Exp_Dbug is
return True;
end Output_Subscript;
--------------------
-- Scope_Contains --
--------------------
function Scope_Contains (Sc : Node_Id; Ent : Entity_Id) return Boolean
is
Cur : Node_Id := Scope (Ent);
begin
while Present (Cur) loop
if Cur = Sc then
return True;
end if;
Cur := Scope (Cur);
end loop;
return False;
end Scope_Contains;
-- Start of processing for Debug_Renaming_Declaration
begin

137
gcc/ada/fname.adb
View File

@ -58,27 +58,30 @@ package body Fname is
Table_Name => "Fname_Dummy_Table");
function Has_Internal_Extension (Fname : String) return Boolean;
pragma Inline (Has_Internal_Extension);
-- True if the extension is appropriate for an internal/predefined
-- unit. That means ".ads" or ".adb" for source files, and ".ali" for
-- ALI files.
function Has_Prefix (X, Prefix : String) return Boolean;
pragma Inline (Has_Prefix);
-- True if Prefix is at the beginning of X. For example,
-- Has_Prefix("a-filename.ads", Prefix => "a-") is True.
function Has_Suffix (X, Suffix : String) return Boolean;
-- True if Suffix is at the end of X
----------------------------
-- Has_Internal_Extension --
----------------------------
function Has_Internal_Extension (Fname : String) return Boolean is
begin
return
Has_Suffix (Fname, Suffix => ".ads")
or else Has_Suffix (Fname, Suffix => ".adb")
or else Has_Suffix (Fname, Suffix => ".ali");
if Fname'Length >= 4 then
declare
S : String renames Fname (Fname'Last - 3 .. Fname'Last);
begin
return S = ".ads" or else S = ".adb" or else S = ".ali";
end;
end if;
return False;
end Has_Internal_Extension;
----------------
@ -89,32 +92,14 @@ package body Fname is
begin
if X'Length >= Prefix'Length then
declare
Slice : String renames
X (X'First .. X'First + Prefix'Length - 1);
S : String renames X (X'First .. X'First + Prefix'Length - 1);
begin
return Slice = Prefix;
return S = Prefix;
end;
end if;
return False;
end Has_Prefix;
----------------
-- Has_Suffix --
----------------
function Has_Suffix (X, Suffix : String) return Boolean is
begin
if X'Length >= Suffix'Length then
declare
Slice : String renames
X (X'Last - Suffix'Length + 1 .. X'Last);
begin
return Slice = Suffix;
end;
end if;
return False;
end Has_Suffix;
---------------------------
-- Is_Internal_File_Name --
---------------------------
@ -124,6 +109,10 @@ package body Fname is
Renamings_Included : Boolean := True) return Boolean
is
begin
if Is_Predefined_File_Name (Fname, Renamings_Included) then
return True;
end if;
-- Check for internal extensions first, so we don't think (e.g.)
-- "gnat.adc" is internal.
@ -131,10 +120,7 @@ package body Fname is
return False;
end if;
return
Is_Predefined_File_Name (Fname, Renamings_Included)
or else Has_Prefix (Fname, Prefix => "g-")
or else Has_Prefix (Fname, Prefix => "gnat.");
return Has_Prefix (Fname, "g-") or else Has_Prefix (Fname, "gnat.");
end Is_Internal_File_Name;
function Is_Internal_File_Name
@ -156,16 +142,38 @@ package body Fname is
(Fname : String;
Renamings_Included : Boolean := True) return Boolean
is
subtype Str8 is String (1 .. 8);
Renaming_Names : constant array (1 .. 8) of Str8 :=
("calendar", -- Calendar
"machcode", -- Machine_Code
"unchconv", -- Unchecked_Conversion
"unchdeal", -- Unchecked_Deallocation
"directio", -- Direct_IO
"ioexcept", -- IO_Exceptions
"sequenio", -- Sequential_IO
"text_io."); -- Text_IO
-- Note: the implementation is optimized to perform uniform comparisons
-- on string slices whose length is known at compile time and at most 8
-- characters; the remaining calls to Has_Prefix must be inlined so as
-- to expose the compile-time known length.
begin
if not Has_Internal_Extension (Fname) then
return False;
end if;
if Has_Prefix (Fname, "a-")
or else Has_Prefix (Fname, "i-")
or else Has_Prefix (Fname, "s-")
then
return True;
-- Definitely predefined if prefix is a- i- or s-
if Fname'Length >= 2 then
declare
S : String renames Fname (Fname'First .. Fname'First + 1);
begin
if S = "a-" or else S = "i-" or else S = "s-" then
return True;
end if;
end;
end if;
-- Definitely false if longer than 12 characters (8.3)
@ -176,53 +184,30 @@ package body Fname is
-- We include the "." in the prefixes below, so we don't match (e.g.)
-- adamant.ads. So the first line matches "ada.ads", "ada.adb", and
-- "ada.ali".
-- "ada.ali". But that's not necessary if they have 8 characters.
if Has_Prefix (Fname, Prefix => "ada.") -- Ada
or else Has_Prefix (Fname, Prefix => "interfac.") -- Interfaces
or else Has_Prefix (Fname, Prefix => "system.") -- System
if Has_Prefix (Fname, "ada.") -- Ada
or else Has_Prefix (Fname, "interfac") -- Interfaces
or else Has_Prefix (Fname, "system.") -- System
then
return True;
end if;
if not Renamings_Included then
return False;
-- If instructed and the name has 8+ characters, check for renamings
if Renamings_Included and then Fname'Length >= 8 then
declare
S : String renames Fname (Fname'First .. Fname'First + 7);
begin
for J in Renaming_Names'Range loop
if S = Renaming_Names (J) then
return True;
end if;
end loop;
end;
end if;
-- The following are the predefined renamings
return
-- Calendar
Has_Prefix (Fname, Prefix => "calendar.")
-- Machine_Code
or else Has_Prefix (Fname, Prefix => "machcode.")
-- Unchecked_Conversion
or else Has_Prefix (Fname, Prefix => "unchconv.")
-- Unchecked_Deallocation
or else Has_Prefix (Fname, Prefix => "unchdeal.")
-- Direct_IO
or else Has_Prefix (Fname, Prefix => "directio.")
-- IO_Exceptions
or else Has_Prefix (Fname, Prefix => "ioexcept.")
-- Sequential_IO
or else Has_Prefix (Fname, Prefix => "sequenio.")
-- Text_IO
or else Has_Prefix (Fname, Prefix => "text_io.");
return False;
end Is_Predefined_File_Name;
function Is_Predefined_File_Name

34
gcc/ada/sem_ch10.adb
View File

@ -1204,32 +1204,38 @@ package body Sem_Ch10 is
-- where the elaboration routine might otherwise be called more
-- than once.
-- Case of units which do not require elaboration checks
-- They are also needed to ensure explicit visibility from the
-- binder generated code of all the units involved in a partition
-- when control-flow preservation is requested.
if
-- Pure units do not need checks
-- Case of units which do not require an elaboration entity
Is_Pure (Spec_Id)
if not Opt.Suppress_Control_Flow_Optimizations
and then
( -- Pure units do not need checks
-- Preelaborated units do not need checks
Is_Pure (Spec_Id)
or else Is_Preelaborated (Spec_Id)
-- Preelaborated units do not need checks
-- No checks needed if pragma Elaborate_Body present
or else Is_Preelaborated (Spec_Id)
or else Has_Pragma_Elaborate_Body (Spec_Id)
-- No checks needed if pragma Elaborate_Body present
-- No checks needed if unit does not require a body
or else Has_Pragma_Elaborate_Body (Spec_Id)
or else not Unit_Requires_Body (Spec_Id)
-- No checks needed if unit does not require a body
-- No checks needed for predefined files
or else not Unit_Requires_Body (Spec_Id)
or else Is_Predefined_File_Name (Unit_File_Name (Unum))
-- No checks needed for predefined files
-- No checks required if no separate spec
or else Is_Predefined_File_Name (Unit_File_Name (Unum))
or else Acts_As_Spec (N)
-- No checks required if no separate spec
or else Acts_As_Spec (N)
)
then
-- This is a case where we only need the entity for
-- checking to prevent multiple elaboration checks.

186
gcc/ada/sem_util.adb
View File

@ -16488,6 +16488,73 @@ package body Sem_Util is
end if;
end New_Copy_List_Tree;
--------------------------------------------------
-- New_Copy_Tree Auxiliary Data and Subprograms --
--------------------------------------------------
use Atree.Unchecked_Access;
use Atree_Private_Part;
-- Our approach here requires a two pass traversal of the tree. The
-- first pass visits all nodes that eventually will be copied looking
-- for defining Itypes. If any defining Itypes are found, then they are
-- copied, and an entry is added to the replacement map. In the second
-- phase, the tree is copied, using the replacement map to replace any
-- Itype references within the copied tree.
-- The following hash tables are used to speed up access to the map. They
-- are declared at library level to avoid elaborating them for every call
-- to New_Copy_Tree. This can save up to 2% of the entire compilation time
-- spent in the front end.
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
-- Hash function used for hash operations
-------------------
-- New_Copy_Hash --
-------------------
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
begin
return Nat (E) mod (NCT_Header_Num'Last + 1);
end New_Copy_Hash;
---------------
-- NCT_Assoc --
---------------
-- The hash table NCT_Assoc associates old entities in the table with their
-- corresponding new entities (i.e. the pairs of entries presented in the
-- original Map argument are Key-Element pairs).
package NCT_Assoc is new Simple_HTable (
Header_Num => NCT_Header_Num,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => New_Copy_Hash,
Equal => Types."=");
---------------------
-- NCT_Itype_Assoc --
---------------------
-- The hash table NCT_Itype_Assoc contains entries only for those old
-- nodes which have a non-empty Associated_Node_For_Itype set. The key
-- is the associated node, and the element is the new node itself (NOT
-- the associated node for the new node).
package NCT_Itype_Assoc is new Simple_HTable (
Header_Num => NCT_Header_Num,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => New_Copy_Hash,
Equal => Types."=");
-------------------
-- New_Copy_Tree --
-------------------
@ -16509,63 +16576,10 @@ package body Sem_Util is
-- variables for declarations located in blocks or subprograms defined
-- in Expression_With_Action nodes.
------------------------------------
-- Auxiliary Data and Subprograms --
------------------------------------
use Atree.Unchecked_Access;
use Atree_Private_Part;
-- Our approach here requires a two pass traversal of the tree. The
-- first pass visits all nodes that eventually will be copied looking
-- for defining Itypes. If any defining Itypes are found, then they are
-- copied, and an entry is added to the replacement map. In the second
-- phase, the tree is copied, using the replacement map to replace any
-- Itype references within the copied tree.
-- The following hash tables are used if the Map supplied has more than
-- hash threshold entries to speed up access to the map. If there are
-- fewer entries, then the map is searched sequentially (because setting
-- up a hash table for only a few entries takes more time than it saves.
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
-- Hash function used for hash operations
---------------
-- NCT_Assoc --
---------------
-- The hash table NCT_Assoc associates old entities in the table with
-- their corresponding new entities (i.e. the pairs of entries presented
-- in the original Map argument are Key-Element pairs).
package NCT_Assoc is new Simple_HTable (
Header_Num => NCT_Header_Num,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => New_Copy_Hash,
Equal => Types."=");
---------------------
-- NCT_Itype_Assoc --
---------------------
-- The hash table NCT_Itype_Assoc contains entries only for those old
-- nodes which have a non-empty Associated_Node_For_Itype set. The key
-- is the associated node, and the element is the new node itself (NOT
-- the associated node for the new node).
package NCT_Itype_Assoc is new Simple_HTable (
Header_Num => NCT_Header_Num,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => New_Copy_Hash,
Equal => Types."=");
NCT_Hash_Tables_Used : Boolean := False;
-- Set to True if hash tables are in use. It is intended to speed up the
-- common case, which is no hash tables in use. This can save up to 8%
-- of the entire compilation time spent in the front end.
function Assoc (N : Node_Or_Entity_Id) return Node_Id;
-- Called during second phase to map entities into their corresponding
@ -16627,7 +16641,7 @@ package body Sem_Util is
Ent : Entity_Id;
begin
if Nkind (N) not in N_Entity then
if Nkind (N) not in N_Entity or else not NCT_Hash_Tables_Used then
return N;
else
@ -16681,6 +16695,8 @@ package body Sem_Util is
Next_Elmt (Elmt);
end loop;
NCT_Hash_Tables_Used := True;
end Build_NCT_Hash_Tables;
---------------------------------
@ -17041,14 +17057,6 @@ package body Sem_Util is
return False;
end In_Map;
-------------------
-- New_Copy_Hash --
-------------------
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
begin
return Nat (E) mod (NCT_Header_Num'Last + 1);
end New_Copy_Hash;
-----------------
-- Visit_Elist --
@ -17099,6 +17107,7 @@ package body Sem_Util is
-- Add new association to map
NCT_Assoc.Set (Old_Entity, New_E);
NCT_Hash_Tables_Used := True;
-- Visit descendants that eventually get copied
@ -17228,6 +17237,7 @@ package body Sem_Util is
-- Add new association to map
NCT_Assoc.Set (Old_Itype, New_Itype);
NCT_Hash_Tables_Used := True;
-- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing.
@ -17354,28 +17364,30 @@ package body Sem_Util is
-- Now the second phase of the copy can start. First we process all the
-- mapped entities, copying their descendants.
declare
Old_E : Entity_Id := Empty;
New_E : Entity_Id;
if NCT_Hash_Tables_Used then
declare
Old_E : Entity_Id := Empty;
New_E : Entity_Id;
begin
NCT_Assoc.Get_First (Old_E, New_E);
while Present (New_E) loop
begin
NCT_Assoc.Get_First (Old_E, New_E);
while Present (New_E) loop
-- Skip entities that were not created in the first phase (that
-- is, old entities specified by the caller in the set of mappings
-- to be applied to the tree).
-- Skip entities that were not created in the first phase
-- (that is, old entities specified by the caller in the
-- set of mappings to be applied to the tree).
if Is_Itype (New_E)
or else No (Map)
or else not In_Map (Old_E)
then
Copy_Entity_With_Replacement (New_E);
end if;
if Is_Itype (New_E)
or else No (Map)
or else not In_Map (Old_E)
then
Copy_Entity_With_Replacement (New_E);
end if;
NCT_Assoc.Get_Next (Old_E, New_E);
end loop;
end;
NCT_Assoc.Get_Next (Old_E, New_E);
end loop;
end;
end if;
-- Now we can copy the actual tree
@ -17383,8 +17395,10 @@ package body Sem_Util is
Result : constant Node_Id := Copy_Node_With_Replacement (Source);
begin
NCT_Assoc.Reset;
NCT_Itype_Assoc.Reset;
if NCT_Hash_Tables_Used then
NCT_Assoc.Reset;
NCT_Itype_Assoc.Reset;
end if;
return Result;
end;