Skip to content

R
riscv-gcc-1
Commit b4fad9fa by Javier Miranda Committed by Arnaud Charlet
Options

sem_util.adb (New_Copy_Tree): Code cleanup: removal of the internal map (ie. 

2017-01-23  Javier Miranda  <miranda@adacore.com>

	* sem_util.adb (New_Copy_Tree): Code cleanup:
	removal of the internal map (ie. variable Actual_Map, its
	associated local variables, and all the code handling it).
	* sem_ch9.adb (Analyze_Task_Type_Declaration): in GNATprove mode
	force loading of the System package when processing a task type.
	(Analyze_Protected_Type_Declaration): in GNATprove mode force
	loading of the System package when processing a protected type.
	* sem_ch10.adb (Analyze_Compilation_Unit): in GNATprove mode
	force loading of the System package when processing compilation
	unit with a main-like subprogram.
	* frontend.adb (Frontend): remove forced loading of the System
	package.

From-SVN: r244810
parent d268147d
Showing with 134 additions and 231 deletions
gcc/ada/ChangeLog
2017-01-23 Javier Miranda <miranda@adacore.com>
* sem_util.adb (New_Copy_Tree): Code cleanup:
removal of the internal map (ie. variable Actual_Map, its
associated local variables, and all the code handling it).
* sem_ch9.adb (Analyze_Task_Type_Declaration): in GNATprove mode
force loading of the System package when processing a task type.
(Analyze_Protected_Type_Declaration): in GNATprove mode force
loading of the System package when processing a protected type.
* sem_ch10.adb (Analyze_Compilation_Unit): in GNATprove mode
force loading of the System package when processing compilation
unit with a main-like subprogram.
* frontend.adb (Frontend): remove forced loading of the System
package.
2017-01-23 Ed Schonberg <schonberg@adacore.com> 2017-01-23 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Default_Initial_Condition): If the desired type * sem_prag.adb (Default_Initial_Condition): If the desired type
......
gcc/ada/frontend.adb
...@@ -463,23 +463,6 @@ begin ...@@ -463,23 +463,6 @@ begin
end if; end if;
end if; end if;
-- In GNATprove mode, force the loading of a few RTE units. This step is
-- skipped if we had a fatal error during parsing.
if GNATprove_Mode
and then Fatal_Error (Main_Unit) /= Error_Detected
then
declare
Unused : Entity_Id;
begin
-- Ensure that System.Interrupt_Priority is available to GNATprove
-- for the generation of VCs related to ceiling priority.
Unused := RTE (RE_Interrupt_Priority);
end;
end if;
-- Qualify all entity names in inner packages, package bodies, etc -- Qualify all entity names in inner packages, package bodies, etc
Exp_Dbug.Qualify_All_Entity_Names; Exp_Dbug.Qualify_All_Entity_Names;
......
gcc/ada/sem_ch10.adb
...@@ -1133,6 +1133,48 @@ package body Sem_Ch10 is ...@@ -1133,6 +1133,48 @@ package body Sem_Ch10 is
Style_Check := Save_Style_Check; Style_Check := Save_Style_Check;
end; end;
-- In GNATprove mode, force the loading of a Interrupt_Priority when
-- processing compilation units with potentially "main" subprograms.
-- This is required for the ceiling priority protocol checks, which
-- are trigerred by these subprograms.
if GNATprove_Mode
and then Nkind_In (Unit_Node, N_Subprogram_Body,
N_Procedure_Instantiation,
N_Function_Instantiation)
then
declare
Spec : Node_Id;
Unused : Entity_Id;
begin
case Nkind (Unit_Node) is
when N_Subprogram_Body =>
Spec := Specification (Unit_Node);
when N_Subprogram_Instantiation =>
Spec :=
Subprogram_Specification (Entity (Name (Unit_Node)));
when others =>
raise Program_Error;
end case;
pragma Assert (Nkind (Spec) in N_Subprogram_Specification);
-- Only subprogram with no parameters can act as "main", and if
-- it is a function, it needs to return an integer.
if No (Parameter_Specifications (Spec))
and then (Nkind (Spec) = N_Procedure_Specification
or else
Is_Integer_Type (Etype (Result_Definition (Spec))))
then
Unused := RTE (RE_Interrupt_Priority);
end if;
end;
end if;
end if; end if;
-- Deal with creating elaboration counter if needed. We create an -- Deal with creating elaboration counter if needed. We create an
......
gcc/ada/sem_ch9.adb
...@@ -2257,6 +2257,19 @@ package body Sem_Ch9 is ...@@ -2257,6 +2257,19 @@ package body Sem_Ch9 is
Process_Full_View (N, T, Def_Id); Process_Full_View (N, T, Def_Id);
end if; end if;
end if; end if;
-- In GNATprove mode, force the loading of a Interrupt_Priority, which
-- is required for the ceiling priority protocol checks trigerred by
-- calls originating from protected subprograms and entries.
if GNATprove_Mode then
declare
Unused : Entity_Id;
begin
Unused := RTE (RE_Interrupt_Priority);
end;
end if;
end Analyze_Protected_Type_Declaration; end Analyze_Protected_Type_Declaration;
--------------------- ---------------------
...@@ -3196,6 +3209,19 @@ package body Sem_Ch9 is ...@@ -3196,6 +3209,19 @@ package body Sem_Ch9 is
Process_Full_View (N, T, Def_Id); Process_Full_View (N, T, Def_Id);
end if; end if;
end if; end if;
-- In GNATprove mode, force the loading of a Interrupt_Priority, which
-- is required for the ceiling priority protocol checks trigerred by
-- calls originating from tasks.
if GNATprove_Mode then
declare
Unused : Entity_Id;
begin
Unused := RTE (RE_Interrupt_Priority);
end;
end if;
end Analyze_Task_Type_Declaration; end Analyze_Task_Type_Declaration;
----------------------------------- -----------------------------------
......
gcc/ada/sem_util.adb
...@@ -16227,31 +16227,6 @@ package body Sem_Util is ...@@ -16227,31 +16227,6 @@ package body Sem_Util is
New_Sloc : Source_Ptr := No_Location; New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id New_Scope : Entity_Id := Empty) return Node_Id
is is
Actual_Map : Elist_Id := Map;
-- This is the actual map for the copy. It is initialized with the given
-- elements, and then enlarged as required for Itypes that are copied
-- during the first phase of the copy operation. The visit procedures
-- add elements to this map as Itypes are encountered. The reason we
-- cannot use Map directly, is that it may well be (and normally is)
-- initialized to No_Elist, and if we have mapped entities, we have to
-- reset it to point to a real Elist.
NCT_Hash_Threshold : constant := 20;
-- If there are more than this number of pairs of entries in the map,
-- then Hash_Tables_Used will be set, and the hash tables will be
-- initialized and used for the searches.
NCT_Hash_Tables_Used : Boolean := False;
-- Set to True if hash tables are in use
NCT_Table_Entries : Nat := 0;
-- Count entries in table to see if threshold is reached
NCT_Hash_Table_Setup : Boolean := False;
-- Set to True if hash table contains data. We set this True if we setup
-- the hash table with data. This is a signal that we must clear its
-- contents before returning the tree copy.
------------------------------------ ------------------------------------
-- Auxiliary Data and Subprograms -- -- Auxiliary Data and Subprograms --
------------------------------------ ------------------------------------
...@@ -16312,11 +16287,11 @@ package body Sem_Util is ...@@ -16312,11 +16287,11 @@ package body Sem_Util is
function Assoc (N : Node_Or_Entity_Id) return Node_Id; function Assoc (N : Node_Or_Entity_Id) return Node_Id;
-- Called during second phase to map entities into their corresponding -- Called during second phase to map entities into their corresponding
-- copies using Actual_Map. If the argument is not an entity, or is not -- copies using the hash table. If the argument is not an entity, or is
-- in Actual_Map, then it is returned unchanged. -- not in the hash table, then it is returned unchanged.
procedure Build_NCT_Hash_Tables; procedure Build_NCT_Hash_Tables;
-- Builds hash tables (number of elements >= threshold value) -- Builds hash tables.
function Copy_Elist_With_Replacement function Copy_Elist_With_Replacement
(Old_Elist : Elist_Id) return Elist_Id; (Old_Elist : Elist_Id) return Elist_Id;
...@@ -16358,33 +16333,18 @@ package body Sem_Util is ...@@ -16358,33 +16333,18 @@ package body Sem_Util is
----------- -----------
function Assoc (N : Node_Or_Entity_Id) return Node_Id is function Assoc (N : Node_Or_Entity_Id) return Node_Id is
E : Elmt_Id;
Ent : Entity_Id; Ent : Entity_Id;
begin begin
if not Has_Extension (N) or else No (Actual_Map) then if Nkind (N) not in N_Entity then
return N; return N;
elsif NCT_Hash_Tables_Used then else
Ent := NCT_Assoc.Get (Entity_Id (N)); Ent := NCT_Assoc.Get (Entity_Id (N));
if Present (Ent) then if Present (Ent) then
return Ent; return Ent;
else
return N;
end if; end if;
-- No hash table used, do serial search
else
E := First_Elmt (Actual_Map);
while Present (E) loop
if Node (E) = N then
return Node (Next_Elmt (E));
else
E := Next_Elmt (Next_Elmt (E));
end if;
end loop;
end if; end if;
return N; return N;
...@@ -16399,7 +16359,11 @@ package body Sem_Util is ...@@ -16399,7 +16359,11 @@ package body Sem_Util is
Ent : Entity_Id; Ent : Entity_Id;
begin begin
Elmt := First_Elmt (Actual_Map); if No (Map) then
return;
end if;
Elmt := First_Elmt (Map);
while Present (Elmt) loop while Present (Elmt) loop
Ent := Node (Elmt); Ent := Node (Elmt);
...@@ -16427,9 +16391,6 @@ package body Sem_Util is ...@@ -16427,9 +16391,6 @@ package body Sem_Util is
Next_Elmt (Elmt); Next_Elmt (Elmt);
end loop; end loop;
NCT_Hash_Tables_Used := True;
NCT_Hash_Table_Setup := True;
end Build_NCT_Hash_Tables; end Build_NCT_Hash_Tables;
--------------------------------- ---------------------------------
...@@ -16678,7 +16639,7 @@ package body Sem_Util is ...@@ -16678,7 +16639,7 @@ package body Sem_Util is
if Old_Node <= Empty_Or_Error then if Old_Node <= Empty_Or_Error then
return Old_Node; return Old_Node;
elsif Has_Extension (Old_Node) then elsif Nkind (Old_Node) in N_Entity then
return Assoc (Old_Node); return Assoc (Old_Node);
else else
...@@ -16688,39 +16649,14 @@ package body Sem_Util is ...@@ -16688,39 +16649,14 @@ package body Sem_Util is
-- previously copied Itype, then adjust the associated node -- previously copied Itype, then adjust the associated node
-- of the copy of that Itype accordingly. -- of the copy of that Itype accordingly.
if Present (Actual_Map) then declare
declare Ent : constant Entity_Id := NCT_Itype_Assoc.Get (Old_Node);
E : Elmt_Id;
Ent : Entity_Id;
begin
-- Case of hash table used
if NCT_Hash_Tables_Used then
Ent := NCT_Itype_Assoc.Get (Old_Node);
if Present (Ent) then
Set_Associated_Node_For_Itype (Ent, New_Node);
end if;
-- Case of no hash table used
else
E := First_Elmt (Actual_Map);
while Present (E) loop
if Is_Itype (Node (E))
and then
Old_Node = Associated_Node_For_Itype (Node (E))
then
Set_Associated_Node_For_Itype
(Node (Next_Elmt (E)), New_Node);
end if;
E := Next_Elmt (Next_Elmt (E)); begin
end loop; if Present (Ent) then
end if; Set_Associated_Node_For_Itype (Ent, New_Node);
end; end if;
end if; end;
-- Recursively copy descendants -- Recursively copy descendants
...@@ -16846,7 +16782,7 @@ package body Sem_Util is ...@@ -16846,7 +16782,7 @@ package body Sem_Util is
-- would catch it, but it is a common case (Etype pointing to -- would catch it, but it is a common case (Etype pointing to
-- itself for an Itype that is a base type). -- itself for an Itype that is a base type).
elsif Has_Extension (Node_Id (F)) elsif Nkind (Node_Id (F)) in N_Entity
and then Is_Itype (Entity_Id (F)) and then Is_Itype (Entity_Id (F))
and then Node_Id (F) /= N and then Node_Id (F) /= N
then then
...@@ -16884,7 +16820,6 @@ package body Sem_Util is ...@@ -16884,7 +16820,6 @@ package body Sem_Util is
procedure Visit_Itype (Old_Itype : Entity_Id) is procedure Visit_Itype (Old_Itype : Entity_Id) is
New_Itype : Entity_Id; New_Itype : Entity_Id;
E : Elmt_Id;
Ent : Entity_Id; Ent : Entity_Id;
begin begin
...@@ -16913,50 +16848,23 @@ package body Sem_Util is ...@@ -16913,50 +16848,23 @@ package body Sem_Util is
-- node of some previously copied Itype, then we set the right -- node of some previously copied Itype, then we set the right
-- pointer in the other direction. -- pointer in the other direction.
if Present (Actual_Map) then Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
-- Case of hash tables used
if NCT_Hash_Tables_Used then
Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
if Present (Ent) then
Set_Associated_Node_For_Itype (New_Itype, Ent);
end if;
Ent := NCT_Itype_Assoc.Get (Old_Itype);
if Present (Ent) then
Set_Associated_Node_For_Itype (Ent, New_Itype);
-- If the hash table has no association for this Itype and its
-- associated node, enter one now.
else if Present (Ent) then
NCT_Itype_Assoc.Set Set_Associated_Node_For_Itype (New_Itype, Ent);
(Associated_Node_For_Itype (Old_Itype), New_Itype); end if;
end if;
-- Case of hash tables not used Ent := NCT_Itype_Assoc.Get (Old_Itype);
else if Present (Ent) then
E := First_Elmt (Actual_Map); Set_Associated_Node_For_Itype (Ent, New_Itype);
while Present (E) loop
if Associated_Node_For_Itype (Old_Itype) = Node (E) then
Set_Associated_Node_For_Itype
(New_Itype, Node (Next_Elmt (E)));
end if;
if Is_Type (Node (E)) -- If the hash table has no association for this Itype and its
and then Old_Itype = Associated_Node_For_Itype (Node (E)) -- associated node, enter one now.
then
Set_Associated_Node_For_Itype
(Node (Next_Elmt (E)), New_Itype);
end if;
E := Next_Elmt (Next_Elmt (E)); else
end loop; NCT_Itype_Assoc.Set
end if; (Associated_Node_For_Itype (Old_Itype), New_Itype);
end if; end if;
if Present (Freeze_Node (New_Itype)) then if Present (Freeze_Node (New_Itype)) then
...@@ -16966,23 +16874,7 @@ package body Sem_Util is ...@@ -16966,23 +16874,7 @@ package body Sem_Util is
-- Add new association to map -- Add new association to map
if No (Actual_Map) then NCT_Assoc.Set (Old_Itype, New_Itype);
Actual_Map := New_Elmt_List;
end if;
Append_Elmt (Old_Itype, Actual_Map);
Append_Elmt (New_Itype, Actual_Map);
if NCT_Hash_Tables_Used then
NCT_Assoc.Set (Old_Itype, New_Itype);
else
NCT_Table_Entries := NCT_Table_Entries + 1;
if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
end if;
end if;
-- If a record subtype is simply copied, the entity list will be -- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing. -- shared. Thus cloned_Subtype must be set to indicate the sharing.
...@@ -17041,36 +16933,14 @@ package body Sem_Util is ...@@ -17041,36 +16933,14 @@ package body Sem_Util is
begin begin
-- Handle case of an Itype, which must be copied -- Handle case of an Itype, which must be copied
if Has_Extension (N) and then Is_Itype (N) then if Nkind (N) in N_Entity and then Is_Itype (N) then
-- Nothing to do if already in the list. This can happen with an -- Nothing to do if already in the list. This can happen with an
-- Itype entity that appears more than once in the tree. Note that -- Itype entity that appears more than once in the tree. Note that
-- we do not want to visit descendants in this case. -- we do not want to visit descendants in this case.
-- Test for already in list when hash table is used if Present (NCT_Assoc.Get (Entity_Id (N))) then
return;
if NCT_Hash_Tables_Used then
if Present (NCT_Assoc.Get (Entity_Id (N))) then
return;
end if;
-- Test for already in list when hash table not used
else
declare
E : Elmt_Id;
begin
if Present (Actual_Map) then
E := First_Elmt (Actual_Map);
while Present (E) loop
if Node (E) = N then
return;
else
E := Next_Elmt (Next_Elmt (E));
end if;
end loop;
end if;
end;
end if; end if;
Visit_Itype (N); Visit_Itype (N);
...@@ -17088,34 +16958,7 @@ package body Sem_Util is ...@@ -17088,34 +16958,7 @@ package body Sem_Util is
-- Start of processing for New_Copy_Tree -- Start of processing for New_Copy_Tree
begin begin
Actual_Map := Map; Build_NCT_Hash_Tables;
-- See if we should use hash table
if No (Actual_Map) then
NCT_Hash_Tables_Used := False;
else
declare
Elmt : Elmt_Id;
begin
NCT_Table_Entries := 0;
Elmt := First_Elmt (Actual_Map);
while Present (Elmt) loop
NCT_Table_Entries := NCT_Table_Entries + 1;
Next_Elmt (Elmt);
Next_Elmt (Elmt);
end loop;
if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
else
NCT_Hash_Tables_Used := False;
end if;
end;
end if;
-- Hash table set up if required, now start phase one by visiting top -- Hash table set up if required, now start phase one by visiting top
-- node (we will recursively visit the descendants). -- node (we will recursively visit the descendants).
...@@ -17125,24 +16968,20 @@ package body Sem_Util is ...@@ -17125,24 +16968,20 @@ package body Sem_Util is
-- Now the second phase of the copy can start. First we process all the -- Now the second phase of the copy can start. First we process all the
-- mapped entities, copying their descendants. -- mapped entities, copying their descendants.
if Present (Actual_Map) then declare
declare Old_E : Entity_Id := Empty;
Elmt : Elmt_Id; New_E : Entity_Id;
New_Itype : Entity_Id;
begin
Elmt := First_Elmt (Actual_Map);
while Present (Elmt) loop
Next_Elmt (Elmt);
New_Itype := Node (Elmt);
if Is_Itype (New_Itype) then begin
Copy_Itype_With_Replacement (New_Itype); NCT_Assoc.Get_First (Old_E, New_E);
end if; while Present (New_E) loop
if Is_Itype (New_E) then
Copy_Itype_With_Replacement (New_E);
end if;
Next_Elmt (Elmt); NCT_Assoc.Get_Next (Old_E, New_E);
end loop; end loop;
end; end;
end if;
-- Now we can copy the actual tree -- Now we can copy the actual tree
...@@ -17150,10 +16989,8 @@ package body Sem_Util is ...@@ -17150,10 +16989,8 @@ package body Sem_Util is
Result : constant Node_Id := Copy_Node_With_Replacement (Source); Result : constant Node_Id := Copy_Node_With_Replacement (Source);
begin begin
if NCT_Hash_Table_Setup then NCT_Assoc.Reset;
NCT_Assoc.Reset; NCT_Itype_Assoc.Reset;
NCT_Itype_Assoc.Reset;
end if;
return Result; return Result;
end; end;
...@@ -19482,7 +19319,7 @@ package body Sem_Util is ...@@ -19482,7 +19319,7 @@ package body Sem_Util is
function Clear_Analyzed (N : Node_Id) return Traverse_Result is function Clear_Analyzed (N : Node_Id) return Traverse_Result is
begin begin
if not Has_Extension (N) then if Nkind (N) not in N_Entity then
Set_Analyzed (N, False); Set_Analyzed (N, False);
end if; end if;
......
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