Commit 980f94b7 by Hristian Kirtchev Committed by Pierre-Marie de Rodat

[Ada] New ignored Ghost code removal mechanism

This patch reimplements the mechanism which removes ignored Ghost code from the
tree.

The previous mechanism proved to be unreliable because it assumed that no new
scoping constructs would be created after some ignored Ghost code had already
notified its enclosing scoping constructs that they contain such code. The
assumption can be broken by having a call to an ignored Ghost procedure within
the extended return statement of a function. The procedure call would signal
the enclosing function that it contains ignored Ghost code, however the return
statement would introduce an extra block, effectively hiding the procedure call
from the ignored Ghost code elimination pass.

The new mechanism implemented in this patch forgoes directed tree pruning in
favor of storing the actual ignored Ghost code, and later directly eliminating
it from the tree.

For this approach to operate efficiently, only "top level" ignored Ghost
constructs are stored. The top level constructs are essentially nodes which can
appear within a declarative or statement list and be safely rewritten into null
statements. This ensures that only "root" ignored Ghost construct need to be
processed, as opposed to all ignored Ghost nodes within a subtree.

The approach has one drawback however. Due to the generation and analysis of
ignored Ghost code, a construct may be recorded multiple times (usually twice).
The mechanism simply deals with this artefact instead of employing expensive
solutions such as hash tables or a common flag shared by all nodes to eliminate
the duplicates.

------------
-- Source --
------------

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;

procedure Main is
   procedure Ghost_Proc with Ghost;
   procedure Ghost_Proc is
   begin
      Put_Line ("ERROR: Ghost_Proc called");
   end Ghost_Proc;

   function Func return Integer is
   begin
      return Res : Integer := 123 do
         Ghost_Proc;
      end return;
   end Func;

   Val : Integer with Ghost;

begin
   Val := Func;
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gcc -c -gnatDG main.adb
$ grep -c "ghost" main.adb.dg
0

2018-07-17  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* alloc.ads: Update the allocation metrics of the ignored Ghost nodes
	table.
	* atree.adb: Add a soft link for a procedure which is invoked whenever
	an ignored Ghost node or entity is created.
	(Change_Node): Preserve relevant attributes which come from the Flags
	table.
	(Mark_New_Ghost_Node): Record a newly created ignored Ghost node or
	entity.
	(Rewrite): Preserve relevant attributes which come from the Flags
	table.
	(Set_Ignored_Ghost_Recording_Proc): New routine.
	* atree.ads: Define an access-to-suprogram type for a soft link which
	records a newly created ignored Ghost node or entity.
	(Set_Ignored_Ghost_Recording_Proc): New routine.
	* ghost.adb: Remove with and use clause for Lib.  Remove table
	Ignored_Ghost_Units.  Add new table Ignored_Ghost_Nodes.
	(Add_Ignored_Ghost_Unit): Removed.
	(Initialize): Initialize the table which stores ignored Ghost nodes.
	Set the soft link which allows Atree.Mark_New_Ghost_Node to record an
	ignored Ghost node.
	(Is_Ignored_Ghost_Unit): Use the ultimate original node when checking
	an eliminated ignored Ghost unit.
	(Lock): Release and lock the table which stores ignored Ghost nodes.
	(Mark_And_Set_Ghost_Assignment): Record rather than propagate ignored
	Ghost nodes.
	(Mark_And_Set_Ghost_Procedure_Call): Record rather than propagate
	ignored Ghost nodes.
	(Mark_Ghost_Clause): Record rather than propagate ignored Ghost nodes.
	(Mark_Ghost_Declaration_Or_Body): Record rather than propagate ignored
	Ghost nodes.
	(Mark_Ghost_Pragma): Record rather than propagate ignored Ghost nodes.
	(Propagate_Ignored_Ghost_Code): Removed.
	(Record_Ignored_Ghost_Node): New routine.
	(Remove_Ignored_Ghost_Code): Reimplemented.
	(Remove_Ignored_Ghost_Node): New routine.
	(Ultimate_Original_Node): New routine.
	* ghost.ads (Check_Ghost_Completion): Removed.
	* sem_ch8.adb (Analyze_Use_Package): Remove obsolete code. Mark a use
	package clause as ignored Ghost if applicable.
	* sem_util.adb (Is_Body_Or_Package_Declaration): Reimplemented.

