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

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;