summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2017-01-13 11:54:43 +0100
committerArnaud Charlet <charlet@gcc.gnu.org>2017-01-13 11:54:43 +0100
commit354ae44943ca7642d2f3a48ca428bfb5df2e0049 (patch)
treef029b95ac27175fee7062ad81282fdb79d0f388a
parent448a1eb3eb4357dcdd1e2271e267bedb0c4b7d6c (diff)
downloadgcc-354ae44943ca7642d2f3a48ca428bfb5df2e0049.tar.gz
[multiple changes]
2017-01-13 Javier Miranda <miranda@adacore.com> * einfo.ads (Component_Bit_Offset): Fix documentation. * sem_ch13.adb (Check_Record_Representation_Clause): Skip check on record holes for components with unknown compile-time offsets. 2017-01-13 Bob Duff <duff@adacore.com> * ali.ads, ali.adb (Static_Elaboration_Model_Used): Remove unused flag. * g-locfil.ads: Minor comment fix. 2017-01-13 Bob Duff <duff@adacore.com> * binde.adb (Elab_New): New elaboration order algorithm that is expected to cause fewer ABE issues. This is a work in progress. The new algorithm is currently disabled, and can be enable by the -dp switch, or by modifying the Do_Old and Do_New etc. flags and rebuilding. Experimental code is included to compare the results of the old and new algorithms. * binde.ads: Use GNAT.Dynamic_Tables instead of Table, so we can have multiple of these tables, so the old and new algorithms can coexist. * bindgen.ads (Gen_Output_File): Pass Elab_Order as an 'in' parameter of type array. This avoids the global variable, and allows bounds checking (which is normally defeated by the tables packages). It also ensures that the Elab_Order is read-only to Bindgen. * bindgen.adb: Pass Elab_Order as an 'in' parameter to all subprograms that need it, as above. * debug.adb: Document new -dp switch. Modify doc of old -do switch. * gnatbind.adb (Gnatbind): Make use of new interfaces to Binde and Bindgen. Move writing of closure (-R and -Ra switches) to Binde; that's more convenient. 2017-01-13 Ed Schonberg <schonberg@adacore.com> * sem_ch6.adb (Analyze_Expression_Function): If the expression function is a completion, all entities referenced in the expression are frozen. As a consequence, a reference to an uncompleted private type from an enclosing scope is illegal. From-SVN: r244419
Diffstat
-rw-r--r--gcc/ada/ChangeLog42
-rw-r--r--gcc/ada/ali.adb9
-rw-r--r--gcc/ada/ali.ads7
-rw-r--r--gcc/ada/binde.adb2145
-rw-r--r--gcc/ada/binde.ads40
-rw-r--r--gcc/ada/bindgen.adb273
-rw-r--r--gcc/ada/bindgen.ads8
-rw-r--r--gcc/ada/debug.adb19
-rw-r--r--gcc/ada/einfo.ads15
-rw-r--r--gcc/ada/g-locfil.ads4
-rw-r--r--gcc/ada/gnatbind.adb186
-rw-r--r--gcc/ada/sem_ch13.adb25
-rw-r--r--gcc/ada/sem_ch6.adb25
13 files changed, 2014 insertions, 784 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5d5be94bc32..fba33935f16 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,47 @@
2017-01-13 Javier Miranda <miranda@adacore.com>
+ * einfo.ads (Component_Bit_Offset): Fix documentation.
+ * sem_ch13.adb (Check_Record_Representation_Clause): Skip check
+ on record holes for components with unknown compile-time offsets.
+
+2017-01-13 Bob Duff <duff@adacore.com>
+
+ * ali.ads, ali.adb (Static_Elaboration_Model_Used): Remove unused flag.
+ * g-locfil.ads: Minor comment fix.
+
+2017-01-13 Bob Duff <duff@adacore.com>
+
+ * binde.adb (Elab_New): New elaboration order algorithm
+ that is expected to cause fewer ABE issues. This is a work in
+ progress. The new algorithm is currently disabled, and can be
+ enable by the -dp switch, or by modifying the Do_Old and Do_New
+ etc. flags and rebuilding. Experimental code is included to
+ compare the results of the old and new algorithms.
+ * binde.ads: Use GNAT.Dynamic_Tables instead of Table, so we
+ can have multiple of these tables, so the old and new algorithms
+ can coexist.
+ * bindgen.ads (Gen_Output_File): Pass Elab_Order as an 'in'
+ parameter of type array. This avoids the global variable, and
+ allows bounds checking (which is normally defeated by the tables
+ packages). It also ensures that the Elab_Order is read-only
+ to Bindgen.
+ * bindgen.adb: Pass Elab_Order as an 'in' parameter to all
+ subprograms that need it, as above.
+ * debug.adb: Document new -dp switch. Modify doc of old -do
+ switch.
+ * gnatbind.adb (Gnatbind): Make use of new interfaces to Binde
+ and Bindgen. Move writing of closure (-R and -Ra switches)
+ to Binde; that's more convenient.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): If the expression
+ function is a completion, all entities referenced in the
+ expression are frozen. As a consequence, a reference to an
+ uncompleted private type from an enclosing scope is illegal.
+
+2017-01-13 Javier Miranda <miranda@adacore.com>
+
* sem_ch6.adb (Freeze_Expr_Types): New subprogram.
(Analyze_Subprogram_Body_Helper): At the occurrence of an
expression function declaration that is a completion, its
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index d60d4980d0c..d42cb34431a 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -116,7 +116,6 @@ package body ALI is
Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' ';
SSO_Default_Specified := False;
- Static_Elaboration_Model_Used := False;
Task_Dispatching_Policy_Specified := ' ';
Unreserve_All_Interrupts_Specified := False;
Frontend_Exceptions_Specified := False;
@@ -1996,14 +1995,6 @@ package body ALI is
Skip_Eol;
- -- Check if static elaboration model used
-
- if not Units.Table (Units.Last).Dynamic_Elab
- and then not Units.Table (Units.Last).Internal
- then
- Static_Elaboration_Model_Used := True;
- end if;
-
C := Getc;
-- Scan out With lines for this unit
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index eea6b461133..c51129df0db 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
@@ -523,11 +523,6 @@ package ALI is
-- Set to True if at least one ALI file contains '-fstack-check' in its
-- argument list.
- Static_Elaboration_Model_Used : Boolean := False;
- -- Set to False by Initialize_ALI. Set to True if any ALI file for a
- -- non-internal unit compiled with the static elaboration model is
- -- encountered.
-
Task_Dispatching_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate task dispatching
-- policy character if an ali file contains a P line setting the
diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb
index ffb3b914a2a..ea341272b56 100644
--- a/gcc/ada/binde.adb
+++ b/gcc/ada/binde.adb
@@ -27,22 +27,71 @@ with Binderr; use Binderr;
with Butil; use Butil;
with Debug; use Debug;
with Fname; use Fname;
-with Namet; use Namet;
with Opt; use Opt;
with Osint;
with Output; use Output;
+with Table;
with System.Case_Util; use System.Case_Util;
with System.OS_Lib;
package body Binde is
+ -- We now have Elab_New, a new elaboration-order algorithm. It has the
+ -- property that ???
+ --
+ -- However, any change to elaboration order can break some programs.
+ -- Therefore, we are keeping the old algorithm in place, to be selected
+ -- by switches.
+ --
+ -- The new algorithm has the following interesting properties:
+ --
+ -- * The static and dynamic models use the same elaboration order. The
+ -- static model might get an error, but if it does not, it will use
+ -- the same order as the dynamic model.
+ --
+ -- * Each SCC (see below) is elaborated together; that is, units from
+ -- different SCCs are not interspersed.
+ --
+ -- * In particular, this implies that if an SCC contains just a spec and
+ -- the corresponding body, and nothing else, the body will be
+ -- elaborated immediately after the spec. This is expected to result
+ -- in a better elaboration order for most programs, because in this
+ -- case, a call from outside the library unit cannot get ABE.
+ --
+ -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
+ -- we behave as if every legal pragma Elaborate_All were present. That
+ -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
+ -- then we behave as if such a pragma exists, even if it does not.
+
+ Do_Old : constant Boolean := False;
+ Do_New : constant Boolean := True;
+ -- True to enable the old and new algorithms, respectively. Used for
+ -- debugging/experimentation.
+
+ Doing_New : Boolean := False;
+ -- True if we are currently doing the new algorithm. Print certain
+ -- messages only when doing the "new" elab order algorithm, so we don't get
+ -- duplicates. And use different heuristics in Better_Choice_Optimistic.
+
-- The following data structures are used to represent the graph that is
-- used to determine the elaboration order (using a topological sort).
- -- The following structures are used to record successors. If A is a
- -- successor of B in this table, it means that A must be elaborated
- -- before B is elaborated.
+ -- The following structures are used to record successors. If B is a
+ -- successor of A in this table, it means that A must be elaborated before
+ -- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
+ -- will be a successor of X (spec), and X (spec) will be a predecessor of
+ -- Y (body).
+ --
+ -- Note that we store the successors of each unit explictly. We don't store
+ -- the predecessors, but we store a count of them.
+ --
+ -- The basic algorithm is to first compute a directed graph of units (type
+ -- Unit_Node_Record, below), with successors as edges. A unit is "ready"
+ -- (to be chosen as the next to be elaborated) if it has no predecessors
+ -- that have not yet been chosen. We use heuristics to decide which of the
+ -- ready units should be elaborated next, and "choose" that one (which
+ -- means we append it to the elaboration-order table).
type Successor_Id is new Nat;
-- Identification of single successor entry
@@ -68,24 +117,24 @@ package body Binde is
-- order file.
Elab,
- -- After directly mentions Before in a pragma Elaborate, so the
- -- body of Before must be elaborated before After is elaborated.
+ -- After directly mentions Before in a pragma Elaborate, so the body of
+ -- Before must be elaborated before After is elaborated.
Elab_All,
- -- After either mentions Before directly in a pragma Elaborate_All,
- -- or mentions a third unit, X, which itself requires that Before be
- -- elaborated before unit X is elaborated. The Elab_All_Link list
- -- traces the dependencies in the latter case.
+ -- After either mentions Before directly in a pragma Elaborate_All, or
+ -- mentions a third unit, X, which itself requires that Before be
+ -- elaborated before unit X is elaborated. The Elab_All_Link list traces
+ -- the dependencies in the latter case.
Elab_All_Desirable,
-- This is just like Elab_All, except that the Elaborate_All was not
- -- explicitly present in the source, but rather was created by the
- -- front end, which decided that it was "desirable".
+ -- explicitly present in the source, but rather was created by the front
+ -- end, which decided that it was "desirable".
Elab_Desirable,
- -- This is just like Elab, except that the Elaborate was not
- -- explicitly present in the source, but rather was created by the
- -- front end, which decided that it was "desirable".
+ -- This is just like Elab, except that the Elaborate was not explicitly
+ -- present in the source, but rather was created by the front end, which
+ -- decided that it was "desirable".
Spec_First);
-- After is a body, and Before is the corresponding spec
@@ -115,9 +164,8 @@ package body Binde is
Elab_All_Link : Elab_All_Id;
-- If Reason = Elab_All or Elab_Desirable, then this points to the
- -- first elment in a list of Elab_All entries that record the with
+ -- first element in a list of Elab_All entries that record the with
-- chain resulting in this particular dependency.
-
end record;
-- Note on handling of Elaborate_Body. Basically, if we have a pragma
@@ -132,17 +180,17 @@ package body Binde is
Succ_First : constant := 1;
- package Succ is new Table.Table (
- Table_Component_Type => Successor_Link,
- Table_Index_Type => Successor_Id,
- Table_Low_Bound => Succ_First,
- Table_Initial => 500,
- Table_Increment => 200,
- Table_Name => "Succ");
+ package Succ is new Table.Table
+ (Table_Component_Type => Successor_Link,
+ Table_Index_Type => Successor_Id,
+ Table_Low_Bound => Succ_First,
+ Table_Initial => 500,
+ Table_Increment => 200,
+ Table_Name => "Succ");
-- For the case of Elaborate_All, the following table is used to record
- -- chains of with relationships that lead to the Elab_All link. These
- -- are used solely for diagnostic purposes
+ -- chains of with relationships that lead to the Elab_All link. These are
+ -- used solely for diagnostic purposes
type Elab_All_Entry is record
Needed_By : Unit_Name_Type;
@@ -153,50 +201,74 @@ package body Binde is
-- Link to next entry on chain (No_Elab_All_Link marks end of list)
end record;
- package Elab_All_Entries is new Table.Table (
- Table_Component_Type => Elab_All_Entry,
- Table_Index_Type => Elab_All_Id,
- Table_Low_Bound => 1,
- Table_Initial => 2000,
- Table_Increment => 200,
- Table_Name => "Elab_All_Entries");
+ package Elab_All_Entries is new Table.Table
+ (Table_Component_Type => Elab_All_Entry,
+ Table_Index_Type => Elab_All_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 2000,
+ Table_Increment => 200,
+ Table_Name => "Elab_All_Entries");
- -- A Unit_Node record is built for each active unit
+ type Unit_Id_Array_Ptr is access Unit_Id_Array;
- type Unit_Node_Record is record
+ -- A Unit_Node_Record is built for each active unit
+ type Unit_Node_Record is record
Successors : Successor_Id;
-- Pointer to list of links for successor nodes
Num_Pred : Int;
- -- Number of predecessors for this unit. Normally non-negative, but
- -- can go negative in the case of units chosen by the diagnose error
- -- procedure (when cycles are being removed from the graph).
+ -- Number of predecessors for this unit that have not yet been chosen.
+ -- Normally non-negative, but can go negative in the case of units
+ -- chosen by the diagnose error procedure (when cycles are being removed
+ -- from the graph).
Nextnp : Unit_Id;
-- Forward pointer for list of units with no predecessors
- Elab_Order : Nat;
- -- Position in elaboration order (zero = not placed yet)
-
Visited : Boolean;
- -- Used in computing transitive closure for Elaborate_All and
- -- also in locating cycles and paths in the diagnose routines.
+ -- Used in computing transitive closure for Elaborate_All and also in
+ -- locating cycles and paths in the diagnose routines.
Elab_Position : Natural;
- -- Initialized to zero. Set non-zero when a unit is chosen and
- -- placed in the elaboration order. The value represents the
- -- ordinal position in the elaboration order.
-
+ -- Initialized to zero. Set non-zero when a unit is chosen and placed in
+ -- the elaboration order. The value represents the ordinal position in
+ -- the elaboration order.
+
+ -- The following are for Elab_New. We compute the strongly connected
+ -- components (SCCs) of the directed graph of units. The edges are the
+ -- Successors, which do not include pragmas Elaborate_All (explicit or
+ -- implicit) in Elab_New. In addition, we assume there is a edge
+ -- pointing from a body to its corresponding spec; this edge is not
+ -- included in Successors, because of course a spec is elaborated BEFORE
+ -- its body, not after.
+
+ SCC_Root : Unit_Id;
+ -- Each unit points to the root of its SCC, which is just an arbitrary
+ -- member of the SCC. Two units are in the same SCC if and only if their
+ -- SCC_Roots are equal. U is the root of its SCC if and only if
+ -- SCC(U)=U.
+
+ Nodes : Unit_Id_Array_Ptr;
+ -- Present only in the root of an SCC. This is the set of units in the
+ -- SCC, in no particular order.
+
+ SCC_Num_Pred : Int;
+ -- Present only in the root of an SCC. This is the number of predecessor
+ -- units of the SCC that are in other SCCs, and that have not yet been
+ -- chosen.
+
+ Validate_Seen : Boolean := False;
+ -- See procedure Validate below
end record;
- package UNR is new Table.Table (
- Table_Component_Type => Unit_Node_Record,
- Table_Index_Type => Unit_Id,
- Table_Low_Bound => First_Unit_Entry,
- Table_Initial => 500,
- Table_Increment => 200,
- Table_Name => "UNR");
+ package UNR is new Table.Table
+ (Table_Component_Type => Unit_Node_Record,
+ Table_Index_Type => Unit_Id,
+ Table_Low_Bound => First_Unit_Entry,
+ Table_Initial => 500,
+ Table_Increment => 200,
+ Table_Name => "UNR");
No_Pred : Unit_Id;
-- Head of list of items with no predecessors
@@ -205,17 +277,26 @@ package body Binde is
-- Number of entries not yet dealt with
Cur_Unit : Unit_Id;
- -- Current unit, set by Gather_Dependencies, and picked up in Build_Link
- -- to set the Reason_Unit field of the created dependency link.
+ -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
+ -- set the Reason_Unit field of the created dependency link.
- Num_Chosen : Natural := 0;
+ Num_Chosen : Natural;
-- Number of units chosen in the elaboration order so far
-----------------------
-- Local Subprograms --
-----------------------
- function Better_Choice (U1, U2 : Unit_Id) return Boolean;
+ function Debug_Flag_Older return Boolean;
+ function Debug_Flag_Old return Boolean;
+ -- True if debug flags select the old or older algorithms
+
+ procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean);
+ -- Assert that certain properties are true
+
+ function Better_Choice_Optimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean;
-- U1 and U2 are both permitted candidates for selection as the next unit
-- to be elaborated. This function determines whether U1 is a better choice
-- than U2, i.e. should be elaborated in preference to U2, based on a set
@@ -223,6 +304,18 @@ package body Binde is
-- for details). The result is True if U1 is a better choice than U2, and
-- False if it is a worse choice, or there is no preference between them.
+ function Better_Choice_Pessimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean;
+ -- This is like Better_Choice_Optimistic, and has the same interface, but
+ -- returns true if U1 is a worse choice than U2 in the sense of the -p
+ -- (pessimistic elaboration order) switch. We still have to obey Ada rules,
+ -- so it is not quite the direct inverse of Better_Choice_Optimistic.
+
+ function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean;
+ -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
+ -- appropriate. Also takes care of the U2 = No_Unit_Id case.
+
procedure Build_Link
(Before : Unit_Id;
After : Unit_Id;
@@ -232,7 +325,7 @@ package body Binde is
-- the reason for the link is R. Ea_Id is the contents to be placed in the
-- Elab_All_Link of the entry.
- procedure Choose (Chosen : Unit_Id);
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id);
-- Chosen is the next entry chosen in the elaboration order. This procedure
-- updates all data structures appropriately.
@@ -248,7 +341,8 @@ package body Binde is
-- the unit id of the spec. It is an error to call this routine with a unit
-- that is not a body, or that does not have a separate spec.
- procedure Diagnose_Elaboration_Problem;
+ procedure Diagnose_Elaboration_Problem
+ (Elab_Order : in out Unit_Id_Table);
-- Called when no elaboration order can be found. Outputs an appropriate
-- diagnosis of the problem, and then abandons the bind.
@@ -279,6 +373,9 @@ package body Binde is
procedure Gather_Dependencies;
-- Compute dependencies, building the Succ and UNR tables
+ procedure Init;
+ -- Initialize global data structures in this package body
+
function Is_Body_Unit (U : Unit_Id) return Boolean;
pragma Inline (Is_Body_Unit);
-- Determines if given unit is a body
@@ -297,16 +394,14 @@ package body Binde is
Link : Elab_All_Id) return Elab_All_Id;
-- Make an Elab_All_Entries table entry with the given Unam and Link
- function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean;
- -- This is like Better_Choice, and has the same interface, but returns
- -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic
- -- elaboration order) switch. We still have to obey Ada rules, so it is
- -- not quite the direct inverse of Better_Choice.
-
function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
-- This function uses the Info field set in the names table to obtain
-- the unit Id of a unit, given its name id value.
+ procedure Write_Closure (Order : Unit_Id_Array);
+ -- Write the closure. This is for the -R and -Ra switches, "list closure
+ -- display".
+
procedure Write_Dependencies;
-- Write out dependencies (called only if appropriate option is set)
@@ -314,17 +409,79 @@ package body Binde is
-- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
-- then this routine will output the "needed by" explanation chain.
+ procedure Write_Elab_Order (Order : Unit_Id_Array; Title : String);
+ -- Display elaboration order. This is for the -l switch. Title is a heading
+ -- to print; an empty string is passed to indicate Zero_Formatting.
+
+ package Elab_New is
+
+ -- Implementation of the new algorithm
+
+ procedure Write_SCC (U : Unit_Id);
+ -- Write the unit names of the units in the SCC in which U lives
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
+
+ Illegal_Elab_All : Boolean := False;
+ -- Set true if Find_Elab_Order found an illegal pragma Elaborate_All
+ -- (explicit or implicit).
+
+ function SCC (U : Unit_Id) return Unit_Id;
+ -- The root of the strongly connected component containing U
+
+ function SCC_Num_Pred (U : Unit_Id) return Int;
+ -- The SCC_Num_Pred of the SCC in which U lives
+
+ function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr;
+ -- The nodes of the strongly connected component containing U
+
+ end Elab_New;
+
+ use Elab_New;
+
+ package Elab_Old is
+
+ -- Implementation of the old algorithm
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
+
+ end Elab_Old;
+
+ -- Most of the code is shared between old and new; such code is outside
+ -- packages Elab_Old and Elab_New.
+
-------------------
-- Better_Choice --
-------------------
- function Better_Choice (U1, U2 : Unit_Id) return Boolean is
+ function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean is
+ pragma Assert (U1 /= No_Unit_Id);
+ begin
+ if U2 = No_Unit_Id then
+ return True;
+ end if;
+
+ if Pessimistic_Elab_Order then
+ return Better_Choice_Pessimistic (U1, U2);
+ else
+ return Better_Choice_Optimistic (U1, U2);
+ end if;
+ end Better_Choice;
+
+ ------------------------------
+ -- Better_Choice_Optimistic --
+ ------------------------------
+
+ function Better_Choice_Optimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean
+ is
UT1 : Unit_Record renames Units.Table (U1);
UT2 : Unit_Record renames Units.Table (U2);
begin
if Debug_Flag_B then
- Write_Str ("Better_Choice (");
+ Write_Str ("Better_Choice_Optimistic (");
Write_Unit_Name (UT1.Uname);
Write_Str (", ");
Write_Unit_Name (UT2.Uname);
@@ -381,7 +538,8 @@ package body Binde is
return False;
- -- Prefer a pure or preelaborable unit to one that is not
+ -- Prefer a pure or preelaborated unit to one that is not Pure should
+ -- come before preelaborated.
elsif Is_Pure_Or_Preelab_Unit (U1)
and then not
@@ -419,23 +577,23 @@ package body Binde is
return False;
- -- If both are waiting bodies, then prefer the one whose spec is
- -- more recently elaborated. Consider the following:
+ -- If both are waiting bodies, then prefer the one whose spec is more
+ -- recently elaborated. Consider the following:
-- spec of A
-- spec of B
-- body of A or B?
- -- The normal waiting body preference would have placed the body of
- -- A before the spec of B if it could. Since it could not, then it
- -- must be the case that A depends on B. It is therefore a good idea
- -- to put the body of B first.
+ -- The normal waiting body preference would have placed the body of A
+ -- before the spec of B if it could. Since it could not, then it must be
+ -- the case that A depends on B. It is therefore a good idea to put the
+ -- body of B first.
elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
declare
Result : constant Boolean :=
- UNR.Table (Corresponding_Spec (U1)).Elab_Position >
- UNR.Table (Corresponding_Spec (U2)).Elab_Position;
+ UNR.Table (Corresponding_Spec (U1)).Elab_Position >
+ UNR.Table (Corresponding_Spec (U2)).Elab_Position;
begin
if Debug_Flag_B then
if Result then
@@ -451,7 +609,7 @@ package body Binde is
-- Remaining choice rules are disabled by Debug flag -do
- if not Debug_Flag_O then
+ if not Debug_Flag_Older then
-- The following deal with the case of specs that have been marked
-- as Elaborate_Body_Desirable. We generally want to delay these
@@ -490,8 +648,8 @@ package body Binde is
then
declare
Result : constant Boolean :=
- UNR.Table (Corresponding_Body (U1)).Num_Pred <
- UNR.Table (Corresponding_Body (U2)).Num_Pred;
+ UNR.Table (Corresponding_Body (U1)).Num_Pred <
+ UNR.Table (Corresponding_Body (U2)).Num_Pred;
begin
if Debug_Flag_B then
if Result then
@@ -506,6 +664,41 @@ package body Binde is
end if;
end if;
+ -- If we have two specs in the same SCC, choose the one whose body is
+ -- closer to being ready.
+
+ if Doing_New
+ and then SCC (U1) = SCC (U2)
+ and then Units.Table (U1).Utype = Is_Spec
+ and then Units.Table (U2).Utype = Is_Spec
+ and then UNR.Table (Corresponding_Body (U1)).Num_Pred /=
+ UNR.Table (Corresponding_Body (U2)).Num_Pred
+ then
+ if UNR.Table (Corresponding_Body (U1)).Num_Pred <
+ UNR.Table (Corresponding_Body (U2)).Num_Pred
+ then
+ if Debug_Flag_B then
+ Write_Str (" True: same SCC; ");
+ Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
+ Write_Str (" < ");
+ Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
+ Write_Eol;
+ end if;
+
+ return True;
+ else
+ if Debug_Flag_B then
+ Write_Str (" False: same SCC; ");
+ Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
+ Write_Str (" > ");
+ Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
+ Write_Eol;
+ end if;
+
+ return False;
+ end if;
+ end if;
+
-- If we fall through, it means that no preference rule applies, so we
-- use alphabetical order to at least give a deterministic result.
@@ -514,7 +707,226 @@ package body Binde is
end if;
return Uname_Less (UT1.Uname, UT2.Uname);
- end Better_Choice;
+ end Better_Choice_Optimistic;
+
+ -------------------------------
+ -- Better_Choice_Pessimistic --
+ -------------------------------
+
+ function Better_Choice_Pessimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean
+ is
+ UT1 : Unit_Record renames Units.Table (U1);
+ UT2 : Unit_Record renames Units.Table (U2);
+
+ begin
+ if Debug_Flag_B then
+ Write_Str ("Better_Choice_Pessimistic (");
+ Write_Unit_Name (UT1.Uname);
+ Write_Str (", ");
+ Write_Unit_Name (UT2.Uname);
+ Write_Line (")");
+ end if;
+
+ -- Note: the checks here are applied in sequence, and the ordering is
+ -- significant (i.e. the more important criteria are applied first).
+
+ -- If either unit is predefined or internal, then we use the normal
+ -- Better_Choice_Optimistic rule, since we don't want to disturb the
+ -- elaboration rules of the language with -p, same treatment for
+ -- Pure/Preelab.
+
+ -- Prefer a predefined unit to a non-predefined unit
+
+ if UT1.Predefined and then not UT2.Predefined then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is predefined, u2 is not");
+ end if;
+
+ return True;
+
+ elsif UT2.Predefined and then not UT1.Predefined then
+ if Debug_Flag_B then
+ Write_Line (" False: u2 is predefined, u1 is not");
+ end if;
+
+ return False;
+
+ -- Prefer an internal unit to a non-internal unit
+
+ elsif UT1.Internal and then not UT2.Internal then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is internal, u2 is not");
+ end if;
+
+ return True;
+
+ elsif UT2.Internal and then not UT1.Internal then
+ if Debug_Flag_B then
+ Write_Line (" False: u2 is internal, u1 is not");
+ end if;
+
+ return False;
+
+ -- Prefer a pure or preelaborated unit to one that is not
+
+ elsif Is_Pure_Or_Preelab_Unit (U1)
+ and then not
+ Is_Pure_Or_Preelab_Unit (U2)
+ then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is pure/preelab, u2 is not");
+ end if;
+
+ return True;
+
+ elsif Is_Pure_Or_Preelab_Unit (U2)
+ and then not
+ Is_Pure_Or_Preelab_Unit (U1)
+ then
+ if Debug_Flag_B then
+ Write_Line (" False: u2 is pure/preelab, u1 is not");
+ end if;
+
+ return False;
+
+ -- Prefer anything else to a waiting body. We want to make bodies wait
+ -- as long as possible, till we are forced to choose them.
+
+ elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
+ if Debug_Flag_B then
+ Write_Line (" False: u1 is waiting body, u2 is not");
+ end if;
+
+ return False;
+
+ elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
+ if Debug_Flag_B then
+ Write_Line (" True: u2 is waiting body, u1 is not");
+ end if;
+
+ return True;
+
+ -- Prefer a spec to a body (this is mandatory)
+
+ elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
+ if Debug_Flag_B then
+ Write_Line (" False: u1 is body, u2 is not");
+ end if;
+
+ return False;
+
+ elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
+ if Debug_Flag_B then
+ Write_Line (" True: u2 is body, u1 is not");
+ end if;
+
+ return True;
+
+ -- If both are waiting bodies, then prefer the one whose spec is less
+ -- recently elaborated. Consider the following:
+
+ -- spec of A
+ -- spec of B
+ -- body of A or B?
+
+ -- The normal waiting body preference would have placed the body of A
+ -- before the spec of B if it could. Since it could not, then it must be
+ -- the case that A depends on B. It is therefore a good idea to put the
+ -- body of B last so that if there is an elaboration order problem, we
+ -- will find it (that's what pessimistic order is about).
+
+ elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
+ declare
+ Result : constant Boolean :=
+ UNR.Table (Corresponding_Spec (U1)).Elab_Position <
+ UNR.Table (Corresponding_Spec (U2)).Elab_Position;
+ begin
+ if Debug_Flag_B then
+ if Result then
+ Write_Line (" True: based on waiting body elab positions");
+ else
+ Write_Line (" False: based on waiting body elab positions");
+ end if;
+ end if;
+
+ return Result;
+ end;
+ end if;
+
+ -- Remaining choice rules are disabled by Debug flag -do
+
+ if not Debug_Flag_Older then
+
+ -- The following deal with the case of specs that have been marked as
+ -- Elaborate_Body_Desirable. In the normal case, we generally want to
+ -- delay the elaboration of these specs as long as possible, so that
+ -- bodies have better chance of being elaborated closer to the specs.
+ -- Better_Choice_Pessimistic as usual wants to do the opposite and
+ -- elaborate such specs as early as possible.
+
+ -- If we have two units, one of which is a spec for which this flag
+ -- is set, and the other is not, we normally prefer to delay the spec
+ -- for which the flag is set, so again Better_Choice_Pessimistic does
+ -- the opposite.
+
+ if not UT1.Elaborate_Body_Desirable
+ and then UT2.Elaborate_Body_Desirable
+ then
+ if Debug_Flag_B then
+ Write_Line (" False: u1 is elab body desirable, u2 is not");
+ end if;
+
+ return False;
+
+ elsif not UT2.Elaborate_Body_Desirable
+ and then UT1.Elaborate_Body_Desirable
+ then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is elab body desirable, u2 is not");
+ end if;
+
+ return True;
+
+ -- If we have two specs that are both marked as Elaborate_Body
+ -- desirable, we normally prefer the one whose body is nearer to
+ -- being able to be elaborated, based on the Num_Pred count. This
+ -- helps to ensure bodies are as close to specs as possible. As
+ -- usual, Better_Choice_Pessimistic does the opposite.
+
+ elsif UT1.Elaborate_Body_Desirable
+ and then UT2.Elaborate_Body_Desirable
+ then
+ declare
+ Result : constant Boolean :=
+ UNR.Table (Corresponding_Body (U1)).Num_Pred >=
+ UNR.Table (Corresponding_Body (U2)).Num_Pred;
+ begin
+ if Debug_Flag_B then
+ if Result then
+ Write_Line (" True based on Num_Pred compare");
+ else
+ Write_Line (" False based on Num_Pred compare");
+ end if;
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end if;
+
+ -- If we fall through, it means that no preference rule applies, so we
+ -- use alphabetical order to at least give a deterministic result. Since
+ -- Better_Choice_Pessimistic is in the business of stirring up the
+ -- order, we will use reverse alphabetical ordering.
+
+ if Debug_Flag_B then
+ Write_Line (" choose on reverse alpha order");
+ end if;
+
+ return Uname_Less (UT2.Uname, UT1.Uname);
+ end Better_Choice_Pessimistic;
----------------
-- Build_Link --
@@ -559,16 +971,17 @@ package body Binde is
-- Fall through on normal case
- Succ.Table (Succ.Last).After := After;
- Succ.Table (Succ.Last).Elab_Body := False;
- UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1;
+ Succ.Table (Succ.Last).After := After;
+ Succ.Table (Succ.Last).Elab_Body := False;
+ UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1;
end Build_Link;
------------
-- Choose --
------------
- procedure Choose (Chosen : Unit_Id) is
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id) is
+ pragma Assert (Chosen /= No_Unit_Id);
S : Successor_Id;
U : Unit_Id;
@@ -579,17 +992,27 @@ package body Binde is
Write_Eol;
end if;
- -- Add to elaboration order. Note that units having no elaboration
- -- code are not treated specially yet. The special casing of this
- -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
- -- we need them here, because the object file list is also driven
- -- by the contents of the Elab_Order table.
+ -- We shouldn't be choosing something with unelaborated predecessors,
+ -- and we shouldn't call this twice on the same unit. But that's not
+ -- true when this is called from Diagnose_Elaboration_Problem.
+
+ if Errors_Detected = 0 then
+ pragma Assert (UNR.Table (Chosen).Num_Pred = 0);
+ pragma Assert (UNR.Table (Chosen).Elab_Position = 0);
+ pragma Assert (not Doing_New or else SCC_Num_Pred (Chosen) = 0);
+ null;
+ end if;
+
+ -- Add to elaboration order. Note that units having no elaboration code
+ -- are not treated specially yet. The special casing of this is in
+ -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
+ -- here, because the object file list is also driven by the contents of
+ -- the Elab_Order table.
- Elab_Order.Increment_Last;
- Elab_Order.Table (Elab_Order.Last) := Chosen;
+ Append (Elab_Order, Chosen);
- -- Remove from No_Pred list. This is a little inefficient and may
- -- be we should doubly link the list, but it will do for now.
+ -- Remove from No_Pred list. This is a little inefficient and may be we
+ -- should doubly link the list, but it will do for now.
if No_Pred = Chosen then
No_Pred := UNR.Table (Chosen).Nextnp;
@@ -611,8 +1034,8 @@ package body Binde is
end loop;
end if;
- -- For all successors, decrement the number of predecessors, and
- -- if it becomes zero, then add to no predecessor list.
+ -- For all successors, decrement the number of predecessors, and if it
+ -- becomes zero, then add to no predecessor list.
S := UNR.Table (Chosen).Successors;
while S /= No_Successor loop
@@ -632,31 +1055,47 @@ package body Binde is
No_Pred := U;
end if;
+ if Doing_New and then SCC (U) /= SCC (Chosen) then
+ UNR.Table (SCC (U)).SCC_Num_Pred :=
+ UNR.Table (SCC (U)).SCC_Num_Pred - 1;
+
+ if Debug_Flag_N then
+ Write_Str (" decrementing SCC_Num_Pred for unit ");
+ Write_Unit_Name (Units.Table (U).Uname);
+ Write_Str (" new value = ");
+ Write_Int (SCC_Num_Pred (U));
+ Write_Eol;
+ end if;
+ end if;
+
S := Succ.Table (S).Next;
end loop;
-- All done, adjust number of units left count and set elaboration pos
- Num_Left := Num_Left - 1;
+ Num_Left := Num_Left - 1;
Num_Chosen := Num_Chosen + 1;
+
+ pragma Assert
+ (Errors_Detected > 0 or else Num_Chosen = Natural (Last (Elab_Order)));
+
UNR.Table (Chosen).Elab_Position := Num_Chosen;
- Units.Table (Chosen).Elab_Position := Num_Chosen;
- -- If we just chose a spec with Elaborate_Body set, then we
- -- must immediately elaborate the body, before any other units.
+ -- If we just chose a spec with Elaborate_Body set, then we must
+ -- immediately elaborate the body, before any other units.
if Units.Table (Chosen).Elaborate_Body then
-- If the unit is a spec only, then there is no body. This is a bit
- -- odd given that Elaborate_Body is here, but it is valid in an
- -- RCI unit, where we only have the interface in the stub bind.
+ -- odd given that Elaborate_Body is here, but it is valid in an RCI
+ -- unit, where we only have the interface in the stub bind.
if Units.Table (Chosen).Utype = Is_Spec_Only
and then Units.Table (Chosen).RCI
then
null;
else
- Choose (Corresponding_Body (Chosen));
+ Choose (Elab_Order, Corresponding_Body (Chosen));
end if;
end if;
end Choose;
@@ -665,9 +1104,9 @@ package body Binde is
-- Corresponding_Body --
------------------------
- -- Currently if the body and spec are separate, then they appear as
- -- two separate units in the same ALI file, with the body appearing
- -- first and the spec appearing second.
+ -- Currently if the body and spec are separate, then they appear as two
+ -- separate units in the same ALI file, with the body appearing first and
+ -- the spec appearing second.
function Corresponding_Body (U : Unit_Id) return Unit_Id is
begin
@@ -679,9 +1118,9 @@ package body Binde is
-- Corresponding_Spec --
------------------------
- -- Currently if the body and spec are separate, then they appear as
- -- two separate units in the same ALI file, with the body appearing
- -- first and the spec appearing second.
+ -- Currently if the body and spec are separate, then they appear as two
+ -- separate units in the same ALI file, with the body appearing first and
+ -- the spec appearing second.
function Corresponding_Spec (U : Unit_Id) return Unit_Id is
begin
@@ -689,12 +1128,38 @@ package body Binde is
return U + 1;
end Corresponding_Spec;
+ --------------------
+ -- Debug_Flag_Old --
+ --------------------
+
+ function Debug_Flag_Old return Boolean is
+ begin
+ -- For now, Debug_Flag_P means "use the new algorithm". Once it is
+ -- stable, we intend to remove the "not" below.
+
+ return not Debug_Flag_P;
+ end Debug_Flag_Old;
+
+ ----------------------
+ -- Debug_Flag_Older --
+ ----------------------
+
+ function Debug_Flag_Older return Boolean is
+ begin
+ return Debug_Flag_O;
+ end Debug_Flag_Older;
+
----------------------------------
-- Diagnose_Elaboration_Problem --
----------------------------------
- procedure Diagnose_Elaboration_Problem is
- function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
+ procedure Diagnose_Elaboration_Problem
+ (Elab_Order : in out Unit_Id_Table)
+ is
+ function Find_Path
+ (Ufrom : Unit_Id;
+ Uto : Unit_Id;
+ ML : Nat) return Boolean;
-- Recursive routine used to find a path from node Ufrom to node Uto.
-- If a path exists, returns True and outputs an appropriate set of
-- error messages giving the path. Also calls Choose for each of the
@@ -708,7 +1173,11 @@ package body Binde is
-- Find_Path --
---------------
- function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
+ function Find_Path
+ (Ufrom : Unit_Id;
+ Uto : Unit_Id;
+ ML : Nat) return Boolean
+ is
function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
-- This is the inner recursive routine, it determines if a path
-- exists from U to Uto, and if so returns True and outputs the
@@ -722,11 +1191,11 @@ package body Binde is
S : Successor_Id;
begin
- -- Recursion ends if we are at terminating node and the path
- -- is sufficiently long, generate error message and return True.
+ -- Recursion ends if we are at terminating node and the path is
+ -- sufficiently long, generate error message and return True.
if U = Uto and then PL >= ML then
- Choose (U);
+ Choose (Elab_Order, U);
return True;
-- All done if already visited
@@ -743,7 +1212,7 @@ package body Binde is
while S /= No_Successor loop
if Find_Link (Succ.Table (S).After, PL + 1) then
Elab_Error_Msg (S);
- Choose (U);
+ Choose (Elab_Order, U);
return True;
end if;
@@ -842,9 +1311,9 @@ package body Binde is
end;
end if;
- -- Output the header for the error, and manually increment the
- -- error count. We are using Error_Msg_Output rather than Error_Msg
- -- here for two reasons:
+ -- Output the header for the error, and manually increment the error
+ -- count. We are using Error_Msg_Output rather than Error_Msg here for
+ -- two reasons:
-- This is really only one error, not one for each line
-- We want this output on standard output since it is voluminous
@@ -866,8 +1335,8 @@ package body Binde is
end if;
end loop;
- -- We should never get here, since we were called for some reason,
- -- and we should have found and eliminated at least one bad path.
+ -- We should never get here, since we were called for some reason, and
+ -- we should have found and eliminated at least one bad path.
raise Program_Error;
end Diagnose_Elaboration_Problem;
@@ -894,14 +1363,14 @@ package body Binde is
-- Process all units with'ed by Before recursively
- for W in
- Units.Table (Before).First_With .. Units.Table (Before).Last_With
+ for W in Units.Table (Before).First_With ..
+ Units.Table (Before).Last_With
loop
- -- Skip if this with is an interface to a stand-alone library.
- -- Skip also if no ALI file for this WITH, happens for language
- -- defined generics while bootstrapping the compiler (see body of
- -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited
- -- with clause, which does not impose an elaboration link.
+ -- Skip if this with is an interface to a stand-alone library. Skip
+ -- also if no ALI file for this WITH, happens for language defined
+ -- generics while bootstrapping the compiler (see body of routine
+ -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
+ -- clause, which does not impose an elaboration link.
if not Withs.Table (W).SAL_Interface
and then Withs.Table (W).Afile /= No_File
@@ -918,11 +1387,12 @@ package body Binde is
if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
declare
- Withed : String :=
- Get_Name_String (Withs.Table (W).Uname);
+ Withed : String :=
+ Get_Name_String (Withs.Table (W).Uname);
Last_Withed : Natural := Withed'Last;
- Withing : String :=
- Get_Name_String (Units.Table (Before).Uname);
+ Withing : String :=
+ Get_Name_String
+ (Units.Table (Before).Uname);
Last_Withing : Natural := Withing'Last;
Spec_Body : String := " (Spec)";
@@ -930,20 +1400,20 @@ package body Binde is
To_Mixed (Withed);
To_Mixed (Withing);
- if Last_Withed > 2 and then
- Withed (Last_Withed - 1) = '%'
+ if Last_Withed > 2
+ and then Withed (Last_Withed - 1) = '%'
then
Last_Withed := Last_Withed - 2;
end if;
- if Last_Withing > 2 and then
- Withing (Last_Withing - 1) = '%'
+ if Last_Withing > 2
+ and then Withing (Last_Withing - 1) = '%'
then
Last_Withing := Last_Withing - 2;
end if;
- if Units.Table (Before).Utype = Is_Body or else
- Units.Table (Before).Utype = Is_Body_Only
+ if Units.Table (Before).Utype = Is_Body
+ or else Units.Table (Before).Utype = Is_Body_Only
then
Spec_Body := " (Body)";
end if;
@@ -1059,13 +1529,11 @@ package body Binde is
Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
Error_Msg_Output
- (" $ must therefore be elaborated before $",
- True);
+ (" $ must therefore be elaborated before $", True);
Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
Error_Msg_Output
- (" (because $ has a pragma Elaborate_Body)",
- True);
+ (" (because $ has a pragma Elaborate_Body)", True);
end if;
if not Zero_Formatting then
@@ -1077,127 +1545,197 @@ package body Binde is
-- Find_Elab_Order --
---------------------
- procedure Find_Elab_Order is
- U : Unit_Id;
- Best_So_Far : Unit_Id;
+ procedure Find_Elab_Order
+ (Elab_Order : out Unit_Id_Table;
+ First_Main_Lib_File : File_Name_Type)
+ is
+ function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat;
+ -- Number of cases where the body of a unit immediately follows the
+ -- corresponding spec. Such cases are good, because calls to that unit
+ -- from outside can't get ABE.
- begin
- Succ.Init;
- Num_Left := Int (Units.Last - Units.First + 1);
+ -------------------------
+ -- Num_Spec_Body_Pairs --
+ -------------------------
- -- Initialize unit table for elaboration control
+ function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is
+ Result : Nat := 0;
- for U in Units.First .. Units.Last loop
- UNR.Append
- ((Successors => No_Successor,
- Num_Pred => 0,
- Nextnp => No_Unit_Id,
- Elab_Order => 0,
- Visited => False,
- Elab_Position => 0));
- end loop;
+ begin
+ for J in Order'First + 1 .. Order'Last loop
+ if Units.Table (Order (J - 1)).Utype = Is_Spec
+ and then Units.Table (Order (J)).Utype = Is_Body
+ and then Corresponding_Spec (Order (J)) = Order (J - 1)
+ then
+ Result := Result + 1;
+ end if;
+ end loop;
+ return Result;
+ end Num_Spec_Body_Pairs;
+
+ -- Local variables
+
+ Old_Elab_Order : Unit_Id_Table;
+
+ -- Start of processing for Find_Elab_Order
+
+ begin
-- Output warning if -p used with no -gnatE units
- if Pessimistic_Elab_Order and not Dynamic_Elaboration_Checks_Specified
+ if Pessimistic_Elab_Order
+ and not Dynamic_Elaboration_Checks_Specified
then
Error_Msg ("?use of -p switch questionable");
Error_Msg ("?since all units compiled with static elaboration model");
end if;
- -- Gather dependencies and output them if option set
-
- Gather_Dependencies;
-
- -- Output elaboration dependencies if option is set
+ if Do_New then
+ if Debug_Flag_V then
+ Write_Line ("Doing new...");
+ end if;
- if Elab_Dependency_Output or Debug_Flag_E then
- Write_Dependencies;
+ Doing_New := True;
+ Init;
+ Elab_New.Find_Elab_Order (Elab_Order);
end if;
- -- Initialize the no predecessor list
+ -- Elab_New does not support the pessimistic order, so if that was
+ -- requested, use the old results. Use Elab_Old if -dp was selected.
+ -- Elab_New does not yet give proper error messages for illegal
+ -- Elaborate_Alls, so if there is one, run Elab_Old.
- No_Pred := No_Unit_Id;
- for U in UNR.First .. UNR.Last loop
- if UNR.Table (U).Num_Pred = 0 then
- UNR.Table (U).Nextnp := No_Pred;
- No_Pred := U;
+ if Do_Old
+ or Pessimistic_Elab_Order
+ or Debug_Flag_Old
+ or Illegal_Elab_All
+ then
+ if Debug_Flag_V then
+ Write_Line ("Doing old...");
end if;
- end loop;
- -- OK, now we determine the elaboration order proper. All we do is to
- -- select the best choice from the no predecessor list until all the
- -- nodes have been chosen.
+ Doing_New := False;
+ Init;
+ Elab_Old.Find_Elab_Order (Old_Elab_Order);
+ end if;
- Outer : loop
+ declare
+ Old_Order : Unit_Id_Array renames
+ Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
+ New_Order : Unit_Id_Array renames
+ Elab_Order.Table (1 .. Last (Elab_Order));
+ Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
+ New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
- -- If there are no nodes with predecessors, then either we are
- -- done, as indicated by Num_Left being set to zero, or we have
- -- a circularity. In the latter case, diagnose the circularity,
- -- removing it from the graph and continue
+ begin
+ if Do_Old and Do_New then
+ Write_Line (Get_Name_String (First_Main_Lib_File));
- Get_No_Pred : while No_Pred = No_Unit_Id loop
- exit Outer when Num_Left < 1;
- Diagnose_Elaboration_Problem;
- end loop Get_No_Pred;
+ pragma Assert (Old_Order'Length = New_Order'Length);
+ pragma Debug (Validate (Old_Order, Doing_New => False));
+ pragma Debug (Validate (New_Order, Doing_New => True));
- U := No_Pred;
- Best_So_Far := No_Unit_Id;
+ -- Misc debug printouts that can be used for experimentation by
+ -- changing the 'if's below.
- -- Loop to choose best entry in No_Pred list
+ if True then
+ if New_Order = Old_Order then
+ Write_Line ("Elab_New: same order.");
+ else
+ Write_Line ("Elab_New: diff order.");
+ end if;
+ end if;
- No_Pred_Search : loop
- if Debug_Flag_N then
- Write_Str (" considering choice of ");
- Write_Unit_Name (Units.Table (U).Uname);
- Write_Eol;
+ if New_Order /= Old_Order and then False then
+ Write_Line ("Elaboration orders differ:");
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
+ end if;
+
+ if True then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- if Units.Table (U).Elaborate_Body then
- Write_Str
- (" Elaborate_Body = True, Num_Pred for body = ");
- Write_Int
- (UNR.Table (Corresponding_Body (U)).Num_Pred);
+ if Old_Pairs = New_Pairs then
+ Write_Str (" = ");
+ elsif Old_Pairs < New_Pairs then
+ Write_Str (" < ");
else
- Write_Str
- (" Elaborate_Body = False");
+ Write_Str (" > ");
end if;
+ Write_Int (New_Pairs);
Write_Eol;
end if;
- -- This is a candididate to be considered for choice
+ if Old_Pairs /= New_Pairs and then False then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- if Best_So_Far = No_Unit_Id
- or else ((not Pessimistic_Elab_Order)
- and then Better_Choice (U, Best_So_Far))
- or else (Pessimistic_Elab_Order
- and then Pessimistic_Better_Choice (U, Best_So_Far))
- then
- if Debug_Flag_N then
- Write_Str (" tentatively chosen (best so far)");
- Write_Eol;
+ if Old_Pairs < New_Pairs then
+ Write_Str (" < ");
+ else
+ Write_Str (" > ");
end if;
- Best_So_Far := U;
+ Write_Int (New_Pairs);
+ Write_Eol;
+
+ if Old_Pairs /= New_Pairs and then Debug_Flag_V then
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
+ pragma Assert (New_Pairs >= Old_Pairs);
+ end if;
end if;
+ end if;
- U := UNR.Table (U).Nextnp;
- exit No_Pred_Search when U = No_Unit_Id;
- end loop No_Pred_Search;
+ -- The Elab_New algorithm doesn't implement the -p switch, so if that
+ -- was used, use the results from the old algorithm.
+
+ if Pessimistic_Elab_Order or Debug_Flag_Old then
+ New_Order := Old_Order;
+ end if;
- -- If no candididate chosen, it means that no unit has No_Pred = 0,
- -- but there are units left, hence we have a circular dependency,
- -- which we will get Diagnose_Elaboration_Problem to diagnose it.
+ -- Now set the Elab_Positions in the Units table. It is important to
+ -- do this late, in case we're running both Elab_New and Elab_Old.
- if Best_So_Far = No_Unit_Id then
- Diagnose_Elaboration_Problem;
+ declare
+ Units_Array : Units.Table_Type renames
+ Units.Table (Units.First .. Units.Last);
- -- Otherwise choose the best candidate found
+ begin
+ for J in New_Order'Range loop
+ pragma Assert
+ (UNR.Table (New_Order (J)).Elab_Position = Positive (J));
+ Units_Array (New_Order (J)).Elab_Position := Positive (J);
+ end loop;
+ end;
- else
- Choose (Best_So_Far);
+ if Errors_Detected = 0 then
+
+ -- Display elaboration order if -l was specified
+
+ if Elab_Order_Output then
+ if Zero_Formatting then
+ Write_Elab_Order (New_Order, Title => "");
+ else
+ Write_Elab_Order (New_Order, Title => "ELABORATION ORDER");
+ end if;
+ end if;
+
+ -- Display list of sources in the closure (except predefined
+ -- sources) if -R was used. Include predefined sources if -Ra
+ -- was used.
+
+ if List_Closure then
+ Write_Closure (New_Order);
+ end if;
end if;
- end loop Outer;
+ end;
end Find_Elab_Order;
----------------------
@@ -1211,7 +1749,7 @@ package body Binde is
function Get_Line return String;
-- Read the next line from the file content read by Read_File. Strip
- -- leading and trailing blanks. Convert "(spec)" or "(body)" to
+ -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
-- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
function Read_File (Name : String) return String_Ptr;
@@ -1222,6 +1760,7 @@ package body Binde is
---------------
function Read_File (Name : String) return String_Ptr is
+
-- All of the following calls should succeed, because we checked the
-- file in Switch.B, but we double check and raise Program_Error on
-- failure, just in case.
@@ -1363,6 +1902,7 @@ package body Binde is
while Cur <= S'Last loop
declare
Uname : constant Unit_Name_Type := Name_Find (Get_Line);
+
begin
if Uname = Empty_Name then
null; -- silently skip blank lines
@@ -1370,25 +1910,32 @@ package body Binde is
elsif Get_Name_Table_Int (Uname) = 0
or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
then
- Write_Line
- ("""" & Get_Name_String (Uname) &
- """: not present; ignored");
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname)
+ & """: not present; ignored");
+ end if;
else
declare
Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
+
begin
if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
- Write_Line
- ("""" & Get_Name_String (Uname) &
- """: predefined unit ignored");
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname) &
+ """: predefined unit ignored");
+ end if;
else
if Prev_Unit /= No_Unit_Id then
- Write_Unit_Name (Units.Table (Prev_Unit).Uname);
- Write_Str (" <-- ");
- Write_Unit_Name (Units.Table (Cur_Unit).Uname);
- Write_Eol;
+ if Doing_New then
+ Write_Unit_Name (Units.Table (Prev_Unit).Uname);
+ Write_Str (" <-- ");
+ Write_Unit_Name (Units.Table (Cur_Unit).Uname);
+ Write_Eol;
+ end if;
Build_Link
(Before => Prev_Unit,
@@ -1419,9 +1966,9 @@ package body Binde is
for U in Units.First .. Units.Last loop
Cur_Unit := U;
- -- If this is not an interface to a stand-alone library and
- -- there is a body and a spec, then spec must be elaborated first
- -- Note that the corresponding spec immediately follows the body
+ -- If this is not an interface to a stand-alone library and there is
+ -- a body and a spec, then spec must be elaborated first. Note that
+ -- the corresponding spec immediately follows the body.
if not Units.Table (U).SAL_Interface
and then Units.Table (U).Utype = Is_Body
@@ -1429,12 +1976,13 @@ package body Binde is
Build_Link (Corresponding_Spec (U), U, Spec_First);
end if;
- -- If this unit is not an interface to a stand-alone library,
- -- process WITH references for this unit ignoring generic units and
- -- interfaces to stand-alone libraries.
+ -- If this unit is not an interface to a stand-alone library, process
+ -- WITH references for this unit ignoring interfaces to stand-alone
+ -- libraries.
if not Units.Table (U).SAL_Interface then
- for W in Units.Table (U).First_With .. Units.Table (U).Last_With
+ for W in Units.Table (U).First_With ..
+ Units.Table (U).Last_With
loop
if Withs.Table (W).Sfile /= No_File
and then (not Withs.Table (W).SAL_Interface)
@@ -1446,9 +1994,12 @@ package body Binde is
-- obsolete unit with's a previous (now disappeared) spec.
if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
- Error_Msg_File_1 := Units.Table (U).Sfile;
- Error_Msg_Unit_1 := Withs.Table (W).Uname;
- Error_Msg ("{ depends on $ which no longer exists");
+ if Doing_New then
+ Error_Msg_File_1 := Units.Table (U).Sfile;
+ Error_Msg_Unit_1 := Withs.Table (W).Uname;
+ Error_Msg ("{ depends on $ which no longer exists");
+ end if;
+
goto Next_With;
end if;
@@ -1457,7 +2008,10 @@ package body Binde is
-- Pragma Elaborate_All case, for this we use the recursive
-- Elab_All_Links procedure to establish the links.
- if Withs.Table (W).Elaborate_All then
+ -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
+ -- except for error messages.
+
+ if Withs.Table (W).Elaborate_All and then not Doing_New then
-- Reset flags used to stop multiple visits to a given
-- node.
@@ -1476,8 +2030,9 @@ package body Binde is
-- Elaborate_All_Desirable case, for this we establish the
-- same links as above, but with a different reason.
- elsif Withs.Table (W).Elab_All_Desirable then
-
+ elsif Withs.Table (W).Elab_All_Desirable
+ and then not Doing_New
+ then
-- Reset flags used to stop multiple visits to a given
-- node.
@@ -1512,8 +2067,8 @@ package body Binde is
(Corresponding_Body (Withed_Unit), U, Elab);
end if;
- -- Elaborate_Desirable case, for this we establish
- -- the same links as above, but with a different reason.
+ -- Elaborate_Desirable case, for this we establish the same
+ -- links as above, but with a different reason.
elsif Withs.Table (W).Elab_Desirable then
Build_Link (Withed_Unit, U, Withed);
@@ -1550,16 +2105,53 @@ package body Binde is
if Force_Elab_Order_File /= null then
Force_Elab_Order;
end if;
+
+ -- Output elaboration dependencies if option is set
+
+ if Elab_Dependency_Output or Debug_Flag_E then
+ if Doing_New then
+ Write_Dependencies;
+ end if;
+ end if;
end Gather_Dependencies;
+ ----------
+ -- Init --
+ ----------
+
+ procedure Init is
+ begin
+ Num_Chosen := 0;
+ Num_Left := Int (Units.Last - Units.First + 1);
+ Succ.Init;
+ Elab_All_Entries.Init;
+ UNR.Init;
+
+ -- Initialize unit table for elaboration control
+
+ for U in Units.First .. Units.Last loop
+ UNR.Append
+ ((Successors => No_Successor,
+ Num_Pred => 0,
+ Nextnp => No_Unit_Id,
+ Visited => False,
+ Elab_Position => 0,
+ SCC_Root => No_Unit_Id,
+ Nodes => null,
+ SCC_Num_Pred => 0,
+ Validate_Seen => False));
+ end loop;
+ end Init;
+
------------------
-- Is_Body_Unit --
------------------
function Is_Body_Unit (U : Unit_Id) return Boolean is
begin
- return Units.Table (U).Utype = Is_Body
- or else Units.Table (U).Utype = Is_Body_Only;
+ return
+ Units.Table (U).Utype = Is_Body
+ or else Units.Table (U).Utype = Is_Body_Only;
end Is_Body_Unit;
-----------------------------
@@ -1571,16 +2163,14 @@ package body Binde is
-- If we have a body with separate spec, test flags on the spec
if Units.Table (U).Utype = Is_Body then
- return Units.Table (Corresponding_Spec (U)).Preelab
- or else
- Units.Table (Corresponding_Spec (U)).Pure;
+ return
+ Units.Table (Corresponding_Spec (U)).Preelab
+ or else Units.Table (Corresponding_Spec (U)).Pure;
-- Otherwise we have a spec or body acting as spec, test flags on unit
else
- return Units.Table (U).Preelab
- or else
- Units.Table (U).Pure;
+ return Units.Table (U).Preelab or else Units.Table (U).Pure;
end if;
end Is_Pure_Or_Preelab_Unit;
@@ -1590,8 +2180,9 @@ package body Binde is
function Is_Waiting_Body (U : Unit_Id) return Boolean is
begin
- return Units.Table (U).Utype = Is_Body
- and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
+ return
+ Units.Table (U).Utype = Is_Body
+ and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
end Is_Waiting_Body;
-------------------------
@@ -1603,237 +2194,210 @@ package body Binde is
Link : Elab_All_Id) return Elab_All_Id
is
begin
- Elab_All_Entries.Increment_Last;
- Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
- Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
+ Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link));
return Elab_All_Entries.Last;
end Make_Elab_All_Entry;
- -------------------------------
- -- Pessimistic_Better_Choice --
- -------------------------------
+ ----------------
+ -- Unit_Id_Of --
+ ----------------
- function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is
- UT1 : Unit_Record renames Units.Table (U1);
- UT2 : Unit_Record renames Units.Table (U2);
+ function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
+ Info : constant Int := Get_Name_Table_Int (Uname);
begin
- if Debug_Flag_B then
- Write_Str ("Pessimistic_Better_Choice (");
- Write_Unit_Name (UT1.Uname);
- Write_Str (", ");
- Write_Unit_Name (UT2.Uname);
- Write_Line (")");
- end if;
-
- -- Note: the checks here are applied in sequence, and the ordering is
- -- significant (i.e. the more important criteria are applied first).
-
- -- If either unit is predefined or internal, then we use the normal
- -- Better_Choice rule, since we don't want to disturb the elaboration
- -- rules of the language with -p, same treatment for Pure/Preelab.
-
- -- Prefer a predefined unit to a non-predefined unit
-
- if UT1.Predefined and then not UT2.Predefined then
- if Debug_Flag_B then
- Write_Line (" True: u1 is predefined, u2 is not");
- end if;
-
- return True;
-
- elsif UT2.Predefined and then not UT1.Predefined then
- if Debug_Flag_B then
- Write_Line (" False: u2 is predefined, u1 is not");
- end if;
-
- return False;
-
- -- Prefer an internal unit to a non-internal unit
-
- elsif UT1.Internal and then not UT2.Internal then
- if Debug_Flag_B then
- Write_Line (" True: u1 is internal, u2 is not");
- end if;
+ pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
+ return Unit_Id (Info);
+ end Unit_Id_Of;
- return True;
+ --------------
+ -- Validate --
+ --------------
- elsif UT2.Internal and then not UT1.Internal then
- if Debug_Flag_B then
- Write_Line (" False: u2 is internal, u1 is not");
- end if;
+ procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is
+ Cur_SCC : Unit_Id := No_Unit_Id;
+ OK : Boolean := True;
+ Msg : String := "Old: ";
- return False;
+ begin
+ if Doing_New then
+ Msg := "New: ";
+ end if;
- -- Prefer a pure or preelaborable unit to one that is not
+ -- For each unit, assert that its successors are elaborated after it
- elsif Is_Pure_Or_Preelab_Unit (U1)
- and then not
- Is_Pure_Or_Preelab_Unit (U2)
- then
- if Debug_Flag_B then
- Write_Line (" True: u1 is pure/preelab, u2 is not");
- end if;
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
+ S : Successor_Id := UNR.Table (U).Successors;
- return True;
+ begin
+ while S /= No_Successor loop
+ pragma Assert
+ (UNR.Table (Succ.Table (S).After).Elab_Position >
+ UNR.Table (U).Elab_Position,
+ Msg & " elab order failed");
+ S := Succ.Table (S).Next;
+ end loop;
+ end;
+ end loop;
- elsif Is_Pure_Or_Preelab_Unit (U2)
- and then not
- Is_Pure_Or_Preelab_Unit (U1)
- then
- if Debug_Flag_B then
- Write_Line (" False: u2 is pure/preelab, u1 is not");
- end if;
+ -- An SCC of size 2 units necessarily consists of a spec and the
+ -- corresponding body. Assert that the body is elaborated immediately
+ -- after the spec, with nothing in between. (We only have SCCs in the
+ -- new algorithm.)
- return False;
+ if Doing_New then
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
- -- Prefer anything else to a waiting body. We want to make bodies wait
- -- as long as possible, till we are forced to choose them.
+ begin
+ if Nodes (U)'Length = 2 then
+ if Units.Table (U).Utype = Is_Spec then
+ if Order (J + 1) /= Corresponding_Body (U) then
+ OK := False;
+ Write_Line (Msg & "Bad spec with SCC of size 2:");
+ Write_SCC (SCC (U));
+ end if;
+ end if;
- elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
- if Debug_Flag_B then
- Write_Line (" False: u1 is waiting body, u2 is not");
- end if;
+ if Units.Table (U).Utype = Is_Body then
+ if Order (J - 1) /= Corresponding_Spec (U) then
+ OK := False;
+ Write_Line (Msg & "Bad body with SCC of size 2:");
+ Write_SCC (SCC (U));
+ end if;
+ end if;
+ end if;
+ end;
+ end loop;
- return False;
+ -- Assert that all units of an SCC are elaborated together, with no
+ -- units from other SCCs in between. The above spec/body case is a
+ -- special case of this general rule.
- elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
- if Debug_Flag_B then
- Write_Line (" True: u2 is waiting body, u1 is not");
- end if;
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
- return True;
+ begin
+ if SCC (U) /= Cur_SCC then
+ Cur_SCC := SCC (U);
+ if UNR.Table (Cur_SCC).Validate_Seen then
+ OK := False;
+ Write_Line (Msg & "SCC not elaborated together:");
+ Write_SCC (Cur_SCC);
+ end if;
- -- Prefer a spec to a body (this is mandatory)
+ UNR.Table (Cur_SCC).Validate_Seen := True;
+ end if;
+ end;
+ end loop;
+ end if;
- elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
- if Debug_Flag_B then
- Write_Line (" False: u1 is body, u2 is not");
- end if;
+ pragma Assert (OK);
+ end Validate;
- return False;
+ -------------------
+ -- Write_Closure --
+ -------------------
- elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
- if Debug_Flag_B then
- Write_Line (" True: u2 is body, u1 is not");
- end if;
+ procedure Write_Closure (Order : Unit_Id_Array) is
+ package Closure_Sources is new Table.Table
+ (Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Gnatbind.Closure_Sources");
+ -- Table to record the sources in the closure, to avoid duplications
+
+ function Put_In_Sources (S : File_Name_Type) return Boolean;
+ -- Check if S is already in table Sources and put in Sources if it is
+ -- not. Return False if the source is already in Sources, and True if
+ -- it is added.
+
+ --------------------
+ -- Put_In_Sources --
+ --------------------
+
+ function Put_In_Sources (S : File_Name_Type) return Boolean is
+ begin
+ for J in 1 .. Closure_Sources.Last loop
+ if Closure_Sources.Table (J) = S then
+ return False;
+ end if;
+ end loop;
+ Closure_Sources.Append (S);
return True;
+ end Put_In_Sources;
- -- If both are waiting bodies, then prefer the one whose spec is
- -- less recently elaborated. Consider the following:
+ -- Local variables
- -- spec of A
- -- spec of B
- -- body of A or B?
+ Source : File_Name_Type;
- -- The normal waiting body preference would have placed the body of
- -- A before the spec of B if it could. Since it could not, then it
- -- must be the case that A depends on B. It is therefore a good idea
- -- to put the body of B last so that if there is an elaboration order
- -- problem, we will find it (that's what pessimistic order is about)
+ -- Start of processing for Write_Closure
- elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
- declare
- Result : constant Boolean :=
- UNR.Table (Corresponding_Spec (U1)).Elab_Position <
- UNR.Table (Corresponding_Spec (U2)).Elab_Position;
- begin
- if Debug_Flag_B then
- if Result then
- Write_Line (" True: based on waiting body elab positions");
- else
- Write_Line (" False: based on waiting body elab positions");
- end if;
- end if;
+ begin
+ Closure_Sources.Init;
- return Result;
- end;
+ if not Zero_Formatting then
+ Write_Eol;
+ Write_Str ("REFERENCED SOURCES");
+ Write_Eol;
end if;
- -- Remaining choice rules are disabled by Debug flag -do
+ for J in reverse Order'Range loop
+ Source := Units.Table (Order (J)).Sfile;
- if not Debug_Flag_O then
+ -- Do not include same source more than once
- -- The following deal with the case of specs that have been marked
- -- as Elaborate_Body_Desirable. In the normal case, we generally want
- -- to delay the elaboration of these specs as long as possible, so
- -- that bodies have better chance of being elaborated closer to the
- -- specs. Pessimistic_Better_Choice as usual wants to do the opposite
- -- and elaborate such specs as early as possible.
+ if Put_In_Sources (Source)
- -- If we have two units, one of which is a spec for which this flag
- -- is set, and the other is not, we normally prefer to delay the spec
- -- for which the flag is set, so again Pessimistic_Better_Choice does
- -- the opposite.
+ -- Do not include run-time units unless -Ra switch set
- if not UT1.Elaborate_Body_Desirable
- and then UT2.Elaborate_Body_Desirable
+ and then (List_Closure_All
+ or else not Is_Internal_File_Name (Source))
then
- if Debug_Flag_B then
- Write_Line (" False: u1 is elab body desirable, u2 is not");
+ if not Zero_Formatting then
+ Write_Str (" ");
end if;
- return False;
-
- elsif not UT2.Elaborate_Body_Desirable
- and then UT1.Elaborate_Body_Desirable
- then
- if Debug_Flag_B then
- Write_Line (" True: u1 is elab body desirable, u2 is not");
- end if;
+ Write_Str (Get_Name_String (Source));
+ Write_Eol;
+ end if;
+ end loop;
- return True;
+ -- Subunits do not appear in the elaboration table because they are
+ -- subsumed by their parent units, but we need to list them for other
+ -- tools. For now they are listed after other files, rather than right
+ -- after their parent, since there is no easy link between the
+ -- elaboration table and the ALIs table ??? As subunits may appear
+ -- repeatedly in the list, if the parent unit appears in the context of
+ -- several units in the closure, duplicates are suppressed.
- -- If we have two specs that are both marked as Elaborate_Body
- -- desirable, we normally prefer the one whose body is nearer to
- -- being able to be elaborated, based on the Num_Pred count. This
- -- helps to ensure bodies are as close to specs as possible. As
- -- usual, Pessimistic_Better_Choice does the opposite.
+ for J in Sdep.First .. Sdep.Last loop
+ Source := Sdep.Table (J).Sfile;
- elsif UT1.Elaborate_Body_Desirable
- and then UT2.Elaborate_Body_Desirable
+ if Sdep.Table (J).Subunit_Name /= No_Name
+ and then Put_In_Sources (Source)
+ and then not Is_Internal_File_Name (Source)
then
- declare
- Result : constant Boolean :=
- UNR.Table (Corresponding_Body (U1)).Num_Pred >=
- UNR.Table (Corresponding_Body (U2)).Num_Pred;
- begin
- if Debug_Flag_B then
- if Result then
- Write_Line (" True based on Num_Pred compare");
- else
- Write_Line (" False based on Num_Pred compare");
- end if;
- end if;
+ if not Zero_Formatting then
+ Write_Str (" ");
+ end if;
- return Result;
- end;
+ Write_Str (Get_Name_String (Source));
+ Write_Eol;
end if;
- end if;
-
- -- If we fall through, it means that no preference rule applies, so we
- -- use alphabetical order to at least give a deterministic result. Since
- -- Pessimistic_Better_Choice is in the business of stirring up the
- -- order, we will use reverse alphabetical ordering.
+ end loop;
- if Debug_Flag_B then
- Write_Line (" choose on reverse alpha order");
+ if not Zero_Formatting then
+ Write_Eol;
end if;
-
- return Uname_Less (UT2.Uname, UT1.Uname);
- end Pessimistic_Better_Choice;
-
- ----------------
- -- Unit_Id_Of --
- ----------------
-
- function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
- Info : constant Int := Get_Name_Table_Int (Uname);
- begin
- pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
- return Unit_Id (Info);
- end Unit_Id_Of;
+ end Write_Closure;
------------------------
-- Write_Dependencies --
@@ -1892,8 +2456,8 @@ package body Binde is
else
Error_Msg_Output
- (" which must be elaborated " &
- "along with its spec:",
+ (" which must be elaborated along with its "
+ & "spec:",
Info => True);
end if;
@@ -1920,4 +2484,695 @@ package body Binde is
end if;
end Write_Elab_All_Chain;
+ ----------------------
+ -- Write_Elab_Order --
+ ----------------------
+
+ procedure Write_Elab_Order
+ (Order : Unit_Id_Array; Title : String)
+ is
+ begin
+ if Title /= "" then
+ Write_Eol;
+ Write_Str (Title);
+ Write_Eol;
+ end if;
+
+ for J in Order'Range loop
+ if not Units.Table (Order (J)).SAL_Interface then
+ if not Zero_Formatting then
+ Write_Str (" ");
+ end if;
+
+ Write_Unit_Name (Units.Table (Order (J)).Uname);
+ Write_Eol;
+ end if;
+ end loop;
+
+ if Title /= "" then
+ Write_Eol;
+ end if;
+ end Write_Elab_Order;
+
+ --------------
+ -- Elab_New --
+ --------------
+
+ package body Elab_New is
+
+ generic
+ type Node is (<>);
+ First_Node : Node;
+ Last_Node : Node;
+ type Node_Array is array (Pos range <>) of Node;
+ with function Successors (N : Node) return Node_Array;
+ with procedure Create_SCC (Root : Node; Nodes : Node_Array);
+
+ procedure Compute_Strongly_Connected_Components;
+ -- Compute SCCs for a directed graph. The nodes in the graph are all
+ -- values of type Node in the range First_Node .. Last_Node.
+ -- Successors(N) returns the nodes pointed to by the edges emanating
+ -- from N. Create_SCC is a callback that is called once for each SCC,
+ -- passing in the Root node for that SCC (which is an arbitrary node in
+ -- the SCC used as a representative of that SCC), and the set of Nodes
+ -- in that SCC.
+ --
+ -- This is generic, in case we want to use it elsewhere; then we could
+ -- move this into a separate library unit. Unfortunately, it's not as
+ -- generic as one might like. Ideally, we would have "type Node is
+ -- private;", and pass in iterators to iterate over all nodes, and over
+ -- the successors of a given node. However, that leads to using advanced
+ -- features of Ada that are not allowed in the compiler and binder for
+ -- bootstrapping reason. It also leads to trampolines, which are not
+ -- allowed in the compiler and binder. Restricting Node to be discrete
+ -- allows us to iterate over all nodes with a 'for' loop, and allows us
+ -- to attach temporary information to nodes by having an array indexed
+ -- by Node.
+
+ procedure Compute_Unit_SCCs;
+ -- Use the above generic procedure to compute the SCCs for the graph of
+ -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
+ -- components. Also initialize the SCC_Num_Pred components.
+
+ procedure Find_Elab_All_Errors;
+ -- Generate an error for illegal Elaborate_All pragmas (explicit or
+ -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
+ -- if X and Y are in different SCCs.
+
+ -------------------------------------------
+ -- Compute_Strongly_Connected_Components --
+ -------------------------------------------
+
+ procedure Compute_Strongly_Connected_Components is
+
+ -- This uses Tarjan's algorithm for finding SCCs. Comments here are
+ -- intended to tell what it does, but if you want to know how it
+ -- works, you have to look it up. Please do not modify this code
+ -- without reading up on Tarjan's algorithm.
+
+ subtype Node_Index is Nat;
+ No_Index : constant Node_Index := 0;
+
+ Num_Nodes : constant Nat :=
+ Node'Pos (Last_Node) - Node'Pos (First_Node) + 1;
+ Stack : Node_Array (1 .. Num_Nodes);
+ Top : Node_Index := 0;
+ -- Stack of nodes, pushed when first visited. All nodes of an SCC are
+ -- popped at once when the SCC is found.
+
+ subtype Valid_Node is Node range First_Node .. Last_Node;
+ Node_Indices : array (Valid_Node) of Node_Index :=
+ (others => No_Index);
+ -- Each node has an "index", which is the sequential number in the
+ -- order in which they are visited in the recursive walk. No_Index
+ -- means "not yet visited"; we want to avoid walking any node more
+ -- than once.
+
+ Index : Node_Index := 1;
+ -- Next value to be assigned to a node index
+
+ Low_Links : array (Valid_Node) of Node_Index;
+ -- Low_Links (N) is the smallest index of nodes reachable from N
+
+ On_Stack : array (Valid_Node) of Boolean := (others => False);
+ -- True if the node is currently on the stack
+
+ procedure Walk (N : Valid_Node);
+ -- Recursive depth-first graph walk, with the node index used to
+ -- avoid visiting a node more than once.
+
+ ----------
+ -- Walk --
+ ----------
+
+ procedure Walk (N : Valid_Node) is
+ Stack_Position_Of_N : constant Pos := Top + 1;
+ S : constant Node_Array := Successors (N);
+
+ begin
+ -- Assign the index and low link, increment Index for next call to
+ -- Walk.
+
+ Node_Indices (N) := Index;
+ Low_Links (N) := Index;
+ Index := Index + 1;
+
+ -- Push it one the stack:
+
+ Top := Stack_Position_Of_N;
+ Stack (Top) := N;
+ On_Stack (N) := True;
+
+ -- Walk not-yet-visited subnodes, and update low link for visited
+ -- ones as appropriate.
+
+ for J in S'Range loop
+ if Node_Indices (S (J)) = No_Index then
+ Walk (S (J));
+ Low_Links (N) :=
+ Node_Index'Min (Low_Links (N), Low_Links (S (J)));
+ elsif On_Stack (S (J)) then
+ Low_Links (N) :=
+ Node_Index'Min (Low_Links (N), Node_Indices (S (J)));
+ end if;
+ end loop;
+
+ -- If the index is (still) equal to the low link, we've found an
+ -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
+
+ if Low_Links (N) = Node_Indices (N) then
+ declare
+ SCC : Node_Array renames
+ Stack (Stack_Position_Of_N .. Top);
+ pragma Assert (SCC'Length >= 1);
+ pragma Assert (SCC (SCC'First) = N);
+
+ begin
+ for J in SCC'Range loop
+ On_Stack (SCC (J)) := False;
+ end loop;
+
+ Create_SCC (Root => N, Nodes => SCC);
+ pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1);
+ Top := Stack_Position_Of_N - 1; -- pop all
+ end;
+ end if;
+ end Walk;
+
+ -- Start of processing for Compute_Strongly_Connected_Components
+
+ begin
+ -- Walk all the nodes that have not yet been walked
+
+ for N in Valid_Node loop
+ if Node_Indices (N) = No_Index then
+ Walk (N);
+ end if;
+ end loop;
+ end Compute_Strongly_Connected_Components;
+
+ -----------------------
+ -- Compute_Unit_SCCs --
+ -----------------------
+
+ procedure Compute_Unit_SCCs is
+ function Successors (U : Unit_Id) return Unit_Id_Array;
+ -- Return all the units that must be elaborated after U. In addition,
+ -- if U is a body, include the corresponding spec; this ensures that
+ -- a spec/body pair are always in the same SCC.
+
+ procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array);
+ -- Set Nodes of the Root, and set SCC_Root of all the Nodes
+
+ procedure Init_SCC_Num_Pred (U : Unit_Id);
+ -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
+ -- has a count of the number of successors of all the units in the
+ -- SCC, but only for successors outside the SCC.
+
+ procedure Compute_SCCs is new Compute_Strongly_Connected_Components
+ (Node => Unit_Id,
+ First_Node => Units.First,
+ Last_Node => Units.Last,
+ Node_Array => Unit_Id_Array,
+ Successors => Successors,
+ Create_SCC => Create_SCC);
+
+ ----------------
+ -- Create_SCC --
+ ----------------
+
+ procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is
+ begin
+ if Debug_Flag_V then
+ Write_Str ("Root = ");
+ Write_Int (Int (Root));
+ Write_Str (" ");
+ Write_Unit_Name (Units.Table (Root).Uname);
+ Write_Str (" -- ");
+ Write_Int (Nodes'Length);
+ Write_Str (" units:");
+ Write_Eol;
+
+ for J in Nodes'Range loop
+ Write_Str (" ");
+ Write_Int (Int (Nodes (J)));
+ Write_Str (" ");
+ Write_Unit_Name (Units.Table (Nodes (J)).Uname);
+ Write_Eol;
+ end loop;
+ end if;
+
+ pragma Assert (Nodes (Nodes'First) = Root);
+ pragma Assert (UNR.Table (Root).Nodes = null);
+ UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes);
+
+ for J in Nodes'Range loop
+ pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
+ UNR.Table (Nodes (J)).SCC_Root := Root;
+ end loop;
+ end Create_SCC;
+
+ ----------------
+ -- Successors --
+ ----------------
+
+ function Successors (U : Unit_Id) return Unit_Id_Array is
+ S : Successor_Id := UNR.Table (U).Successors;
+ Tab : Unit_Id_Table;
+
+ begin
+ -- Pretend that a spec is a successor of its body (even though it
+ -- isn't), just so both get included.
+
+ if Units.Table (U).Utype = Is_Body then
+ Append (Tab, Corresponding_Spec (U));
+ end if;
+
+ -- Now include the real successors
+
+ while S /= No_Successor loop
+ pragma Assert (Succ.Table (S).Before = U);
+ Append (Tab, Succ.Table (S).After);
+ S := Succ.Table (S).Next;
+ end loop;
+
+ declare
+ Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
+
+ begin
+ Free (Tab);
+ return Result;
+ end;
+ end Successors;
+
+ -----------------------
+ -- Init_SCC_Num_Pred --
+ -----------------------
+
+ procedure Init_SCC_Num_Pred (U : Unit_Id) is
+ begin
+ if UNR.Table (U).Visited then
+ return;
+ end if;
+
+ UNR.Table (U).Visited := True;
+
+ declare
+ S : Successor_Id := UNR.Table (U).Successors;
+
+ begin
+ while S /= No_Successor loop
+ pragma Assert (Succ.Table (S).Before = U);
+ Init_SCC_Num_Pred (Succ.Table (S).After);
+
+ if SCC (U) /= SCC (Succ.Table (S).After) then
+ UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
+ UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
+ end if;
+
+ S := Succ.Table (S).Next;
+ end loop;
+ end;
+ end Init_SCC_Num_Pred;
+
+ -- Start of processing for Compute_Unit_SCCs
+
+ begin
+ Compute_SCCs;
+
+ for Uref in UNR.First .. UNR.Last loop
+ pragma Assert (not UNR.Table (Uref).Visited);
+ null;
+ end loop;
+
+ for Uref in UNR.First .. UNR.Last loop
+ Init_SCC_Num_Pred (Uref);
+ end loop;
+
+ -- Assert that SCC_Root of all units has been set to a valid unit,
+ -- and that SCC_Num_Pred has not been modified in non-root units.
+
+ for Uref in UNR.First .. UNR.Last loop
+ pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
+ pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
+
+ if SCC (Uref) /= Uref then
+ pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
+ null;
+ end if;
+ end loop;
+ end Compute_Unit_SCCs;
+
+ --------------------------
+ -- Find_Elab_All_Errors --
+ --------------------------
+
+ procedure Find_Elab_All_Errors is
+ Withed_Unit : Unit_Id;
+
+ begin
+ for U in Units.First .. Units.Last loop
+
+ -- If this unit is not an interface to a stand-alone library,
+ -- process WITH references for this unit ignoring interfaces to
+ -- stand-alone libraries.
+
+ if not Units.Table (U).SAL_Interface then
+ for W in Units.Table (U).First_With ..
+ Units.Table (U).Last_With
+ loop
+ if Withs.Table (W).Sfile /= No_File
+ and then (not Withs.Table (W).SAL_Interface)
+ then
+ -- Check for special case of withing a unit that does not
+ -- exist any more.
+
+ if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
+ goto Next_With;
+ end if;
+
+ Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
+
+ -- If it's Elaborate_All or Elab_All_Desirable, check
+ -- that the withER and withEE are not in the same SCC.
+
+ if Withs.Table (W).Elaborate_All
+ or else Withs.Table (W).Elab_All_Desirable
+ then
+ if SCC (U) = SCC (Withed_Unit) then
+ Illegal_Elab_All := True; -- ????
+
+ -- We could probably give better error messages
+ -- than Elab_Old here, but for now, to avoid
+ -- disruption, we don't give any error here.
+ -- Instead, we set the Illegal_Elab_All flag above,
+ -- and then run the Elab_Old algorithm to issue the
+ -- error message. Ideally, we would like to print
+ -- multiple errors rather than stopping after the
+ -- first cycle.
+
+ if False then
+ Error_Msg_Output
+ ("illegal pragma Elaborate_All",
+ Info => False);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ <<Next_With>>
+ null;
+ end loop;
+ end if;
+ end loop;
+ end Find_Elab_All_Errors;
+
+ ---------------------
+ -- Find_Elab_Order --
+ ---------------------
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
+ Best_So_Far : Unit_Id;
+ U : Unit_Id;
+
+ begin
+ -- Gather dependencies and output them if option set
+
+ Gather_Dependencies;
+
+ Compute_Unit_SCCs;
+
+ -- Initialize the no predecessor list
+
+ No_Pred := No_Unit_Id;
+ for U in UNR.First .. UNR.Last loop
+ if UNR.Table (U).Num_Pred = 0 then
+ UNR.Table (U).Nextnp := No_Pred;
+ No_Pred := U;
+ end if;
+ end loop;
+
+ -- OK, now we determine the elaboration order proper. All we do is to
+ -- select the best choice from the no predecessor list until all the
+ -- nodes have been chosen.
+
+ Outer : loop
+
+ -- If there are no nodes with predecessors, then either we are
+ -- done, as indicated by Num_Left being set to zero, or we have
+ -- a circularity. In the latter case, diagnose the circularity,
+ -- removing it from the graph and continue.
+ -- ????But Diagnose_Elaboration_Problem always raises an
+ -- exception.
+
+ Get_No_Pred : while No_Pred = No_Unit_Id loop
+ exit Outer when Num_Left < 1;
+ Diagnose_Elaboration_Problem (Elab_Order);
+ end loop Get_No_Pred;
+
+ U := No_Pred;
+ Best_So_Far := No_Unit_Id;
+
+ -- Loop to choose best entry in No_Pred list
+
+ No_Pred_Search : loop
+ if Debug_Flag_N then
+ Write_Str (" considering choice of ");
+ Write_Unit_Name (Units.Table (U).Uname);
+ Write_Eol;
+
+ if Units.Table (U).Elaborate_Body then
+ Write_Str
+ (" Elaborate_Body = True, Num_Pred for body = ");
+ Write_Int
+ (UNR.Table (Corresponding_Body (U)).Num_Pred);
+ else
+ Write_Str
+ (" Elaborate_Body = False");
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- Don't even consider units whose SCC is not ready. This
+ -- ensures that all units of an SCC will be elaborated
+ -- together, with no other units in between.
+
+ if SCC_Num_Pred (U) = 0
+ and then Better_Choice (U, Best_So_Far)
+ then
+ if Debug_Flag_N then
+ Write_Str (" tentatively chosen (best so far)");
+ Write_Eol;
+ end if;
+
+ Best_So_Far := U;
+ end if;
+
+ U := UNR.Table (U).Nextnp;
+ exit No_Pred_Search when U = No_Unit_Id;
+ end loop No_Pred_Search;
+
+ -- Choose the best candidate found
+
+ Choose (Elab_Order, Best_So_Far);
+
+ -- If it's a spec with a body, and the body is not yet chosen,
+ -- choose the body if possible. The case where the body is
+ -- already chosen is Elaborate_Body; the above call to Choose
+ -- the spec will also Choose the body.
+
+ if Units.Table (Best_So_Far).Utype = Is_Spec
+ and then UNR.Table
+ (Corresponding_Body (Best_So_Far)).Elab_Position = 0
+ then
+ declare
+ Choose_The_Body : constant Boolean :=
+ UNR.Table (Corresponding_Body
+ (Best_So_Far)).Num_Pred = 0;
+
+ begin
+ if Debug_Flag_B then
+ Write_Str ("Can we choose the body?... ");
+
+ if Choose_The_Body then
+ Write_Line ("Yes!");
+ else
+ Write_Line ("No.");
+ end if;
+ end if;
+
+ if Choose_The_Body then
+ Choose (Elab_Order, Corresponding_Body (Best_So_Far));
+ end if;
+ end;
+ end if;
+
+ -- Finally, choose all the rest of the units in the same SCC as
+ -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
+ -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
+
+ loop
+ declare
+ Chose_One_Or_More : Boolean := False;
+ SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
+
+ begin
+ for J in SCC'Range loop
+ if UNR.Table (SCC (J)).Elab_Position = 0
+ and then UNR.Table (SCC (J)).Num_Pred = 0
+ then
+ Chose_One_Or_More := True;
+ Choose (Elab_Order, SCC (J));
+ end if;
+ end loop;
+
+ exit when not Chose_One_Or_More;
+ end;
+ end loop;
+ end loop Outer;
+
+ Find_Elab_All_Errors;
+ end Find_Elab_Order;
+
+ -----------
+ -- Nodes --
+ -----------
+
+ function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
+ begin
+ return UNR.Table (SCC (U)).Nodes;
+ end Nodes;
+
+ ---------
+ -- SCC --
+ ---------
+
+ function SCC (U : Unit_Id) return Unit_Id is
+ begin
+ return UNR.Table (U).SCC_Root;
+ end SCC;
+
+ ------------------
+ -- SCC_Num_Pred --
+ ------------------
+
+ function SCC_Num_Pred (U : Unit_Id) return Int is
+ begin
+ return UNR.Table (SCC (U)).SCC_Num_Pred;
+ end SCC_Num_Pred;
+
+ ---------------
+ -- Write_SCC --
+ ---------------
+
+ procedure Write_SCC (U : Unit_Id) is
+ pragma Assert (SCC (U) = U);
+ begin
+ for J in Nodes (U)'Range loop
+ Write_Int (Int (UNR.Table (Nodes (U) (J)).Elab_Position));
+ Write_Str (". ");
+ Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
+ Write_Eol;
+ end loop;
+
+ Write_Eol;
+ end Write_SCC;
+
+ end Elab_New;
+
+ --------------
+ -- Elab_Old --
+ --------------
+
+ package body Elab_Old is
+
+ ---------------------
+ -- Find_Elab_Order --
+ ---------------------
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
+ Best_So_Far : Unit_Id;
+ U : Unit_Id;
+
+ begin
+ -- Gather dependencies and output them if option set
+
+ Gather_Dependencies;
+
+ -- Initialize the no predecessor list
+
+ No_Pred := No_Unit_Id;
+ for U in UNR.First .. UNR.Last loop
+ if UNR.Table (U).Num_Pred = 0 then
+ UNR.Table (U).Nextnp := No_Pred;
+ No_Pred := U;
+ end if;
+ end loop;
+
+ -- OK, now we determine the elaboration order proper. All we do is to
+ -- select the best choice from the no predecessor list until all the
+ -- nodes have been chosen.
+
+ Outer : loop
+
+ -- If there are no nodes with predecessors, then either we are
+ -- done, as indicated by Num_Left being set to zero, or we have
+ -- a circularity. In the latter case, diagnose the circularity,
+ -- removing it from the graph and continue.
+ -- ????But Diagnose_Elaboration_Problem always raises an
+ -- exception.
+
+ Get_No_Pred : while No_Pred = No_Unit_Id loop
+ exit Outer when Num_Left < 1;
+ Diagnose_Elaboration_Problem (Elab_Order);
+ end loop Get_No_Pred;
+
+ U := No_Pred;
+ Best_So_Far := No_Unit_Id;
+
+ -- Loop to choose best entry in No_Pred list
+
+ No_Pred_Search : loop
+ if Debug_Flag_N then
+ Write_Str (" considering choice of ");
+ Write_Unit_Name (Units.Table (U).Uname);
+ Write_Eol;
+
+ if Units.Table (U).Elaborate_Body then
+ Write_Str
+ (" Elaborate_Body = True, Num_Pred for body = ");
+ Write_Int
+ (UNR.Table (Corresponding_Body (U)).Num_Pred);
+ else
+ Write_Str
+ (" Elaborate_Body = False");
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- This is a candididate to be considered for choice
+
+ if Better_Choice (U, Best_So_Far) then
+ if Debug_Flag_N then
+ Write_Str (" tentatively chosen (best so far)");
+ Write_Eol;
+ end if;
+
+ Best_So_Far := U;
+ end if;
+
+ U := UNR.Table (U).Nextnp;
+ exit No_Pred_Search when U = No_Unit_Id;
+ end loop No_Pred_Search;
+
+ -- Choose the best candidate found
+
+ Choose (Elab_Order, Best_So_Far);
+ end loop Outer;
+ end Find_Elab_Order;
+
+ end Elab_Old;
+
end Binde;
diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads
index 4481ef20707..79d9cdf0c90 100644
--- a/gcc/ada/binde.ads
+++ b/gcc/ada/binde.ads
@@ -23,30 +23,38 @@
-- --
------------------------------------------------------------------------------
--- This package contains the routines to determine elaboration order
+-- This package contains the routine that determines library-level elaboration
+-- order.
with ALI; use ALI;
-with Table;
+with Namet; use Namet;
with Types; use Types;
+with GNAT.Dynamic_Tables;
+
package Binde is
- -- The following table records the chosen elaboration order. It is used
- -- by Gen_Elab_Calls to generate the sequence of elaboration calls. Note
- -- that units are included in this table even if they have no elaboration
+ package Unit_Id_Tables is new GNAT.Dynamic_Tables
+ (Table_Component_Type => Unit_Id,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 500,
+ Table_Increment => 200);
+ use Unit_Id_Tables;
+
+ subtype Unit_Id_Table is Unit_Id_Tables.Instance;
+ subtype Unit_Id_Array is Unit_Id_Tables.Table_Type;
+
+ procedure Find_Elab_Order
+ (Elab_Order : out Unit_Id_Table;
+ First_Main_Lib_File : File_Name_Type);
+ -- Determine elaboration order.
+ --
+ -- The Elab_Order table records the chosen elaboration order. It is used by
+ -- Gen_Elab_Calls to generate the sequence of elaboration calls. Note that
+ -- units are included in this table even if they have no elaboration
-- routine, since the table is also used to drive the generation of object
-- files in the binder output. Gen_Elab_Calls skips any units that have no
-- elaboration routine.
- package Elab_Order is new Table.Table (
- Table_Component_Type => Unit_Id,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 500,
- Table_Increment => 200,
- Table_Name => "Elab_Order");
-
- procedure Find_Elab_Order;
- -- Determine elaboration order
-
end Binde;
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index 0955b1aba4a..d6c9a83d7dc 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with ALI; use ALI;
-with Binde; use Binde;
with Casing; use Casing;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
@@ -47,12 +46,13 @@ with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
with GNAT.HTable;
package body Bindgen is
+ use Binde.Unit_Id_Tables;
Statement_Buffer : String (1 .. 1000);
-- Buffer used for constructing output statements
- Last : Natural := 0;
- -- Last location in Statement_Buffer currently set
+ Stm_Last : Natural := 0;
+ -- Stm_Last location in Statement_Buffer currently set
With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library
@@ -113,13 +113,13 @@ package body Bindgen is
-- that the information is consistent across units. The entries
-- in this table are n/u/r/s for not set/user/runtime/system.
- package IS_Pragma_Settings is new Table.Table (
- Table_Component_Type => Character,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "IS_Pragma_Settings");
+ package IS_Pragma_Settings is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "IS_Pragma_Settings");
-- This table assembles the Priority_Specific_Dispatching pragma
-- information from all the units in the partition. Note that Bcheck has
@@ -127,13 +127,13 @@ package body Bindgen is
-- The entries in this table are the upper case first character of the
-- policy name, e.g. 'F' for FIFO_Within_Priorities.
- package PSD_Pragma_Settings is new Table.Table (
- Table_Component_Type => Character,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "PSD_Pragma_Settings");
+ package PSD_Pragma_Settings is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "PSD_Pragma_Settings");
----------------------------
-- Bind_Environment Table --
@@ -271,7 +271,7 @@ package body Bindgen is
-- Local Subprograms --
-----------------------
- procedure Gen_Adainit;
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array);
-- Generates the Adainit procedure
procedure Gen_Adafinal;
@@ -283,27 +283,29 @@ package body Bindgen is
procedure Gen_CodePeer_Wrapper;
-- For CodePeer, generate wrapper which calls user-defined main subprogram
- procedure Gen_Elab_Calls;
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array);
-- Generate sequence of elaboration calls
- procedure Gen_Elab_Externals;
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array);
-- Generate sequence of external declarations for elaboration
- procedure Gen_Elab_Order;
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array);
-- Generate comments showing elaboration order chosen
- procedure Gen_Finalize_Library;
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array);
-- Generate a sequence of finalization calls to elaborated packages
procedure Gen_Main;
-- Generate procedure main
- procedure Gen_Object_Files_Options;
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array);
-- Output comments containing a list of the full names of the object
-- files to be linked and the list of linker options supplied by
-- Linker_Options pragmas in the source.
- procedure Gen_Output_File_Ada (Filename : String);
+ procedure Gen_Output_File_Ada
+ (Filename : String;
+ Elab_Order : Unit_Id_Array);
-- Generate Ada output file
procedure Gen_Restrictions;
@@ -335,11 +337,11 @@ package body Bindgen is
-- the encoding method used for the main program source. If there is no
-- main program source (-z switch used), returns brackets ('b').
- function Has_Finalizer return Boolean;
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean;
-- Determine whether the current unit has at least one library-level
-- finalizer.
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
-- Is_Internal_File (internal files come later) and then by
-- elaboration order position (latest to earliest).
@@ -347,21 +349,21 @@ package body Bindgen is
procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options
- procedure Resolve_Binder_Options;
+ procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array);
-- Set the value of With_GNARL
procedure Set_Char (C : Character);
- -- Set given character in Statement_Buffer at the Last + 1 position
- -- and increment Last by one to reflect the stored character.
+ -- Set given character in Statement_Buffer at the Stm_Last + 1 position
+ -- and increment Stm_Last by one to reflect the stored character.
procedure Set_Int (N : Int);
-- Set given value in decimal in Statement_Buffer with no spaces starting
- -- at the Last + 1 position, and updating Last past the value. A minus sign
- -- is output for a negative value.
+ -- at the Stm_Last + 1 position, and updating Stm_Last past the value. A
+ -- minus sign is output for a negative value.
procedure Set_Boolean (B : Boolean);
- -- Set given boolean value in Statement_Buffer at the Last + 1 position
- -- and update Last past the value.
+ -- Set given boolean value in Statement_Buffer at the Stm_Last + 1 position
+ -- and update Stm_Last past the value.
procedure Set_IS_Pragma_Table;
-- Initializes contents of IS_Pragma_Settings table from ALI table
@@ -369,7 +371,7 @@ package body Bindgen is
procedure Set_Main_Program_Name;
-- Given the main program name in Name_Buffer (length in Name_Len) generate
-- the name of the routine to be used in the call. The name is generated
- -- starting at Last + 1, and Last is updated past it.
+ -- starting at Stm_Last + 1, and Stm_Last is updated past it.
procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
@@ -379,7 +381,7 @@ package body Bindgen is
procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the
- -- Last + 1 position, and updating last past the string value.
+ -- Stm_Last + 1 position, and updating last past the string value.
procedure Set_String_Replace (S : String);
-- Replaces the last S'Length characters in the Statement_Buffer with the
@@ -388,8 +390,8 @@ package body Bindgen is
procedure Set_Unit_Name;
-- Given a unit name in the Name_Buffer, copy it into Statement_Buffer,
- -- starting at the Last + 1 position and update Last past the value.
- -- Each dot (.) will be qualified into double underscores (__).
+ -- starting at the Stm_Last + 1 position and update Stm_Last past the
+ -- value. Each dot (.) will be qualified into double underscores (__).
procedure Set_Unit_Number (U : Unit_Id);
-- Sets unit number (first unit is 1, leading zeroes output to line up all
@@ -397,11 +399,12 @@ package body Bindgen is
-- number of units.
procedure Write_Statement_Buffer;
- -- Write out contents of statement buffer up to Last, and reset Last to 0
+ -- Write out contents of statement buffer up to Stm_Last, and reset
+ -- Stm_Last to 0.
procedure Write_Statement_Buffer (S : String);
-- First writes its argument (using Set_String (S)), then writes out the
- -- contents of statement buffer up to Last, and reset Last to 0
+ -- contents of statement buffer up to Stm_Last, and reset Stm_Last to 0
procedure Write_Bind_Line (S : String);
-- Write S (an LF-terminated string) to the binder file (for use with
@@ -472,7 +475,7 @@ package body Bindgen is
-- Gen_Adainit --
-----------------
- procedure Gen_Adainit is
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array) is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
@@ -892,8 +895,8 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
- -- Initialize stack limit variable of the environment task if the
- -- stack check method is stack limit and stack check is enabled.
+ -- Initialize stack limit variable of the environment task if the stack
+ -- check method is stack limit and stack check is enabled.
if Stack_Check_Limits_On_Target
and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
@@ -934,7 +937,7 @@ package body Bindgen is
WBI ("");
end if;
- Gen_Elab_Calls;
+ Gen_Elab_Calls (Elab_Order);
if not CodePeer_Mode then
@@ -980,9 +983,6 @@ package body Bindgen is
-------------------------
procedure Gen_Bind_Env_String is
- KN, VN : Name_Id := No_Name;
- Amp : Character;
-
procedure Write_Name_With_Len (Nam : Name_Id);
-- Write Nam as a string literal, prefixed with one
-- character encoding Nam's length.
@@ -1002,10 +1002,17 @@ package body Bindgen is
Write_String_Table_Entry (End_String);
end Write_Name_With_Len;
+ -- Local variables
+
+ Amp : Character;
+ KN : Name_Id := No_Name;
+ VN : Name_Id := No_Name;
+
-- Start of processing for Gen_Bind_Env_String
begin
Bind_Environment.Get_First (KN, VN);
+
if VN = No_Name then
return;
end if;
@@ -1058,15 +1065,15 @@ package body Bindgen is
-- Gen_Elab_Calls --
--------------------
- procedure Gen_Elab_Calls is
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array) is
Check_Elab_Flag : Boolean;
begin
-- Loop through elaboration order entries
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
Unum_Spec : Unit_Id;
@@ -1241,15 +1248,15 @@ package body Bindgen is
-- Gen_Elab_Externals --
------------------------
- procedure Gen_Elab_Externals is
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array) is
begin
if CodePeer_Mode then
return;
end if;
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
begin
@@ -1289,13 +1296,13 @@ package body Bindgen is
-- Gen_Elab_Order --
--------------------
- procedure Gen_Elab_Order is
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array) is
begin
WBI (" -- BEGIN ELABORATION ORDER");
- for J in Elab_Order.First .. Elab_Order.Last loop
+ for J in Elab_Order'Range loop
Set_String (" -- ");
- Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
+ Get_Name_String (Units.Table (Elab_Order (J)).Uname);
Set_Name_Buffer;
Write_Statement_Buffer;
end loop;
@@ -1308,12 +1315,7 @@ package body Bindgen is
-- Gen_Finalize_Library --
--------------------------
- procedure Gen_Finalize_Library is
- Count : Int := 1;
- U : Unit_Record;
- Uspec : Unit_Record;
- Unum : Unit_Id;
-
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array) is
procedure Gen_Header;
-- Generate the header of the finalization routine
@@ -1327,6 +1329,13 @@ package body Bindgen is
WBI (" begin");
end Gen_Header;
+ -- Local variables
+
+ Count : Int := 1;
+ U : Unit_Record;
+ Uspec : Unit_Record;
+ Unum : Unit_Id;
+
-- Start of processing for Gen_Finalize_Library
begin
@@ -1334,8 +1343,8 @@ package body Bindgen is
return;
end if;
- for E in reverse Elab_Order.First .. Elab_Order.Last loop
- Unum := Elab_Order.Table (E);
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
U := Units.Table (Unum);
-- Dealing with package bodies is a little complicated. In such
@@ -1634,11 +1643,11 @@ package body Bindgen is
end if;
end if;
- -- Generate a reference to Ada_Main_Program_Name. This symbol is
- -- not referenced elsewhere in the generated program, but is needed
- -- by the debugger (that's why it is generated in the first place).
- -- The reference stops Ada_Main_Program_Name from being optimized
- -- away by smart linkers, such as the AiX linker.
+ -- Generate a reference to Ada_Main_Program_Name. This symbol is not
+ -- referenced elsewhere in the generated program, but is needed by
+ -- the debugger (that's why it is generated in the first place). The
+ -- reference stops Ada_Main_Program_Name from being optimized away by
+ -- smart linkers, such as the AiX linker.
-- Because this variable is unused, we make this variable "aliased"
-- with a pragma Volatile in order to tell the compiler to preserve
@@ -1664,9 +1673,9 @@ package body Bindgen is
WBI (" gnat_envp := envp;");
WBI ("");
- -- If configurable run time and no command line args, then nothing
- -- needs to be done since the gnat_argc/argv/envp variables are
- -- suppressed in this case.
+ -- If configurable run time and no command line args, then nothing needs
+ -- to be done since the gnat_argc/argv/envp variables are suppressed in
+ -- this case.
elsif Configurable_Run_Time_On_Target then
null;
@@ -1767,11 +1776,11 @@ package body Bindgen is
-- Gen_Object_Files_Options --
------------------------------
- procedure Gen_Object_Files_Options is
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array) is
Lgnat : Natural;
- -- This keeps track of the position in the sorted set of entries
- -- in the Linker_Options table of where the first entry from an
- -- internal file appears.
+ -- This keeps track of the position in the sorted set of entries in the
+ -- Linker_Options table of where the first entry from an internal file
+ -- appears.
Linker_Option_List_Started : Boolean := False;
-- Set to True when "LINKER OPTION LIST" is displayed
@@ -1836,17 +1845,17 @@ package body Bindgen is
Set_List_File (Object_List_Filename.all);
end if;
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
-- If not spec that has an associated body, then generate a comment
-- giving the name of the corresponding object file.
- if not Units.Table (Elab_Order.Table (E)).SAL_Interface
- and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
+ if not Units.Table (Elab_Order (E)).SAL_Interface
+ and then Units.Table (Elab_Order (E)).Utype /= Is_Spec
then
Get_Name_String
(ALIs.Table
- (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
+ (Units.Table (Elab_Order (E)).My_ALI).Ofile_Full_Name);
-- If the presence of an object file is necessary or if it exists,
-- then use it.
@@ -1874,6 +1883,7 @@ package body Bindgen is
for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
declare
Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
+
begin
Name_Len := 0;
Add_Str_To_Name_Buffer ("-L");
@@ -1996,7 +2006,10 @@ package body Bindgen is
-- Gen_Output_File --
---------------------
- procedure Gen_Output_File (Filename : String) is
+ procedure Gen_Output_File
+ (Filename : String;
+ Elab_Order : Unit_Id_Array)
+ is
begin
-- Acquire settings for Interrupt_State pragmas
@@ -2014,8 +2027,8 @@ package body Bindgen is
-- Count number of elaboration calls
- for E in Elab_Order.First .. Elab_Order.Last loop
- if Units.Table (Elab_Order.Table (E)).No_Elab then
+ for E in Elab_Order'Range loop
+ if Units.Table (Elab_Order (E)).No_Elab then
null;
else
Num_Elab_Calls := Num_Elab_Calls + 1;
@@ -2024,21 +2037,23 @@ package body Bindgen is
-- Generate output file in appropriate language
- Gen_Output_File_Ada (Filename);
+ Gen_Output_File_Ada (Filename, Elab_Order);
end Gen_Output_File;
-------------------------
-- Gen_Output_File_Ada --
-------------------------
- procedure Gen_Output_File_Ada (Filename : String) is
-
+ procedure Gen_Output_File_Ada
+ (Filename : String; Elab_Order : Unit_Id_Array)
+ is
Ada_Main : constant String := Get_Ada_Main_Name;
-- Name to be used for generated Ada main program. See the body of
-- function Get_Ada_Main_Name for details on the form of the name.
Needs_Library_Finalization : constant Boolean :=
- not Configurable_Run_Time_On_Target and then Has_Finalizer;
+ not Configurable_Run_Time_On_Target
+ and then Has_Finalizer (Elab_Order);
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want finalization.
@@ -2096,7 +2111,7 @@ package body Bindgen is
WBI ("with System.Secondary_Stack;");
end if;
- Resolve_Binder_Options;
+ Resolve_Binder_Options (Elab_Order);
-- Generate standard with's
@@ -2240,7 +2255,7 @@ package body Bindgen is
end if;
Gen_Versions;
- Gen_Elab_Order;
+ Gen_Elab_Order (Elab_Order);
-- Spec is complete
@@ -2323,7 +2338,7 @@ package body Bindgen is
-- Generate externals for elaboration entities
- Gen_Elab_Externals;
+ Gen_Elab_Externals (Elab_Order);
if not CodePeer_Mode then
if not Suppress_Standard_Library_On_Target then
@@ -2375,13 +2390,13 @@ package body Bindgen is
if not Cumulative_Restrictions.Set (No_Finalization) then
if Needs_Library_Finalization then
- Gen_Finalize_Library;
+ Gen_Finalize_Library (Elab_Order);
end if;
Gen_Adafinal;
end if;
- Gen_Adainit;
+ Gen_Adainit (Elab_Order);
if Bind_Main_Program then
Gen_Main;
@@ -2389,7 +2404,7 @@ package body Bindgen is
-- Output object file list and the Ada body is complete
- Gen_Object_Files_Options;
+ Gen_Object_Files_Options (Elab_Order);
WBI ("");
WBI ("end " & Ada_Main & ";");
@@ -2519,8 +2534,8 @@ package body Bindgen is
WBI (" type Version_32 is mod 2 ** 32;");
for U in Units.First .. Units.Last loop
if not Units.Table (U).SAL_Interface
- and then
- (not Bind_For_Library or else Units.Table (U).Directly_Scanned)
+ and then (not Bind_For_Library
+ or else Units.Table (U).Directly_Scanned)
then
Increment_Ubuf;
WBI (" " & Ubuf & " : constant Version_32 := 16#" &
@@ -2580,19 +2595,20 @@ package body Bindgen is
function Get_Ada_Main_Name return String is
Suffix : constant String := "_00";
Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
- Opt.Ada_Main_Name.all & Suffix;
+ Opt.Ada_Main_Name.all & Suffix;
Nlen : Natural;
begin
- -- For CodePeer, we want reproducible names (independent of other
- -- mains that may or may not be present) that don't collide
- -- when analyzing multiple mains and which are easily recognizable
- -- as "ada_main" names.
+ -- For CodePeer, we want reproducible names (independent of other mains
+ -- that may or may not be present) that don't collide when analyzing
+ -- multiple mains and which are easily recognizable as "ada_main" names.
if CodePeer_Mode then
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- return "ada_main_for_" &
- Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
+
+ return
+ "ada_main_for_" &
+ Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
end if;
-- This loop tries the following possibilities in order
@@ -2713,13 +2729,13 @@ package body Bindgen is
-- Has_Finalizer --
-------------------
- function Has_Finalizer return Boolean is
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean is
U : Unit_Record;
Unum : Unit_Id;
begin
- for E in reverse Elab_Order.First .. Elab_Order.Last loop
- Unum := Elab_Order.Table (E);
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
U := Units.Table (Unum);
-- We are only interested in non-generic packages
@@ -2749,7 +2765,7 @@ package body Bindgen is
-- Lt_Linker_Option --
----------------------
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean is
begin
-- Sort internal files last
@@ -2771,7 +2787,6 @@ package body Bindgen is
return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
>
Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
-
end if;
end Lt_Linker_Option;
@@ -2788,8 +2803,7 @@ package body Bindgen is
-- Resolve_Binder_Options --
----------------------------
- procedure Resolve_Binder_Options is
-
+ procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array) is
procedure Check_Package (Var : in out Boolean; Name : String);
-- Set Var to true iff the current identifier in Namet is Name. Do
-- nothing if it doesn't match. This procedure is just a helper to
@@ -2811,8 +2825,8 @@ package body Bindgen is
-- Start of processing for Resolve_Binder_Options
begin
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
+ for E in Elab_Order'Range loop
+ Get_Name_String (Units.Table (Elab_Order (E)).Uname);
-- This is not a perfect approach, but is the current protocol
-- between the run-time and the binder to indicate that tasking is
@@ -2873,15 +2887,18 @@ package body Bindgen is
-----------------
procedure Set_Boolean (B : Boolean) is
- True_Str : constant String := "True";
False_Str : constant String := "False";
+ True_Str : constant String := "True";
+
begin
if B then
- Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
- Last := Last + True_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + True_Str'Length) :=
+ True_Str;
+ Stm_Last := Stm_Last + True_Str'Length;
else
- Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
- Last := Last + False_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + False_Str'Length) :=
+ False_Str;
+ Stm_Last := Stm_Last + False_Str'Length;
end if;
end Set_Boolean;
@@ -2891,8 +2908,8 @@ package body Bindgen is
procedure Set_Char (C : Character) is
begin
- Last := Last + 1;
- Statement_Buffer (Last) := C;
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) := C;
end Set_Char;
-------------
@@ -2910,8 +2927,8 @@ package body Bindgen is
Set_Int (N / 10);
end if;
- Last := Last + 1;
- Statement_Buffer (Last) :=
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) :=
Character'Val (N mod 10 + Character'Pos ('0'));
end if;
end Set_Int;
@@ -2928,9 +2945,9 @@ package body Bindgen is
loop
declare
Inum : constant Int :=
- Interrupt_States.Table (K).Interrupt_Id;
+ Interrupt_States.Table (K).Interrupt_Id;
Stat : constant Character :=
- Interrupt_States.Table (K).Interrupt_State;
+ Interrupt_States.Table (K).Interrupt_State;
begin
while IS_Pragma_Settings.Last < Inum loop
@@ -2951,8 +2968,8 @@ package body Bindgen is
begin
-- Note that name has %b on the end which we ignore
- -- First we output the initial _ada_ since we know that the main
- -- program is a library level subprogram.
+ -- First we output the initial _ada_ since we know that the main program
+ -- is a library level subprogram.
Set_String ("_ada_");
@@ -3011,8 +3028,8 @@ package body Bindgen is
procedure Set_String (S : String) is
begin
- Statement_Buffer (Last + 1 .. Last + S'Length) := S;
- Last := Last + S'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + S'Length) := S;
+ Stm_Last := Stm_Last + S'Length;
end Set_String;
------------------------
@@ -3021,7 +3038,7 @@ package body Bindgen is
procedure Set_String_Replace (S : String) is
begin
- Statement_Buffer (Last - S'Length + 1 .. Last) := S;
+ Statement_Buffer (Stm_Last - S'Length + 1 .. Stm_Last) := S;
end Set_String_Replace;
-------------------
@@ -3076,8 +3093,8 @@ package body Bindgen is
procedure Write_Statement_Buffer is
begin
- WBI (Statement_Buffer (1 .. Last));
- Last := 0;
+ WBI (Statement_Buffer (1 .. Stm_Last));
+ Stm_Last := 0;
end Write_Statement_Buffer;
procedure Write_Statement_Buffer (S : String) is
diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads
index 2f4cc78c483..070c7fc4f1c 100644
--- a/gcc/ada/bindgen.ads
+++ b/gcc/ada/bindgen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
@@ -32,9 +32,13 @@
-- See the body for exact details of the file that is generated
+with Binde; use Binde;
+
package Bindgen is
- procedure Gen_Output_File (Filename : String);
+ procedure Gen_Output_File
+ (Filename : String;
+ Elab_Order : Unit_Id_Array);
-- Filename is the full path name of the binder output file
procedure Set_Bind_Env (Key, Value : String);
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index bfb1ab45bbd..4e1f0fc9810 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -181,14 +181,14 @@ package body Debug is
-- dl
-- dm
-- dn List details of manipulation of Num_Pred values
- -- do Use old preference for elaboration order
- -- dp
+ -- do Use older preference for elaboration order
+ -- dp Use new preference for elaboration order
-- dq
-- dr
-- ds
-- dt
-- du List units as they are acquired
- -- dv
+ -- dv Verbose debugging printouts
-- dw
-- dx Force binder to read xref information from ali files
-- dy
@@ -809,14 +809,25 @@ package body Debug is
-- the algorithm used to determine a correct order of elaboration. This
-- is useful in diagnosing any problems in its behavior.
- -- do Use old elaboration order preference. The new preference rules
+ -- do Use older elaboration order preference. The new preference rules
-- prefer specs with no bodies to specs with bodies, and between two
-- specs with bodies, prefers the one whose body is closer to being
-- able to be elaborated. This is a clear improvement, but we provide
-- this debug flag in case of regressions.
+ -- dp Use new elaboration order preference. The new preference rules
+ -- elaborate all units within a strongly connected component together,
+ -- with no other units in between. In particular, if a spec/body pair
+ -- can be elaborated together, it will be. In the new order, the binder
+ -- behaves as if every pragma Elaborate_All that would be legal is
+ -- present, even if it does not appear in the source code. NOTE: We
+ -- intend to reverse the sense of this switch at some point, so the new
+ -- preference is the default.
+
-- du List unit name and file name for each unit as it is read in
+ -- dv Verbose debugging printouts
+
-- dx Force the binder to read (and then ignore) the xref information
-- in ali files (used to check that read circuit is working OK).
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index d3820afe4f9..c0ff37122ee 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -670,14 +670,13 @@ package Einfo is
-- stored in a non-standard way, see body for details.
-- Component_Bit_Offset (Uint11)
--- Defined in record components (E_Component, E_Discriminant) if a
--- component clause applies to the component. First bit position of
--- given component, computed from the first bit and position values
--- given in the component clause. A value of No_Uint means that the
--- value is not yet known. The value can be set by the appearance of
--- an explicit component clause in a record representation clause,
--- or it can be set by the front-end in package Layout, or it can be
--- set by the backend. By the time backend processing is completed,
+-- Defined in record components (E_Component, E_Discriminant). First
+-- bit position of given component, computed from the first bit and
+-- position values given in the component clause. A value of No_Uint
+-- means that the value is not yet known. The value can be set by the
+-- appearance of an explicit component clause in a record representation
+-- clause, or it can be set by the front-end in package Layout, or it can
+-- be set by the backend. By the time backend processing is completed,
-- this field is always set. A negative value is used to represent
-- a value which is not known at compile time, and must be computed
-- at run-time (this happens if fields of a record have variable
diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads
index b8213cdb0d8..3e52cc0625f 100644
--- a/gcc/ada/g-locfil.ads
+++ b/gcc/ada/g-locfil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2010, AdaCore --
+-- Copyright (C) 1995-2016, AdaCore --
-- --
-- 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- --
@@ -39,7 +39,7 @@ package GNAT.Lock_Files is
-- Exception raised if file cannot be locked
subtype Path_Name is String;
- -- Pathname is used by all services provided in this unit to specified
+ -- Pathname is used by all services provided in this unit to specify
-- directory name and file name. On DOS based systems both directory
-- separators are handled (i.e. slash and backslash).
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index 7d9875173cc..ebe87c11f0e 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -30,12 +30,10 @@ with Binde; use Binde;
with Binderr; use Binderr;
with Bindgen; use Bindgen;
with Bindusg;
-with Butil; use Butil;
with Casing; use Casing;
with Csets;
with Debug; use Debug;
with Fmap;
-with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
@@ -45,7 +43,6 @@ with Rident; use Rident;
with Snames;
with Switch; use Switch;
with Switch.B; use Switch.B;
-with Table;
with Targparm; use Targparm;
with Types; use Types;
@@ -76,22 +73,15 @@ procedure Gnatbind is
Mapping_File : String_Ptr := null;
- package Closure_Sources is new Table.Table
- (Table_Component_Type => File_Name_Type,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Gnatbind.Closure_Sources");
- -- Table to record the sources in the closure, to avoid duplications. Used
- -- only with switch -R.
-
procedure Add_Artificial_ALI_File (Name : String);
-- Artificially add ALI file Name in the closure
function Gnatbind_Supports_Auto_Init return Boolean;
- -- Indicates if automatic initialization of elaboration procedure
- -- through the constructor mechanism is possible on the platform.
+ -- Indicates if automatic initialization of elaboration procedure through
+ -- the constructor mechanism is possible on the platform.
+
+ function Is_Cross_Compiler return Boolean;
+ -- Returns True iff this is a cross-compiler
procedure List_Applicable_Restrictions;
-- List restrictions that apply to this partition if option taken
@@ -110,9 +100,6 @@ procedure Gnatbind is
procedure Write_Arg (S : String);
-- Passed to Generic_Scan_Bind_Args to print args
- function Is_Cross_Compiler return Boolean;
- -- Returns True iff this is a cross-compiler
-
-----------------------------
-- Add_Artificial_ALI_File --
-----------------------------
@@ -149,6 +136,7 @@ procedure Gnatbind is
function gnat_binder_supports_auto_init return Integer;
pragma Import (C, gnat_binder_supports_auto_init,
"__gnat_binder_supports_auto_init");
+
begin
return gnat_binder_supports_auto_init /= 0;
end Gnatbind_Supports_Auto_Init;
@@ -160,6 +148,7 @@ procedure Gnatbind is
function Is_Cross_Compiler return Boolean is
Cross_Compiler : Integer;
pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler");
+
begin
return Cross_Compiler = 1;
end Is_Cross_Compiler;
@@ -287,13 +276,13 @@ procedure Gnatbind is
for R in All_Restrictions loop
if not No_Restriction_List (R)
- and then Restriction_Could_Be_Set (R)
+ and then Restriction_Could_Be_Set (R)
then
if not Additional_Restrictions_Listed then
Write_Eol;
Write_Line
- ("The following additional restrictions may be" &
- " applied to this partition:");
+ ("The following additional restrictions may be applied to "
+ & "this partition:");
Additional_Restrictions_Listed := True;
end if;
@@ -301,6 +290,7 @@ procedure Gnatbind is
declare
S : constant String := Restriction_Id'Image (R);
+
begin
Name_Len := S'Length;
Name_Buffer (1 .. Name_Len) := S;
@@ -377,8 +367,8 @@ procedure Gnatbind is
else
Fail
- ("Prefix of initialization and finalization " &
- "procedure names missing in -L");
+ ("Prefix of initialization and finalization procedure names "
+ & "missing in -L");
end if;
-- -Sin -Slo -Shi -Sxx -Sev
@@ -560,12 +550,12 @@ procedure Gnatbind is
Write_Str (" " & S);
end Write_Arg;
- procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg);
- procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg);
-
procedure Check_Version_And_Help is
new Check_Version_And_Help_G (Bindusg.Display);
+ procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg);
+ procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg);
+
-- Start of processing for Gnatbind
begin
@@ -582,8 +572,8 @@ begin
begin
pragma Assert
(Shared_Libgnat_Default = SHARED
- or else
- Shared_Libgnat_Default = STATIC);
+ or else
+ Shared_Libgnat_Default = STATIC);
Shared_Libgnat := (Shared_Libgnat_Default = SHARED);
end;
@@ -618,8 +608,8 @@ begin
Fail ("switch -a must be used in conjunction with -n or -Lxxx");
elsif not Gnatbind_Supports_Auto_Init then
- Fail ("automatic initialisation of elaboration " &
- "not supported on this platform");
+ Fail ("automatic initialisation of elaboration not supported on this "
+ & "platform");
end if;
end if;
@@ -641,6 +631,7 @@ begin
Check_Extensions : declare
Length : constant Natural := Output_File_Name'Length;
Last : constant Natural := Output_File_Name'Last;
+
begin
if Length <= 4
or else Output_File_Name (Last - 3 .. Last) /= ".adb"
@@ -873,132 +864,19 @@ begin
-- Complete bind if no errors
if Errors_Detected = 0 then
- Find_Elab_Order;
-
- if Errors_Detected = 0 then
- -- Display elaboration order if -l was specified
-
- if Elab_Order_Output then
- if not Zero_Formatting then
- Write_Eol;
- Write_Str ("ELABORATION ORDER");
- Write_Eol;
- end if;
-
- for J in Elab_Order.First .. Elab_Order.Last loop
- if not Units.Table (Elab_Order.Table (J)).SAL_Interface then
- if not Zero_Formatting then
- Write_Str (" ");
- end if;
-
- Write_Unit_Name
- (Units.Table (Elab_Order.Table (J)).Uname);
- Write_Eol;
- end if;
- end loop;
-
- if not Zero_Formatting then
- Write_Eol;
- end if;
- end if;
-
- if not Check_Only then
- Gen_Output_File (Output_File_Name.all);
- end if;
+ declare
+ Elab_Order : Unit_Id_Table;
+ use Unit_Id_Tables;
- -- Display list of sources in the closure (except predefined
- -- sources) if -R was used.
-
- if List_Closure then
- List_Closure_Display : declare
- Source : File_Name_Type;
-
- function Put_In_Sources (S : File_Name_Type) return Boolean;
- -- Check if S is already in table Sources and put in Sources
- -- if it is not. Return False if the source is already in
- -- Sources, and True if it is added.
-
- --------------------
- -- Put_In_Sources --
- --------------------
-
- function Put_In_Sources
- (S : File_Name_Type) return Boolean
- is
- begin
- for J in 1 .. Closure_Sources.Last loop
- if Closure_Sources.Table (J) = S then
- return False;
- end if;
- end loop;
-
- Closure_Sources.Append (S);
- return True;
- end Put_In_Sources;
-
- -- Start of processing for List_Closure_Display
-
- begin
- Closure_Sources.Init;
-
- if not Zero_Formatting then
- Write_Eol;
- Write_Str ("REFERENCED SOURCES");
- Write_Eol;
- end if;
+ begin
+ Find_Elab_Order (Elab_Order, First_Main_Lib_File);
- for J in reverse Elab_Order.First .. Elab_Order.Last loop
- Source := Units.Table (Elab_Order.Table (J)).Sfile;
-
- -- Do not include same source more than once
-
- if Put_In_Sources (Source)
-
- -- Do not include run-time units unless -Ra switch set
-
- and then (List_Closure_All
- or else not Is_Internal_File_Name (Source))
- then
- if not Zero_Formatting then
- Write_Str (" ");
- end if;
-
- Write_Str (Get_Name_String (Source));
- Write_Eol;
- end if;
- end loop;
-
- -- Subunits do not appear in the elaboration table because
- -- they are subsumed by their parent units, but we need to
- -- list them for other tools. For now they are listed after
- -- other files, rather than right after their parent, since
- -- there is no easy link between the elaboration table and
- -- the ALIs table ??? As subunits may appear repeatedly in
- -- the list, if the parent unit appears in the context of
- -- several units in the closure, duplicates are suppressed.
-
- for J in Sdep.First .. Sdep.Last loop
- Source := Sdep.Table (J).Sfile;
-
- if Sdep.Table (J).Subunit_Name /= No_Name
- and then Put_In_Sources (Source)
- and then not Is_Internal_File_Name (Source)
- then
- if not Zero_Formatting then
- Write_Str (" ");
- end if;
-
- Write_Str (Get_Name_String (Source));
- Write_Eol;
- end if;
- end loop;
-
- if not Zero_Formatting then
- Write_Eol;
- end if;
- end List_Closure_Display;
+ if Errors_Detected = 0 and then not Check_Only then
+ Gen_Output_File
+ (Output_File_Name.all,
+ Elab_Order => Elab_Order.Table (First .. Last (Elab_Order)));
end if;
- end if;
+ end;
end if;
Total_Errors := Total_Errors + Errors_Detected;
@@ -1010,7 +888,7 @@ begin
Total_Warnings := Total_Warnings + Warnings_Detected;
end;
- -- All done. Set proper exit status
+ -- All done. Set the proper exit status.
Finalize_Binderr;
Namet.Finalize;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index ba47f92e4e4..55aea49bf2f 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -10374,15 +10374,26 @@ package body Sem_Ch13 is
Nbit := Sbit;
for J in 1 .. Ncomps loop
CEnt := Comps (J);
- Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit;
- if Error_Msg_Uint_1 > 0 then
- Error_Msg_NE
- ("?H?^-bit gap before component&",
- Component_Name (Component_Clause (CEnt)), CEnt);
- end if;
+ declare
+ CBO : constant Uint := Component_Bit_Offset (CEnt);
+
+ begin
+ -- Skip components with unknown offsets
+
+ if CBO /= No_Uint and then CBO >= 0 then
+ Error_Msg_Uint_1 := CBO - Nbit;
- Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt);
+ if Error_Msg_Uint_1 > 0 then
+ Error_Msg_NE
+ ("?H?^-bit gap before component&",
+ Component_Name (Component_Clause (CEnt)),
+ CEnt);
+ end if;
+
+ Nbit := CBO + Esize (CEnt);
+ end if;
+ end;
end loop;
-- Process variant parts recursively if present
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index d125bf2846d..7cb90bfc6da 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -274,6 +274,7 @@ package body Sem_Ch6 is
New_Spec : Node_Id;
Orig_N : Node_Id;
Ret : Node_Id;
+ Ret_Type : Entity_Id;
Prev : Entity_Id;
-- If the expression is a completion, Prev is the entity whose
@@ -366,16 +367,34 @@ package body Sem_Ch6 is
then
Set_Has_Completion (Prev, False);
Set_Is_Inlined (Prev);
+ Ret_Type := Etype (Prev);
-- An expression function that is a completion freezes the
- -- expression. This means freezing the return type, and if it is
- -- an access type, freezing its designated type as well.
+ -- expression. This means freezing the return type, and if it is an
+ -- access type, freezing its designated type as well.
-- Note that we cannot defer this freezing to the analysis of the
-- expression itself, because a freeze node might appear in a nested
-- scope, leading to an elaboration order issue in gigi.
- Freeze_Before (N, Etype (Prev));
+ -- An entity can only be frozen if it has a completion, so we must
+ -- check this explicitly. If it is declared elsewhere it will have
+ -- been frozen already, so only types declared in currently opend
+ -- scopes need to be tested.
+
+ if Ekind (Ret_Type) = E_Private_Type
+ and then In_Open_Scopes (Scope (Ret_Type))
+ and then not Is_Generic_Type (Ret_Type)
+ and then not Is_Frozen (Ret_Type)
+ and then No (Full_View (Ret_Type))
+ then
+ Error_Msg_NE
+ ("premature use of private type&",
+ Result_Definition (Specification (N)), Ret_Type);
+
+ else
+ Freeze_Before (N, Ret_Type);
+ end if;
if Is_Access_Type (Etype (Prev)) then
Freeze_Before (N, Designated_Type (Etype (Prev)));
View Lorry Controller Status