+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.
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
-- 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
-- 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.
-- 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);
-- 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);
-- 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 --
----------------------------
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))));
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
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 --
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.
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
(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)
-- 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
+ -- If instructed and the name has 8+ characters, check for renamings
- 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
+ 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
-- 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
+
+ Is_Pure (Spec_Id)
- -- Preelaborated units do not need checks
+ -- Preelaborated units do not need checks
- or else Is_Preelaborated (Spec_Id)
+ or else Is_Preelaborated (Spec_Id)
- -- No checks needed if pragma Elaborate_Body present
+ -- No checks needed if pragma Elaborate_Body present
- or else Has_Pragma_Elaborate_Body (Spec_Id)
+ or else Has_Pragma_Elaborate_Body (Spec_Id)
- -- No checks needed if unit does not require a body
+ -- No checks needed if unit does not require a body
- or else not Unit_Requires_Body (Spec_Id)
+ or else not Unit_Requires_Body (Spec_Id)
- -- No checks needed for predefined files
+ -- No checks needed for predefined files
- or else Is_Predefined_File_Name (Unit_File_Name (Unum))
+ or else Is_Predefined_File_Name (Unit_File_Name (Unum))
- -- No checks required if no separate spec
+ -- No checks required if no separate spec
- or else Acts_As_Spec (N)
+ or else Acts_As_Spec (N)
+ )
then
-- This is a case where we only need the entity for
-- checking to prevent multiple elaboration checks.
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 --
-------------------
-- 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
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
Next_Elmt (Elmt);
end loop;
+
+ NCT_Hash_Tables_Used := True;
end Build_NCT_Hash_Tables;
---------------------------------
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 --
-- Add new association to map
NCT_Assoc.Set (Old_Entity, New_E);
+ NCT_Hash_Tables_Used := True;
-- Visit descendants that eventually get copied
-- 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.
-- 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
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;
projects / gcc.git / commitdiff