From 1f0bcd44fe7967cd994a2a1d1397305b4b8f2e47 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 12:46:54 +0200 Subject: [PATCH] sem_util.adb (New_Copy_Tree): Put back the declarations of the hash tables at library level. 2017-04-25 Eric Botcazou * 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 --- gcc/ada/ChangeLog | 43 ++++++++++ gcc/ada/bindgen.adb | 8 +- gcc/ada/errout.adb | 26 +++++- gcc/ada/exp_dbug.adb | 25 +++++- gcc/ada/fname.adb | 137 ++++++++++++++----------------- gcc/ada/sem_ch10.adb | 34 ++++---- gcc/ada/sem_util.adb | 186 +++++++++++++++++++++++-------------------- 7 files changed, 275 insertions(+), 184 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 55a1526b072..9e8581879dd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2017-04-25 Eric Botcazou + + * 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 + + * 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 + + * 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 + + * errout.adb (Error_Msg): Adapt continuation + message in instantiations and inlined bodies for info messages. + +2017-04-25 Eric Botcazou + + * 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 * checks.adb (Insert_Valid_Check): Code cleanup. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index e87b251fa13..8ada7c1ae39 100644 --- a/gcc/ada/bindgen.adb +++ b/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 diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index ea806397dc9..d2c41fcb4ab 100644 --- a/gcc/ada/errout.adb +++ b/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); diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index e463c79a3ab..d2cad8893dc 100644 --- a/gcc/ada/exp_dbug.adb +++ b/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 diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index 0024eec4e2d..5acd813d1d7 100644 --- a/gcc/ada/fname.adb +++ b/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,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; - 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 diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 11e6a4a31c2..31bf27f4a32 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -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 + + 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. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a1187824bfa..69ba0cb3017 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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; -- 2.30.2