Skip to content

R
riscv-gcc-1
Commit 1f0bcd44 by Arnaud Charlet
Options

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

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
parent 62e45e3e
Showing with 220 additions and 129 deletions
gcc/ada/ChangeLog
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.
......
gcc/ada/bindgen.adb
......@@ -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
......
gcc/ada/errout.adb
......@@ -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);
......
gcc/ada/exp_dbug.adb
......@@ -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
......
gcc/ada/fname.adb
......@@ -58,62 +58,47 @@ 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");
end Has_Internal_Extension;
----------------
-- Has_Prefix --
----------------
function Has_Prefix (X, Prefix : String) return Boolean is
begin
if X'Length >= Prefix'Length then
if Fname'Length >= 4 then
declare
Slice : String renames
X (X'First .. X'First + Prefix'Length - 1);
S : String renames Fname (Fname'Last - 3 .. Fname'Last);
begin
return Slice = Prefix;
return S = ".ads" or else S = ".adb" or else S = ".ali";
end;
end if;
return False;
end Has_Prefix;
end Has_Internal_Extension;
----------------
-- Has_Suffix --
-- Has_Prefix --
----------------
function Has_Suffix (X, Suffix : String) return Boolean is
function Has_Prefix (X, Prefix : String) return Boolean is
begin
if X'Length >= Suffix'Length then
if X'Length >= Prefix'Length then
declare
Slice : String renames
X (X'Last - Suffix'Length + 1 .. X'Last);
S : String renames X (X'First .. X'First + Prefix'Length - 1);
begin
return Slice = Suffix;
return S = Prefix;
end;
end if;
return False;
end Has_Suffix;
end Has_Prefix;
---------------------------
-- 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,17 +142,39 @@ 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
-- 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;
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
-- If instructed and the name has 8+ characters, check for renamings
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
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;
or else Has_Prefix (Fname, Prefix => "text_io.");
return False;
end Is_Predefined_File_Name;
function Is_Predefined_File_Name
......
gcc/ada/sem_ch10.adb
......@@ -1204,10 +1204,15 @@ 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
if not Opt.Suppress_Control_Flow_Optimizations
and then
( -- Pure units do not need checks
Is_Pure (Spec_Id)
......@@ -1230,6 +1235,7 @@ package body Sem_Ch10 is
-- 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.
......
gcc/ada/sem_util.adb
......@@ -16488,30 +16488,9 @@ package body Sem_Util is
end if;
end New_Copy_List_Tree;
-------------------
-- New_Copy_Tree --
-------------------
function New_Copy_Tree
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id
is
EWA_Level : Nat := 0;
-- By default, copying of defining identifiers is prohibited because
-- this would introduce an entirely new entity into the tree. The
-- exception to this general rule is declaration of constants and
-- variables located in Expression_With_Action nodes.
EWA_Inner_Scope_Level : Nat := 0;
-- Level of internal scope of defined in EWAs. Used to avoid creating
-- variables for declarations located in blocks or subprograms defined
-- in Expression_With_Action nodes.
------------------------------------
-- Auxiliary Data and Subprograms --
------------------------------------
--------------------------------------------------
-- New_Copy_Tree Auxiliary Data and Subprograms --
--------------------------------------------------
use Atree.Unchecked_Access;
use Atree_Private_Part;
......@@ -16523,10 +16502,10 @@ package body Sem_Util is
-- 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.
-- 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)
......@@ -16534,13 +16513,22 @@ package body Sem_Util is
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).
-- 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,
......@@ -16567,6 +16555,32 @@ package body Sem_Util is
Hash => New_Copy_Hash,
Equal => Types."=");
-------------------
-- New_Copy_Tree --
-------------------
function New_Copy_Tree
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id
is
EWA_Level : Nat := 0;
-- By default, copying of defining identifiers is prohibited because
-- this would introduce an entirely new entity into the tree. The
-- exception to this general rule is declaration of constants and
-- variables located in Expression_With_Action nodes.
EWA_Inner_Scope_Level : Nat := 0;
-- Level of internal scope of defined in EWAs. Used to avoid creating
-- variables for declarations located in blocks or subprograms defined
-- in Expression_With_Action nodes.
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
-- copies using the hash table. If the argument is not an entity, or is
......@@ -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,6 +17364,7 @@ package body Sem_Util is
-- Now the second phase of the copy can start. First we process all the
-- mapped entities, copying their descendants.
if NCT_Hash_Tables_Used then
declare
Old_E : Entity_Id := Empty;
New_E : Entity_Id;
......@@ -17362,9 +17373,9 @@ package body Sem_Util is
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)
......@@ -17376,6 +17387,7 @@ package body Sem_Util is
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
if NCT_Hash_Tables_Used then
NCT_Assoc.Reset;
NCT_Itype_Assoc.Reset;
end if;
return Result;
end;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment