blob: 0017d4b9baf278ccc223f67aac5919aaa820696e [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- B I N D O . B U I L D E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2019-2021, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Binderr; use Binderr;
with Butil; use Butil;
with Debug; use Debug;
with Opt; use Opt;
with Output; use Output;
with Types; use Types;
with Bindo.Units; use Bindo.Units;
with Bindo.Validators;
use Bindo.Validators;
use Bindo.Validators.Invocation_Graph_Validators;
use Bindo.Validators.Library_Graph_Validators;
with Bindo.Writers;
use Bindo.Writers;
use Bindo.Writers.Phase_Writers;
with GNAT; use GNAT;
with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
package body Bindo.Builders is
-------------------------------
-- Invocation_Graph_Builders --
-------------------------------
package body Invocation_Graph_Builders is
-----------------
-- Global data --
-----------------
Inv_Graph : Invocation_Graph := Invocation_Graphs.Nil;
Lib_Graph : Library_Graph := Library_Graphs.Nil;
-----------------------
-- Local subprograms --
-----------------------
procedure Create_Edge (IR_Id : Invocation_Relation_Id);
pragma Inline (Create_Edge);
-- Create a new edge for invocation relation IR_Id in invocation graph
-- Inv_Graph.
procedure Create_Edges (U_Id : Unit_Id);
pragma Inline (Create_Edges);
-- Create new edges for all invocation relations of unit U_Id
procedure Create_Vertex
(IC_Id : Invocation_Construct_Id;
Vertex : Library_Graph_Vertex_Id);
pragma Inline (Create_Vertex);
-- Create a new vertex for invocation construct IC_Id in invocation
-- graph Inv_Graph. The vertex is linked to vertex Vertex of library
-- graph Lib_Graph.
procedure Create_Vertices (U_Id : Unit_Id);
pragma Inline (Create_Vertices);
-- Create new vertices for all invocation constructs of unit U_Id in
-- invocation graph Inv_Graph.
function Declaration_Placement_Vertex
(Vertex : Library_Graph_Vertex_Id;
Placement : Declaration_Placement_Kind)
return Library_Graph_Vertex_Id;
pragma Inline (Declaration_Placement_Vertex);
-- Obtain the spec or body of vertex Vertex depending on the requested
-- placement in Placement.
----------------------------
-- Build_Invocation_Graph --
----------------------------
function Build_Invocation_Graph
(Lib_G : Library_Graph) return Invocation_Graph
is
begin
pragma Assert (Present (Lib_G));
Start_Phase (Invocation_Graph_Construction);
-- Prepare the global data
Inv_Graph :=
Create
(Initial_Vertices => Number_Of_Elaborable_Units,
Initial_Edges => Number_Of_Elaborable_Units,
Lib_Graph => Lib_G);
Lib_Graph := Lib_G;
For_Each_Elaborable_Unit (Create_Vertices'Access);
For_Each_Elaborable_Unit (Create_Edges'Access);
Validate_Invocation_Graph (Inv_Graph);
End_Phase (Invocation_Graph_Construction);
return Inv_Graph;
end Build_Invocation_Graph;
-----------------
-- Create_Edge --
-----------------
procedure Create_Edge (IR_Id : Invocation_Relation_Id) is
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (IR_Id));
Invoker_Sig : constant Invocation_Signature_Id := Invoker (IR_Id);
Target_Sig : constant Invocation_Signature_Id := Target (IR_Id);
pragma Assert (Present (Invoker_Sig));
pragma Assert (Present (Target_Sig));
begin
-- Nothing to do when the target denotes an invocation construct that
-- resides in a unit which will never be elaborated.
if not Needs_Elaboration (Target_Sig) then
return;
end if;
Add_Edge
(G => Inv_Graph,
Source => Corresponding_Vertex (Inv_Graph, Invoker_Sig),
Target => Corresponding_Vertex (Inv_Graph, Target_Sig),
IR_Id => IR_Id);
end Create_Edge;
------------------
-- Create_Edges --
------------------
procedure Create_Edges (U_Id : Unit_Id) is
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (U_Id));
U_Rec : Unit_Record renames ALI.Units.Table (U_Id);
begin
for IR_Id in U_Rec.First_Invocation_Relation ..
U_Rec.Last_Invocation_Relation
loop
Create_Edge (IR_Id);
end loop;
end Create_Edges;
-------------------
-- Create_Vertex --
-------------------
procedure Create_Vertex
(IC_Id : Invocation_Construct_Id;
Vertex : Library_Graph_Vertex_Id)
is
begin
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (IC_Id));
pragma Assert (Present (Vertex));
Add_Vertex
(G => Inv_Graph,
IC_Id => IC_Id,
Body_Vertex =>
Declaration_Placement_Vertex
(Vertex => Vertex,
Placement => Body_Placement (IC_Id)),
Spec_Vertex =>
Declaration_Placement_Vertex
(Vertex => Vertex,
Placement => Spec_Placement (IC_Id)));
end Create_Vertex;
---------------------
-- Create_Vertices --
---------------------
procedure Create_Vertices (U_Id : Unit_Id) is
pragma Assert (Present (Inv_Graph));
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (U_Id));
U_Rec : Unit_Record renames ALI.Units.Table (U_Id);
Vertex : constant Library_Graph_Vertex_Id :=
Corresponding_Vertex (Lib_Graph, U_Id);
begin
for IC_Id in U_Rec.First_Invocation_Construct ..
U_Rec.Last_Invocation_Construct
loop
Create_Vertex (IC_Id, Vertex);
end loop;
end Create_Vertices;
----------------------------------
-- Declaration_Placement_Vertex --
----------------------------------
function Declaration_Placement_Vertex
(Vertex : Library_Graph_Vertex_Id;
Placement : Declaration_Placement_Kind)
return Library_Graph_Vertex_Id
is
begin
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (Vertex));
if Placement = In_Body then
return Proper_Body (Lib_Graph, Vertex);
else
pragma Assert (Placement = In_Spec);
return Proper_Spec (Lib_Graph, Vertex);
end if;
end Declaration_Placement_Vertex;
end Invocation_Graph_Builders;
----------------------------
-- Library_Graph_Builders --
----------------------------
package body Library_Graph_Builders is
---------------------
-- Data structures --
---------------------
procedure Destroy_Line_Number (Line : in out Logical_Line_Number);
pragma Inline (Destroy_Line_Number);
-- Destroy line number Line
function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type;
pragma Inline (Hash_Unit);
-- Obtain the hash value of key U_Id
package Unit_Line_Tables is new Dynamic_Hash_Tables
(Key_Type => Unit_Id,
Value_Type => Logical_Line_Number,
No_Value => No_Line_Number,
Expansion_Threshold => 1.5,
Expansion_Factor => 2,
Compression_Threshold => 0.3,
Compression_Factor => 2,
"=" => "=",
Destroy_Value => Destroy_Line_Number,
Hash => Hash_Unit);
-----------------
-- Global data --
-----------------
Lib_Graph : Library_Graph := Library_Graphs.Nil;
Unit_To_Line : Unit_Line_Tables.Dynamic_Hash_Table :=
Unit_Line_Tables.Nil;
-- The map of unit name -> line number, used to detect duplicate unit
-- names in the forced-elaboration-order file and report errors.
-----------------------
-- Local subprograms --
-----------------------
procedure Add_Unit
(U_Id : Unit_Id;
Line : Logical_Line_Number);
pragma Inline (Add_Unit);
-- Create a relationship between unit U_Id and its declaration line in
-- map Unit_To_Line.
procedure Create_Forced_Edge
(Pred : Unit_Id;
Succ : Unit_Id);
pragma Inline (Create_Forced_Edge);
-- Create a new forced edge between predecessor unit Pred and successor
-- unit Succ.
procedure Create_Forced_Edges;
pragma Inline (Create_Forced_Edges);
-- Inspect the contents of the forced-elaboration-order file, and create
-- specialized edges for each valid pair of units listed within.
procedure Create_Spec_And_Body_Edge (U_Id : Unit_Id);
pragma Inline (Create_Spec_And_Body_Edge);
-- Establish a link between the spec and body of unit U_Id. In certain
-- cases this may result in a new edge which is added to library graph
-- Lib_Graph.
procedure Create_Vertex (U_Id : Unit_Id);
pragma Inline (Create_Vertex);
-- Create a new vertex for unit U_Id in library graph Lib_Graph
procedure Create_With_Edge
(W_Id : With_Id;
Succ : Library_Graph_Vertex_Id);
pragma Inline (Create_With_Edge);
-- Create a new edge for with W_Id where the predecessor is the library
-- graph vertex of the withed unit, and the successor is Succ. The edge
-- is added to library graph Lib_Graph.
procedure Create_With_Edges (U_Id : Unit_Id);
pragma Inline (Create_With_Edges);
-- Establish links between unit U_Id and its predecessor units. The new
-- edges are added to library graph Lib_Graph.
procedure Create_With_Edges
(U_Id : Unit_Id;
Succ : Library_Graph_Vertex_Id);
pragma Inline (Create_With_Edges);
-- Create new edges for all withs of unit U_Id where the predecessor is
-- some withed unit, and the successor is Succ. The edges are added to
-- library graph Lib_Graph.
procedure Duplicate_Unit_Error
(U_Id : Unit_Id;
Nam : Unit_Name_Type;
Line : Logical_Line_Number);
pragma Inline (Duplicate_Unit_Error);
-- Emit an error concerning the duplication of unit U_Id with name Nam
-- that is redeclared in the forced-elaboration-order file at line Line.
procedure Internal_Unit_Info (Nam : Unit_Name_Type);
pragma Inline (Internal_Unit_Info);
-- Emit an information message concerning the omission of an internal
-- unit with name Nam from the creation of forced edges.
function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean;
pragma Inline (Is_Duplicate_Unit);
-- Determine whether unit U_Id is already recorded in map Unit_To_Line
function Is_Significant_With (W_Id : With_Id) return Boolean;
pragma Inline (Is_Significant_With);
-- Determine whether with W_Id plays a significant role in elaboration
procedure Missing_Unit_Info (Nam : Unit_Name_Type);
pragma Inline (Missing_Unit_Info);
-- Emit an information message concerning the omission of an undefined
-- unit found in the forced-elaboration-order file.
--------------
-- Add_Unit --
--------------
procedure Add_Unit
(U_Id : Unit_Id;
Line : Logical_Line_Number)
is
begin
pragma Assert (Present (U_Id));
Unit_Line_Tables.Put (Unit_To_Line, U_Id, Line);
end Add_Unit;
-------------------------
-- Build_Library_Graph --
-------------------------
function Build_Library_Graph return Library_Graph is
begin
Start_Phase (Library_Graph_Construction);
-- Prepare the global data
Lib_Graph :=
Create
(Initial_Vertices => Number_Of_Elaborable_Units,
Initial_Edges => Number_Of_Elaborable_Units);
For_Each_Elaborable_Unit (Create_Vertex'Access);
For_Each_Elaborable_Unit (Create_Spec_And_Body_Edge'Access);
For_Each_Elaborable_Unit (Create_With_Edges'Access);
Create_Forced_Edges;
Validate_Library_Graph (Lib_Graph);
End_Phase (Library_Graph_Construction);
return Lib_Graph;
end Build_Library_Graph;
------------------------
-- Create_Forced_Edge --
------------------------
procedure Create_Forced_Edge
(Pred : Unit_Id;
Succ : Unit_Id)
is
pragma Assert (Present (Pred));
pragma Assert (Present (Succ));
Pred_Vertex : constant Library_Graph_Vertex_Id :=
Corresponding_Vertex (Lib_Graph, Pred);
Succ_Vertex : constant Library_Graph_Vertex_Id :=
Corresponding_Vertex (Lib_Graph, Succ);
begin
Write_Unit_Name (Name (Pred));
Write_Str (" <-- ");
Write_Unit_Name (Name (Succ));
Write_Eol;
Add_Edge
(G => Lib_Graph,
Pred => Pred_Vertex,
Succ => Succ_Vertex,
Kind => Forced_Edge,
Activates_Task => False);
end Create_Forced_Edge;
-------------------------
-- Create_Forced_Edges --
-------------------------
procedure Create_Forced_Edges is
Current_Unit : Unit_Id;
Iter : Forced_Units_Iterator;
Previous_Unit : Unit_Id;
Unit_Line : Logical_Line_Number;
Unit_Name : Unit_Name_Type;
begin
Previous_Unit := No_Unit_Id;
Unit_To_Line := Unit_Line_Tables.Create (20);
-- Inspect the contents of the forced-elaboration-order file supplied
-- to the binder using switch -f, and diagnose each unit accordingly.
Iter := Iterate_Forced_Units;
while Has_Next (Iter) loop
Next (Iter, Unit_Name, Unit_Line);
Current_Unit := Corresponding_Unit (Unit_Name);
if not Present (Current_Unit) then
Missing_Unit_Info (Unit_Name);
elsif Is_Internal_Unit (Current_Unit) then
Internal_Unit_Info (Unit_Name);
elsif Is_Duplicate_Unit (Current_Unit) then
Duplicate_Unit_Error (Current_Unit, Unit_Name, Unit_Line);
-- Otherwise the unit is a valid candidate for a vertex. Create a
-- forced edge between each pair of units.
else
Add_Unit (Current_Unit, Unit_Line);
if Present (Previous_Unit) then
Create_Forced_Edge
(Pred => Previous_Unit,
Succ => Current_Unit);
end if;
Previous_Unit := Current_Unit;
end if;
end loop;
Unit_Line_Tables.Destroy (Unit_To_Line);
end Create_Forced_Edges;
-------------------------------
-- Create_Spec_And_Body_Edge --
-------------------------------
procedure Create_Spec_And_Body_Edge (U_Id : Unit_Id) is
Extra_Vertex : Library_Graph_Vertex_Id;
Vertex : Library_Graph_Vertex_Id;
begin
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (U_Id));
Vertex := Corresponding_Vertex (Lib_Graph, U_Id);
-- The unit denotes a body that completes a previous spec. Link the
-- spec and body. Add an edge between the predecessor spec and the
-- successor body.
if Is_Body_With_Spec (Lib_Graph, Vertex) then
Extra_Vertex :=
Corresponding_Vertex (Lib_Graph, Corresponding_Spec (U_Id));
Set_Corresponding_Item (Lib_Graph, Vertex, Extra_Vertex);
Add_Edge
(G => Lib_Graph,
Pred => Extra_Vertex,
Succ => Vertex,
Kind => Spec_Before_Body_Edge,
Activates_Task => False);
-- The unit denotes a spec with a completing body. Link the spec and
-- body.
elsif Is_Spec_With_Body (Lib_Graph, Vertex) then
Extra_Vertex :=
Corresponding_Vertex (Lib_Graph, Corresponding_Body (U_Id));
Set_Corresponding_Item (Lib_Graph, Vertex, Extra_Vertex);
end if;
end Create_Spec_And_Body_Edge;
-------------------
-- Create_Vertex --
-------------------
procedure Create_Vertex (U_Id : Unit_Id) is
begin
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (U_Id));
Add_Vertex
(G => Lib_Graph,
U_Id => U_Id);
end Create_Vertex;
----------------------
-- Create_With_Edge --
----------------------
procedure Create_With_Edge
(W_Id : With_Id;
Succ : Library_Graph_Vertex_Id)
is
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (W_Id));
pragma Assert (Present (Succ));
Withed_Rec : With_Record renames Withs.Table (W_Id);
Withed_U_Id : constant Unit_Id :=
Corresponding_Unit (Withed_Rec.Uname);
Kind : Library_Graph_Edge_Kind;
Withed_Vertex : Library_Graph_Vertex_Id;
begin
-- Nothing to do when the withed unit does not need to be elaborated.
-- This prevents spurious dependencies that can never be satisfied.
if not Needs_Elaboration (Withed_U_Id) then
return;
end if;
Withed_Vertex := Corresponding_Vertex (Lib_Graph, Withed_U_Id);
-- The with comes with pragma Elaborate. Treat the edge as a with
-- edge when switch -d_e (ignore the effects of pragma Elaborate)
-- is in effect.
if Withed_Rec.Elaborate
and then not Debug_Flag_Underscore_E
then
Kind := Elaborate_Edge;
-- The withed unit is a spec with a completing body. Add an edge
-- between the body of the withed predecessor and the withing
-- successor.
if Is_Spec_With_Body (Lib_Graph, Withed_Vertex) then
Add_Edge
(G => Lib_Graph,
Pred =>
Corresponding_Vertex
(Lib_Graph, Corresponding_Body (Withed_U_Id)),
Succ => Succ,
Kind => Kind,
Activates_Task => False);
end if;
-- The with comes with pragma Elaborate_All. Treat the edge as a with
-- edge when switch -d_a (ignore the effects of pragma Elaborate_All)
-- is in effect.
elsif Withed_Rec.Elaborate_All
and then not Debug_Flag_Underscore_A
then
Kind := Elaborate_All_Edge;
-- Otherwise this is a regular with
else
Kind := With_Edge;
end if;
-- Add an edge between the withed predecessor unit and the withing
-- successor.
Add_Edge
(G => Lib_Graph,
Pred => Withed_Vertex,
Succ => Succ,
Kind => Kind,
Activates_Task => False);
end Create_With_Edge;
-----------------------
-- Create_With_Edges --
-----------------------
procedure Create_With_Edges (U_Id : Unit_Id) is
begin
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (U_Id));
Create_With_Edges
(U_Id => U_Id,
Succ => Corresponding_Vertex (Lib_Graph, U_Id));
end Create_With_Edges;
-----------------------
-- Create_With_Edges --
-----------------------
procedure Create_With_Edges
(U_Id : Unit_Id;
Succ : Library_Graph_Vertex_Id)
is
pragma Assert (Present (Lib_Graph));
pragma Assert (Present (U_Id));
pragma Assert (Present (Succ));
U_Rec : Unit_Record renames ALI.Units.Table (U_Id);
begin
for W_Id in U_Rec.First_With .. U_Rec.Last_With loop
if Is_Significant_With (W_Id) then
Create_With_Edge (W_Id, Succ);
end if;
end loop;
end Create_With_Edges;
------------------
-- Destroy_Unit --
------------------
procedure Destroy_Line_Number (Line : in out Logical_Line_Number) is
pragma Unreferenced (Line);
begin
null;
end Destroy_Line_Number;
--------------------------
-- Duplicate_Unit_Error --
--------------------------
procedure Duplicate_Unit_Error
(U_Id : Unit_Id;
Nam : Unit_Name_Type;
Line : Logical_Line_Number)
is
pragma Assert (Present (U_Id));
pragma Assert (Present (Nam));
Prev_Line : constant Logical_Line_Number :=
Unit_Line_Tables.Get (Unit_To_Line, U_Id);
begin
Error_Msg_Nat_1 := Nat (Line);
Error_Msg_Nat_2 := Nat (Prev_Line);
Error_Msg_Unit_1 := Nam;
Error_Msg
(Force_Elab_Order_File.all
& ":#: duplicate unit name $ from line #");
end Duplicate_Unit_Error;
---------------
-- Hash_Unit --
---------------
function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type is
begin
pragma Assert (Present (U_Id));
return Bucket_Range_Type (U_Id);
end Hash_Unit;
------------------------
-- Internal_Unit_Info --
------------------------
procedure Internal_Unit_Info (Nam : Unit_Name_Type) is
begin
pragma Assert (Present (Nam));
Write_Line
("""" & Get_Name_String (Nam) & """: predefined unit ignored");
end Internal_Unit_Info;
-----------------------
-- Is_Duplicate_Unit --
-----------------------
function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean is
begin
pragma Assert (Present (U_Id));
return Unit_Line_Tables.Contains (Unit_To_Line, U_Id);
end Is_Duplicate_Unit;
-------------------------
-- Is_Significant_With --
-------------------------
function Is_Significant_With (W_Id : With_Id) return Boolean is
pragma Assert (Present (W_Id));
Withed_Rec : With_Record renames Withs.Table (W_Id);
Withed_U_Id : constant Unit_Id :=
Corresponding_Unit (Withed_Rec.Uname);
begin
-- Nothing to do for a unit which does not exist any more
if not Present (Withed_U_Id) then
return False;
-- Nothing to do for a limited with
elsif Withed_Rec.Limited_With then
return False;
-- Nothing to do when the unit does not need to be elaborated
elsif not Needs_Elaboration (Withed_U_Id) then
return False;
end if;
return True;
end Is_Significant_With;
-----------------------
-- Missing_Unit_Info --
-----------------------
procedure Missing_Unit_Info (Nam : Unit_Name_Type) is
begin
pragma Assert (Present (Nam));
Write_Line
("""" & Get_Name_String (Nam) & """: not present; ignored");
end Missing_Unit_Info;
end Library_Graph_Builders;
end Bindo.Builders;