From-SVN: r262775
parent e8427749
2018-07-17 Hristian Kirtchev <kirtchev@adacore.com>
* alloc.ads: Update the allocation metrics of the ignored Ghost nodes
table.
* atree.adb: Add a soft link for a procedure which is invoked whenever
an ignored Ghost node or entity is created.
(Change_Node): Preserve relevant attributes which come from the Flags
table.
(Mark_New_Ghost_Node): Record a newly created ignored Ghost node or
entity.
(Rewrite): Preserve relevant attributes which come from the Flags
table.
(Set_Ignored_Ghost_Recording_Proc): New routine.
* atree.ads: Define an access-to-suprogram type for a soft link which
records a newly created ignored Ghost node or entity.
(Set_Ignored_Ghost_Recording_Proc): New routine.
* ghost.adb: Remove with and use clause for Lib. Remove table
Ignored_Ghost_Units. Add new table Ignored_Ghost_Nodes.
(Add_Ignored_Ghost_Unit): Removed.
(Initialize): Initialize the table which stores ignored Ghost nodes.
Set the soft link which allows Atree.Mark_New_Ghost_Node to record an
ignored Ghost node.
(Is_Ignored_Ghost_Unit): Use the ultimate original node when checking
an eliminated ignored Ghost unit.
(Lock): Release and lock the table which stores ignored Ghost nodes.
(Mark_And_Set_Ghost_Assignment): Record rather than propagate ignored
Ghost nodes.
(Mark_And_Set_Ghost_Procedure_Call): Record rather than propagate
ignored Ghost nodes.
(Mark_Ghost_Clause): Record rather than propagate ignored Ghost nodes.
(Mark_Ghost_Declaration_Or_Body): Record rather than propagate ignored
Ghost nodes.
(Mark_Ghost_Pragma): Record rather than propagate ignored Ghost nodes.
(Propagate_Ignored_Ghost_Code): Removed.
(Record_Ignored_Ghost_Node): New routine.
(Remove_Ignored_Ghost_Code): Reimplemented.
(Remove_Ignored_Ghost_Node): New routine.
(Ultimate_Original_Node): New routine.
* ghost.ads (Check_Ghost_Completion): Removed.
* sem_ch8.adb (Analyze_Use_Package): Remove obsolete code. Mark a use
package clause as ignored Ghost if applicable.
* sem_util.adb (Is_Body_Or_Package_Declaration): Reimplemented.
2018-07-17 Javier Miranda <miranda@adacore.com> 2018-07-17 Javier Miranda <miranda@adacore.com>
* sem_ch5.adb (Has_Call_Using_Secondary_Stack): Moved to library level * sem_ch5.adb (Has_Call_Using_Secondary_Stack): Moved to library level
......
...@@ -67,8 +67,8 @@ package Alloc is ...@@ -67,8 +67,8 @@ package Alloc is
In_Out_Warnings_Initial : constant := 100; -- Sem_Warn In_Out_Warnings_Initial : constant := 100; -- Sem_Warn
In_Out_Warnings_Increment : constant := 100; In_Out_Warnings_Increment : constant := 100;
Ignored_Ghost_Units_Initial : constant := 20; -- Sem_Util Ignored_Ghost_Nodes_Initial : constant := 100; -- Ghost
Ignored_Ghost_Units_Increment : constant := 50; Ignored_Ghost_Nodes_Increment : constant := 100;
Inlined_Initial : constant := 100; -- Inline Inlined_Initial : constant := 100; -- Inline
Inlined_Increment : constant := 100; Inlined_Increment : constant := 100;
......
...@@ -48,6 +48,10 @@ with GNAT.Heap_Sort_G; ...@@ -48,6 +48,10 @@ with GNAT.Heap_Sort_G;
package body Atree is package body Atree is
Ignored_Ghost_Recording_Proc : Ignored_Ghost_Record_Proc := null;
-- This soft link captures the procedure invoked during the creation of an
-- ignored Ghost node or entity.
Locked : Boolean := False; Locked : Boolean := False;
-- Compiling with assertions enabled, node contents modifications are -- Compiling with assertions enabled, node contents modifications are
-- permitted only when this switch is set to False; compiling without -- permitted only when this switch is set to False; compiling without
...@@ -683,12 +687,21 @@ package body Atree is ...@@ -683,12 +687,21 @@ package body Atree is
----------------- -----------------
procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind) is procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind) is
Save_Sloc : constant Source_Ptr := Sloc (N);
-- Flags table attributes
Save_CA : constant Boolean := Flags.Table (N).Check_Actuals;
Save_Is_IGN : constant Boolean := Flags.Table (N).Is_Ignored_Ghost_Node;
-- Nodes table attributes
Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source;
Save_In_List : constant Boolean := Nodes.Table (N).In_List; Save_In_List : constant Boolean := Nodes.Table (N).In_List;
Save_Link : constant Union_Id := Nodes.Table (N).Link; Save_Link : constant Union_Id := Nodes.Table (N).Link;
Save_CFS : constant Boolean := Nodes.Table (N).Comes_From_Source;
Save_Posted : constant Boolean := Nodes.Table (N).Error_Posted; Save_Posted : constant Boolean := Nodes.Table (N).Error_Posted;
Par_Count : Nat := 0; Save_Sloc : constant Source_Ptr := Sloc (N);
Par_Count : Nat := 0;
begin begin
if Nkind (N) in N_Subexpr then if Nkind (N) in N_Subexpr then
...@@ -703,7 +716,9 @@ package body Atree is ...@@ -703,7 +716,9 @@ package body Atree is
Nodes.Table (N).Nkind := New_Node_Kind; Nodes.Table (N).Nkind := New_Node_Kind;
Nodes.Table (N).Error_Posted := Save_Posted; Nodes.Table (N).Error_Posted := Save_Posted;
Flags.Table (N) := Default_Flags; Flags.Table (N) := Default_Flags;
Flags.Table (N).Check_Actuals := Save_CA;
Flags.Table (N).Is_Ignored_Ghost_Node := Save_Is_IGN;
if New_Node_Kind in N_Subexpr then if New_Node_Kind in N_Subexpr then
Set_Paren_Count (N, Par_Count); Set_Paren_Count (N, Par_Count);
...@@ -1606,6 +1621,13 @@ package body Atree is ...@@ -1606,6 +1621,13 @@ package body Atree is
end if; end if;
Set_Is_Ignored_Ghost_Node (N); Set_Is_Ignored_Ghost_Node (N);
-- Record the ignored Ghost node or entity in order to eliminate it
-- from the tree later.
if Ignored_Ghost_Recording_Proc /= null then
Ignored_Ghost_Recording_Proc.all (N);
end if;
end if; end if;
end Mark_New_Ghost_Node; end Mark_New_Ghost_Node;
...@@ -1629,8 +1651,8 @@ package body Atree is ...@@ -1629,8 +1651,8 @@ package body Atree is
if Source > Empty_Or_Error then if Source > Empty_Or_Error then
New_Id := Allocate_Initialize_Node (Source, Has_Extension (Source)); New_Id := Allocate_Initialize_Node (Source, Has_Extension (Source));
Nodes.Table (New_Id).Link := Empty_List_Or_Node;
Nodes.Table (New_Id).In_List := False; Nodes.Table (New_Id).In_List := False;
Nodes.Table (New_Id).Link := Empty_List_Or_Node;
-- If the original is marked as a rewrite insertion, then unmark the -- If the original is marked as a rewrite insertion, then unmark the
-- copy, since we inserted the original, not the copy. -- copy, since we inserted the original, not the copy.
...@@ -2218,16 +2240,24 @@ package body Atree is ...@@ -2218,16 +2240,24 @@ package body Atree is
------------- -------------
procedure Rewrite (Old_Node, New_Node : Node_Id) is procedure Rewrite (Old_Node, New_Node : Node_Id) is
Old_Error_P : constant Boolean := Nodes.Table (Old_Node).Error_Posted;
-- This field is always preserved in the new node
Old_Has_Aspects : constant Boolean := Nodes.Table (Old_Node).Has_Aspects; -- Flags table attributes
-- This field is always preserved in the new node
Old_CA : constant Boolean := Flags.Table (Old_Node).Check_Actuals;
Old_Is_IGN : constant Boolean :=
Flags.Table (Old_Node).Is_Ignored_Ghost_Node;
-- Nodes table attributes
Old_Error_Posted : constant Boolean :=
Nodes.Table (Old_Node).Error_Posted;
Old_Has_Aspects : constant Boolean :=
Nodes.Table (Old_Node).Has_Aspects;
Old_Paren_Count : Nat;
Old_Must_Not_Freeze : Boolean; Old_Must_Not_Freeze : Boolean;
-- These fields are preserved in the new node only if the new node Old_Paren_Count : Nat;
-- and the old node are both subexpression nodes. -- These fields are preserved in the new node only if the new node and
-- the old node are both subexpression nodes.
-- Note: it is a violation of abstraction levels for Must_Not_Freeze -- Note: it is a violation of abstraction levels for Must_Not_Freeze
-- to be referenced like this. ??? -- to be referenced like this. ???
...@@ -2244,11 +2274,11 @@ package body Atree is ...@@ -2244,11 +2274,11 @@ package body Atree is
pragma Debug (New_Node_Debugging_Output (New_Node)); pragma Debug (New_Node_Debugging_Output (New_Node));
if Nkind (Old_Node) in N_Subexpr then if Nkind (Old_Node) in N_Subexpr then
Old_Paren_Count := Paren_Count (Old_Node);
Old_Must_Not_Freeze := Must_Not_Freeze (Old_Node); Old_Must_Not_Freeze := Must_Not_Freeze (Old_Node);
Old_Paren_Count := Paren_Count (Old_Node);
else else
Old_Paren_Count := 0;
Old_Must_Not_Freeze := False; Old_Must_Not_Freeze := False;
Old_Paren_Count := 0;
end if; end if;
-- Allocate a new node, to be used to preserve the original contents -- Allocate a new node, to be used to preserve the original contents
...@@ -2274,9 +2304,12 @@ package body Atree is ...@@ -2274,9 +2304,12 @@ package body Atree is
-- Copy substitute node into place, preserving old fields as required -- Copy substitute node into place, preserving old fields as required
Copy_Node (Source => New_Node, Destination => Old_Node); Copy_Node (Source => New_Node, Destination => Old_Node);
Nodes.Table (Old_Node).Error_Posted := Old_Error_P; Nodes.Table (Old_Node).Error_Posted := Old_Error_Posted;
Nodes.Table (Old_Node).Has_Aspects := Old_Has_Aspects; Nodes.Table (Old_Node).Has_Aspects := Old_Has_Aspects;
Flags.Table (Old_Node).Check_Actuals := Old_CA;
Flags.Table (Old_Node).Is_Ignored_Ghost_Node := Old_Is_IGN;
if Nkind (New_Node) in N_Subexpr then if Nkind (New_Node) in N_Subexpr then
Set_Paren_Count (Old_Node, Old_Paren_Count); Set_Paren_Count (Old_Node, Old_Paren_Count);
Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze); Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze);
...@@ -2369,6 +2402,18 @@ package body Atree is ...@@ -2369,6 +2402,18 @@ package body Atree is
Nodes.Table (N).Has_Aspects := Val; Nodes.Table (N).Has_Aspects := Val;
end Set_Has_Aspects; end Set_Has_Aspects;
--------------------------------------
-- Set_Ignored_Ghost_Recording_Proc --
--------------------------------------
procedure Set_Ignored_Ghost_Recording_Proc
(Proc : Ignored_Ghost_Record_Proc)
is
begin
pragma Assert (Ignored_Ghost_Recording_Proc = null);
Ignored_Ghost_Recording_Proc := Proc;
end Set_Ignored_Ghost_Recording_Proc;
------------------------------- -------------------------------
-- Set_Is_Ignored_Ghost_Node -- -- Set_Is_Ignored_Ghost_Node --
------------------------------- -------------------------------
......
...@@ -570,6 +570,13 @@ package Atree is ...@@ -570,6 +570,13 @@ package Atree is
-- are appropriately updated. This function is used only by Sinfo.CN to -- are appropriately updated. This function is used only by Sinfo.CN to
-- change nodes into their corresponding entities. -- change nodes into their corresponding entities.
type Ignored_Ghost_Record_Proc is access procedure (N : Node_Or_Entity_Id);
procedure Set_Ignored_Ghost_Recording_Proc
(Proc : Ignored_Ghost_Record_Proc);
-- Register a procedure that is invoked when an ignored Ghost node or
-- entity is created.
type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id); type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id);
procedure Set_Reporting_Proc (Proc : Report_Proc); procedure Set_Reporting_Proc (Proc : Report_Proc);
......
...@@ -29,7 +29,6 @@ with Atree; use Atree; ...@@ -29,7 +29,6 @@ with Atree; use Atree;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Lib; use Lib;
with Namet; use Namet; with Namet; use Namet;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake; with Nmake; use Nmake;
...@@ -50,18 +49,16 @@ package body Ghost is ...@@ -50,18 +49,16 @@ package body Ghost is
-- Data strictures -- -- Data strictures --
--------------------- ---------------------
-- The following table contains the N_Compilation_Unit node for a unit that -- The following table contains all ignored Ghost nodes that must be
-- is either subject to pragma Ghost with policy Ignore or contains ignored -- eliminated from the tree by routine Remove_Ignored_Ghost_Code.
-- Ghost code. The table is used in the removal of ignored Ghost code from
-- units.
package Ignored_Ghost_Units is new Table.Table ( package Ignored_Ghost_Nodes is new Table.Table (
Table_Component_Type => Node_Id, Table_Component_Type => Node_Id,
Table_Index_Type => Int, Table_Index_Type => Int,
Table_Low_Bound => 0, Table_Low_Bound => 0,
Table_Initial => Alloc.Ignored_Ghost_Units_Initial, Table_Initial => Alloc.Ignored_Ghost_Nodes_Initial,
Table_Increment => Alloc.Ignored_Ghost_Units_Increment, Table_Increment => Alloc.Ignored_Ghost_Nodes_Increment,
Table_Name => "Ignored_Ghost_Units"); Table_Name => "Ignored_Ghost_Nodes");
----------------------- -----------------------
-- Local subprograms -- -- Local subprograms --
...@@ -98,37 +95,9 @@ package body Ghost is ...@@ -98,37 +95,9 @@ package body Ghost is
-- Convert a Ghost mode denoted by name Mode into its respective enumerated -- Convert a Ghost mode denoted by name Mode into its respective enumerated
-- value. -- value.
procedure Propagate_Ignored_Ghost_Code (N : Node_Id); procedure Record_Ignored_Ghost_Node (N : Node_Or_Entity_Id);
-- Signal all enclosing scopes that they now contain at least one ignored -- Save ignored Ghost node or entity N in table Ignored_Ghost_Nodes for
-- Ghost node denoted by N. Add the compilation unit containing N to table -- later elimination.
-- Ignored_Ghost_Units for post processing.
----------------------------
-- Add_Ignored_Ghost_Unit --
----------------------------
procedure Add_Ignored_Ghost_Unit (Unit : Node_Id) is
begin
pragma Assert (Nkind (Unit) = N_Compilation_Unit);
-- Avoid duplicates in the table as pruning the same unit more than once
-- is wasteful. Since ignored Ghost code tends to be grouped up, check
-- the contents of the table in reverse.
for Index in reverse Ignored_Ghost_Units.First ..
Ignored_Ghost_Units.Last
loop
-- If the unit is already present in the table, do not add it again
if Unit = Ignored_Ghost_Units.Table (Index) then
return;
end if;
end loop;
-- If we get here, then this is the first time the unit is being added
Ignored_Ghost_Units.Append (Unit);
end Add_Ignored_Ghost_Unit;
---------------------------- ----------------------------
-- Check_Ghost_Completion -- -- Check_Ghost_Completion --
...@@ -913,7 +882,12 @@ package body Ghost is ...@@ -913,7 +882,12 @@ package body Ghost is
procedure Initialize is procedure Initialize is
begin begin
Ignored_Ghost_Units.Init; Ignored_Ghost_Nodes.Init;
-- Set the soft link which enables Atree.Mark_New_Ghost_Node to record
-- an ignored Ghost node or entity.
Set_Ignored_Ghost_Recording_Proc (Record_Ignored_Ghost_Node'Access);
end Initialize; end Initialize;
------------------------ ------------------------
...@@ -1030,6 +1004,28 @@ package body Ghost is ...@@ -1030,6 +1004,28 @@ package body Ghost is
--------------------------- ---------------------------
function Is_Ignored_Ghost_Unit (N : Node_Id) return Boolean is function Is_Ignored_Ghost_Unit (N : Node_Id) return Boolean is
function Ultimate_Original_Node (Nod : Node_Id) return Node_Id;
-- Obtain the original node of arbitrary node Nod following a potential
-- chain of rewritings.
----------------------------
-- Ultimate_Original_Node --
----------------------------
function Ultimate_Original_Node (Nod : Node_Id) return Node_Id is
Res : Node_Id;
begin
Res := Nod;
while Original_Node (Res) /= Res loop
Res := Original_Node (Res);
end loop;
return Res;
end Ultimate_Original_Node;
-- Start of processing for Is_Ignored_Ghost_Unit
begin begin
-- Inspect the original node of the unit in case removal of ignored -- Inspect the original node of the unit in case removal of ignored
-- Ghost code has already taken place. -- Ghost code has already taken place.
...@@ -1037,7 +1033,7 @@ package body Ghost is ...@@ -1037,7 +1033,7 @@ package body Ghost is
return return
Nkind (N) = N_Compilation_Unit Nkind (N) = N_Compilation_Unit
and then Is_Ignored_Ghost_Entity and then Is_Ignored_Ghost_Entity
(Defining_Entity (Original_Node (Unit (N)))); (Defining_Entity (Ultimate_Original_Node (Unit (N))));
end Is_Ignored_Ghost_Unit; end Is_Ignored_Ghost_Unit;
------------------------- -------------------------
...@@ -1176,8 +1172,8 @@ package body Ghost is ...@@ -1176,8 +1172,8 @@ package body Ghost is
procedure Lock is procedure Lock is
begin begin
Ignored_Ghost_Units.Release; Ignored_Ghost_Nodes.Release;
Ignored_Ghost_Units.Locked := True; Ignored_Ghost_Nodes.Locked := True;
end Lock; end Lock;
----------------------------------- -----------------------------------
...@@ -1201,7 +1197,7 @@ package body Ghost is ...@@ -1201,7 +1197,7 @@ package body Ghost is
Install_Ghost_Region (Ignore, N); Install_Ghost_Region (Ignore, N);
Set_Is_Ignored_Ghost_Node (N); Set_Is_Ignored_Ghost_Node (N);
Propagate_Ignored_Ghost_Code (N); Record_Ignored_Ghost_Node (N);
end if; end if;
end if; end if;
end Mark_And_Set_Ghost_Assignment; end Mark_And_Set_Ghost_Assignment;
...@@ -1472,11 +1468,39 @@ package body Ghost is ...@@ -1472,11 +1468,39 @@ package body Ghost is
Install_Ghost_Region (Ignore, N); Install_Ghost_Region (Ignore, N);
Set_Is_Ignored_Ghost_Node (N); Set_Is_Ignored_Ghost_Node (N);
Propagate_Ignored_Ghost_Code (N); Record_Ignored_Ghost_Node (N);
end if; end if;
end if; end if;
end Mark_And_Set_Ghost_Procedure_Call; end Mark_And_Set_Ghost_Procedure_Call;
-----------------------
-- Mark_Ghost_Clause --
-----------------------
procedure Mark_Ghost_Clause (N : Node_Id) is
Nam : Node_Id := Empty;
begin
if Nkind (N) = N_Use_Package_Clause then
Nam := Name (N);
elsif Nkind (N) = N_Use_Type_Clause then
Nam := Subtype_Mark (N);
elsif Nkind (N) = N_With_Clause then
Nam := Name (N);
end if;
if Present (Nam)
and then Is_Entity_Name (Nam)
and then Present (Entity (Nam))
and then Is_Ignored_Ghost_Entity (Entity (Nam))
then
Set_Is_Ignored_Ghost_Node (N);
Record_Ignored_Ghost_Node (N);
end if;
end Mark_Ghost_Clause;
------------------------------------ ------------------------------------
-- Mark_Ghost_Declaration_Or_Body -- -- Mark_Ghost_Declaration_Or_Body --
------------------------------------ ------------------------------------
...@@ -1502,7 +1526,7 @@ package body Ghost is ...@@ -1502,7 +1526,7 @@ package body Ghost is
Mark_Formals := True; Mark_Formals := True;
Set_Is_Ignored_Ghost_Entity (Id); Set_Is_Ignored_Ghost_Entity (Id);
Set_Is_Ignored_Ghost_Node (N); Set_Is_Ignored_Ghost_Node (N);
Propagate_Ignored_Ghost_Code (N); Record_Ignored_Ghost_Node (N);
end if; end if;
-- Mark all formal parameters when the related node denotes a subprogram -- Mark all formal parameters when the related node denotes a subprogram
...@@ -1538,34 +1562,6 @@ package body Ghost is ...@@ -1538,34 +1562,6 @@ package body Ghost is
end Mark_Ghost_Declaration_Or_Body; end Mark_Ghost_Declaration_Or_Body;
----------------------- -----------------------
-- Mark_Ghost_Clause --
-----------------------
procedure Mark_Ghost_Clause (N : Node_Id) is
Nam : Node_Id := Empty;
begin
if Nkind (N) = N_Use_Package_Clause then
Nam := Name (N);
elsif Nkind (N) = N_Use_Type_Clause then
Nam := Subtype_Mark (N);
elsif Nkind (N) = N_With_Clause then
Nam := Name (N);
end if;
if Present (Nam)
and then Is_Entity_Name (Nam)
and then Present (Entity (Nam))
and then Is_Ignored_Ghost_Entity (Entity (Nam))
then
Set_Is_Ignored_Ghost_Node (N);
Propagate_Ignored_Ghost_Code (N);
end if;
end Mark_Ghost_Clause;
-----------------------
-- Mark_Ghost_Pragma -- -- Mark_Ghost_Pragma --
----------------------- -----------------------
...@@ -1583,7 +1579,7 @@ package body Ghost is ...@@ -1583,7 +1579,7 @@ package body Ghost is
elsif Is_Ignored_Ghost_Entity (Id) then elsif Is_Ignored_Ghost_Entity (Id) then
Set_Is_Ignored_Ghost_Pragma (N); Set_Is_Ignored_Ghost_Pragma (N);
Set_Is_Ignored_Ghost_Node (N); Set_Is_Ignored_Ghost_Node (N);
Propagate_Ignored_Ghost_Code (N); Record_Ignored_Ghost_Node (N);
end if; end if;
end Mark_Ghost_Pragma; end Mark_Ghost_Pragma;
...@@ -1635,168 +1631,90 @@ package body Ghost is ...@@ -1635,168 +1631,90 @@ package body Ghost is
end if; end if;
end Name_To_Ghost_Mode; end Name_To_Ghost_Mode;
---------------------------------- -------------------------------
-- Propagate_Ignored_Ghost_Code -- -- Record_Ignored_Ghost_Node --
---------------------------------- -------------------------------
procedure Propagate_Ignored_Ghost_Code (N : Node_Id) is
Nod : Node_Id;
Scop : Entity_Id;
procedure Record_Ignored_Ghost_Node (N : Node_Or_Entity_Id) is
begin begin
-- Traverse the parent chain looking for blocks, packages, and -- Save all "top level" ignored Ghost nodes which can be safely replaced
-- subprograms or their respective bodies. -- with a null statement. Note that there is need to save other kinds of
-- nodes because those will always be enclosed by some top level ignored
Nod := Parent (N); -- Ghost node.
while Present (Nod) loop
Scop := Empty; if Is_Body (N)
or else Is_Declaration (N)
if Nkind (Nod) = N_Block_Statement or else Nkind (N) in N_Generic_Instantiation
and then Present (Identifier (Nod)) or else Nkind (N) in N_Push_Pop_xxx_Label
then or else Nkind (N) in N_Raise_xxx_Error
Scop := Entity (Identifier (Nod)); or else Nkind (N) in N_Representation_Clause
or else Nkind_In (N, N_Assignment_Statement,
elsif Nkind_In (Nod, N_Package_Body, N_Call_Marker,
N_Package_Declaration, N_Freeze_Entity,
N_Subprogram_Body, N_Freeze_Generic_Entity,
N_Subprogram_Declaration) N_Itype_Reference,
then N_Pragma,
Scop := Defining_Entity (Nod); N_Procedure_Call_Statement,
end if; N_Use_Package_Clause,
N_Use_Type_Clause,
-- The current node denotes a scoping construct N_Variable_Reference_Marker,
N_With_Clause)
if Present (Scop) then then
-- Only ignored Ghost nodes must be recorded in the table
-- Stop the traversal when the scope already contains ignored
-- Ghost code as all enclosing scopes have already been marked.
if Contains_Ignored_Ghost_Code (Scop) then
exit;
-- Otherwise mark this scope and keep climbing
else
Set_Contains_Ignored_Ghost_Code (Scop);
end if;
end if;
Nod := Parent (Nod);
end loop;
-- The unit containing the ignored Ghost code must be post processed
-- before invoking the back end.
Add_Ignored_Ghost_Unit (Cunit (Get_Code_Unit (N))); pragma Assert (Is_Ignored_Ghost_Node (N));
end Propagate_Ignored_Ghost_Code; Ignored_Ghost_Nodes.Append (N);
end if;
end Record_Ignored_Ghost_Node;
------------------------------- -------------------------------
-- Remove_Ignored_Ghost_Code -- -- Remove_Ignored_Ghost_Code --
------------------------------- -------------------------------
procedure Remove_Ignored_Ghost_Code is procedure Remove_Ignored_Ghost_Code is
procedure Prune_Tree (Root : Node_Id); procedure Remove_Ignored_Ghost_Node (N : Node_Id);
-- Remove all code marked as ignored Ghost from the tree of denoted by -- Eliminate ignored Ghost node N from the tree
-- Root.
----------------
-- Prune_Tree --
----------------
procedure Prune_Tree (Root : Node_Id) is
procedure Prune (N : Node_Id);
-- Remove a given node from the tree by rewriting it into null
function Prune_Node (N : Node_Id) return Traverse_Result;
-- Determine whether node N denotes an ignored Ghost construct. If
-- this is the case, rewrite N as a null statement. See the body for
-- special cases.
-----------
-- Prune --
-----------
procedure Prune (N : Node_Id) is
begin
-- Destroy any aspects that may be associated with the node
if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then
Remove_Aspects (N);
end if;
Rewrite (N, Make_Null_Statement (Sloc (N)));
end Prune;
----------------
-- Prune_Node --
----------------
function Prune_Node (N : Node_Id) return Traverse_Result is
Id : Entity_Id;
begin
-- Do not prune compilation unit nodes because many mechanisms
-- depend on their presence. Note that context items are still
-- being processed.
if Nkind (N) = N_Compilation_Unit then -------------------------------
return OK; -- Remove_Ignored_Ghost_Node --
-------------------------------
-- The node is either declared as ignored Ghost or is a byproduct procedure Remove_Ignored_Ghost_Node (N : Node_Id) is
-- of expansion. Destroy it and stop the traversal on this branch. begin
-- The generation and processing of ignored Ghost nodes may cause the
elsif Is_Ignored_Ghost_Node (N) then -- same node to be saved multiple times. Reducing the number of saves
Prune (N); -- to one involves costly solutions such as a hash table or the use
return Skip; -- of a flag shared by all nodes. To solve this problem, the removal
-- machinery allows for multiple saves, but does not eliminate a node
-- Scoping constructs such as blocks, packages, subprograms and -- which has already been eliminated.
-- bodies offer some flexibility with respect to pruning.
elsif Nkind_In (N, N_Block_Statement,
N_Package_Body,
N_Package_Declaration,
N_Subprogram_Body,
N_Subprogram_Declaration)
then
if Nkind (N) = N_Block_Statement then
Id := Entity (Identifier (N));
else
Id := Defining_Entity (N);
end if;
-- The scoping construct contains both living and ignored Ghost
-- code, let the traversal prune all relevant nodes.
if Contains_Ignored_Ghost_Code (Id) then if Nkind (N) = N_Null_Statement then
return OK; null;
-- Otherwise the construct contains only living code and should -- Otherwise the ignored Ghost node must be eliminated
-- not be pruned.
else else
return Skip; -- Only ignored Ghost nodes must be eliminated from the tree
end if;
-- Otherwise keep searching for ignored Ghost nodes pragma Assert (Is_Ignored_Ghost_Node (N));
else -- Eliminate the node by rewriting it into null. Another option
return OK; -- is to remove it from the tree, however multiple corner cases
end if; -- emerge which have be dealt individually.
end Prune_Node;
procedure Prune_Nodes is new Traverse_Proc (Prune_Node); Rewrite (N, Make_Null_Statement (Sloc (N)));
-- Start of processing for Prune_Tree -- Eliminate any aspects hanging off the ignored Ghost node
begin Remove_Aspects (N);
Prune_Nodes (Root); end if;
end Prune_Tree; end Remove_Ignored_Ghost_Node;
-- Start of processing for Remove_Ignored_Ghost_Code -- Start of processing for Remove_Ignored_Ghost_Code
begin begin
for Index in Ignored_Ghost_Units.First .. Ignored_Ghost_Units.Last loop for Index in Ignored_Ghost_Nodes.First .. Ignored_Ghost_Nodes.Last loop
Prune_Tree (Ignored_Ghost_Units.Table (Index)); Remove_Ignored_Ghost_Node (Ignored_Ghost_Nodes.Table (Index));
end loop; end loop;
end Remove_Ignored_Ghost_Code; end Remove_Ignored_Ghost_Code;
......
...@@ -31,10 +31,6 @@ with Types; use Types; ...@@ -31,10 +31,6 @@ with Types; use Types;
package Ghost is package Ghost is
procedure Add_Ignored_Ghost_Unit (Unit : Node_Id);
-- Add a single ignored Ghost compilation unit to the internal table for
-- post processing.
procedure Check_Ghost_Completion procedure Check_Ghost_Completion
(Prev_Id : Entity_Id; (Prev_Id : Entity_Id;
Compl_Id : Entity_Id); Compl_Id : Entity_Id);
......
...@@ -3782,9 +3782,7 @@ package body Sem_Ch8 is ...@@ -3782,9 +3782,7 @@ package body Sem_Ch8 is
-- Local variables -- Local variables
Ghost_Id : Entity_Id := Empty; Pack : Entity_Id;
Living_Id : Entity_Id := Empty;
Pack : Entity_Id;
-- Start of processing for Analyze_Use_Package -- Start of processing for Analyze_Use_Package
...@@ -3870,22 +3868,9 @@ package body Sem_Ch8 is ...@@ -3870,22 +3868,9 @@ package body Sem_Ch8 is
end if; end if;
Use_One_Package (N, Name (N)); Use_One_Package (N, Name (N));
-- Capture the first Ghost package and the first living package
if Is_Entity_Name (Name (N)) then
Pack := Entity (Name (N));
if Is_Ghost_Entity (Pack) then
if No (Ghost_Id) then
Ghost_Id := Pack;
end if;
elsif No (Living_Id) then
Living_Id := Pack;
end if;
end if;
end if; end if;
Mark_Ghost_Clause (N);
end Analyze_Use_Package; end Analyze_Use_Package;
---------------------- ----------------------
......
...@@ -13401,12 +13401,7 @@ package body Sem_Util is ...@@ -13401,12 +13401,7 @@ package body Sem_Util is
function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
begin begin
return Nkind_In (N, N_Entry_Body, return Is_Body (N) or else Nkind (N) = N_Package_Declaration;
N_Package_Body,
N_Package_Declaration,
N_Protected_Body,
N_Subprogram_Body,
N_Task_Body);
end Is_Body_Or_Package_Declaration; end Is_Body_Or_Package_Declaration;
----------------------- -----------------------
......
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