1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Binderr
; use Binderr
;
27 with Butil
; use Butil
;
28 with Debug
; use Debug
;
29 with Fname
; use Fname
;
32 with Output
; use Output
;
35 with System
.Case_Util
; use System
.Case_Util
;
41 -- We now have Elab_New, a new elaboration-order algorithm.
43 -- However, any change to elaboration order can break some programs.
44 -- Therefore, we are keeping the old algorithm in place, to be selected
47 -- The new algorithm has the following interesting properties:
49 -- * The static and dynamic models use the same elaboration order. The
50 -- static model might get an error, but if it does not, it will use
51 -- the same order as the dynamic model.
53 -- * Each SCC (see below) is elaborated together; that is, units from
54 -- different SCCs are not interspersed.
56 -- * In particular, this implies that if an SCC contains just a spec and
57 -- the corresponding body, and nothing else, the body will be
58 -- elaborated immediately after the spec. This is expected to result
59 -- in a better elaboration order for most programs, because in this
60 -- case, a call from outside the library unit cannot get ABE.
62 -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
63 -- we behave as if every legal pragma Elaborate_All were present. That
64 -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
65 -- then we behave as if such a pragma exists, even if it does not.
67 Do_Old
: constant Boolean := False;
68 Do_New
: constant Boolean := True;
69 -- True to enable the old and new algorithms, respectively. Used for
70 -- debugging/experimentation.
72 Doing_New
: Boolean := False;
73 -- True if we are currently doing the new algorithm. Print certain
74 -- messages only when doing the "new" elab order algorithm, so we don't get
75 -- duplicates. And use different heuristics in Better_Choice_Optimistic.
77 -- The following data structures are used to represent the graph that is
78 -- used to determine the elaboration order (using a topological sort).
80 -- The following structures are used to record successors. If B is a
81 -- successor of A in this table, it means that A must be elaborated before
82 -- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
83 -- will be a successor of X (spec), and X (spec) will be a predecessor of
86 -- Note that we store the successors of each unit explicitly. We don't
87 -- store the predecessors, but we store a count of them.
89 -- The basic algorithm is to first compute a directed graph of units (type
90 -- Unit_Node_Record, below), with successors as edges. A unit is "ready"
91 -- (to be chosen as the next to be elaborated) if it has no predecessors
92 -- that have not yet been chosen. We use heuristics to decide which of the
93 -- ready units should be elaborated next, and "choose" that one (which
94 -- means we append it to the elaboration-order table).
96 type Successor_Id
is new Nat
;
97 -- Identification of single successor entry
99 No_Successor
: constant Successor_Id
:= 0;
100 -- Used to indicate end of list of successors
102 type Elab_All_Id
is new Nat
;
103 -- Identification of Elab_All entry link
105 No_Elab_All_Link
: constant Elab_All_Id
:= 0;
106 -- Used to indicate end of list
108 -- Succ_Reason indicates the reason for a particular elaboration link
112 -- After directly with's Before, so the spec of Before must be
113 -- elaborated before After is elaborated.
116 -- Before and After come from a pair of lines in the forced elaboration
120 -- After directly mentions Before in a pragma Elaborate, so the body of
121 -- Before must be elaborated before After is elaborated.
124 -- After either mentions Before directly in a pragma Elaborate_All, or
125 -- mentions a third unit, X, which itself requires that Before be
126 -- elaborated before unit X is elaborated. The Elab_All_Link list traces
127 -- the dependencies in the latter case.
130 -- This is just like Elab_All, except that the Elaborate_All was not
131 -- explicitly present in the source, but rather was created by the front
132 -- end, which decided that it was "desirable".
135 -- This is just like Elab, except that the Elaborate was not explicitly
136 -- present in the source, but rather was created by the front end, which
137 -- decided that it was "desirable".
140 -- After is a body, and Before is the corresponding spec
142 -- Successor_Link contains the information for one link
144 type Successor_Link
is record
152 -- Next successor on this list
154 Reason
: Succ_Reason
;
155 -- Reason for this link
158 -- Set True if this link is needed for the special Elaborate_Body
159 -- processing described below.
161 Reason_Unit
: Unit_Id
;
162 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
163 -- containing the pragma leading to the link.
165 Elab_All_Link
: Elab_All_Id
;
166 -- If Reason = Elab_All or Elab_Desirable, then this points to the
167 -- first element in a list of Elab_All entries that record the with
168 -- chain resulting in this particular dependency.
171 -- Note on handling of Elaborate_Body. Basically, if we have a pragma
172 -- Elaborate_Body in a unit, it means that the spec and body have to be
173 -- handled as a single entity from the point of view of determining an
174 -- elaboration order. What we do is to essentially remove the body from
175 -- consideration completely, and transfer all its links (other than the
176 -- spec link) to the spec. Then when the spec gets chosen, we choose the
177 -- body right afterwards. We mark the links that get moved from the body to
178 -- the spec by setting their Elab_Body flag True, so that we can understand
181 Succ_First
: constant := 1;
183 package Succ
is new Table
.Table
184 (Table_Component_Type
=> Successor_Link
,
185 Table_Index_Type
=> Successor_Id
,
186 Table_Low_Bound
=> Succ_First
,
187 Table_Initial
=> 500,
188 Table_Increment
=> 200,
189 Table_Name
=> "Succ");
191 -- For the case of Elaborate_All, the following table is used to record
192 -- chains of with relationships that lead to the Elab_All link. These are
193 -- used solely for diagnostic purposes
195 type Elab_All_Entry
is record
196 Needed_By
: Unit_Name_Type
;
197 -- Name of unit from which referencing unit was with'ed or otherwise
198 -- needed as a result of Elaborate_All or Elaborate_Desirable.
200 Next_Elab
: Elab_All_Id
;
201 -- Link to next entry on chain (No_Elab_All_Link marks end of list)
204 package Elab_All_Entries
is new Table
.Table
205 (Table_Component_Type
=> Elab_All_Entry
,
206 Table_Index_Type
=> Elab_All_Id
,
207 Table_Low_Bound
=> 1,
208 Table_Initial
=> 2000,
209 Table_Increment
=> 200,
210 Table_Name
=> "Elab_All_Entries");
212 type Unit_Id_Array_Ptr
is access Unit_Id_Array
;
214 -- A Unit_Node_Record is built for each active unit
216 type Unit_Node_Record
is record
217 Successors
: Successor_Id
;
218 -- Pointer to list of links for successor nodes
221 -- Number of predecessors for this unit that have not yet been chosen.
222 -- Normally non-negative, but can go negative in the case of units
223 -- chosen by the diagnose error procedure (when cycles are being removed
227 -- Forward pointer for list of units with no predecessors
230 -- Used in computing transitive closure for Elaborate_All and also in
231 -- locating cycles and paths in the diagnose routines.
234 -- Initialized to zero. Set non-zero when a unit is chosen and placed in
235 -- the elaboration order. The value represents the ordinal position in
236 -- the elaboration order.
238 -- The following are for Elab_New. We compute the strongly connected
239 -- components (SCCs) of the directed graph of units. The edges are the
240 -- Successors, which do not include pragmas Elaborate_All (explicit or
241 -- implicit) in Elab_New. In addition, we assume there is a edge
242 -- pointing from a body to its corresponding spec; this edge is not
243 -- included in Successors, because of course a spec is elaborated BEFORE
244 -- its body, not after.
247 -- Each unit points to the root of its SCC, which is just an arbitrary
248 -- member of the SCC. Two units are in the same SCC if and only if their
249 -- SCC_Roots are equal. U is the root of its SCC if and only if
252 Nodes
: Unit_Id_Array_Ptr
;
253 -- Present only in the root of an SCC. This is the set of units in the
254 -- SCC, in no particular order.
257 -- Present only in the root of an SCC. This is the number of predecessor
258 -- units of the SCC that are in other SCCs, and that have not yet been
261 Validate_Seen
: Boolean := False;
262 -- See procedure Validate below
265 package UNR
is new Table
.Table
266 (Table_Component_Type
=> Unit_Node_Record
,
267 Table_Index_Type
=> Unit_Id
,
268 Table_Low_Bound
=> First_Unit_Entry
,
269 Table_Initial
=> 500,
270 Table_Increment
=> 200,
271 Table_Name
=> "UNR");
274 -- Head of list of items with no predecessors
277 -- Number of entries not yet dealt with
280 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
281 -- set the Reason_Unit field of the created dependency link.
284 -- Number of units chosen in the elaboration order so far
286 Diagnose_Elaboration_Problem_Called
: Boolean := False;
287 -- True if Diagnose_Elaboration_Problem was called. Used in an assertion.
289 -----------------------
290 -- Local Subprograms --
291 -----------------------
293 function Debug_Flag_Older
return Boolean;
294 function Debug_Flag_Old
return Boolean;
295 -- True if debug flags select the old or older algorithms. Pretty much any
296 -- change to elaboration order can break some programs. For example,
297 -- programs can depend on elaboration order even without failing
298 -- access-before-elaboration checks. A trivial example is a program that
299 -- prints text during elaboration. Therefore, we have flags to revert to
300 -- the old(er) algorithms.
302 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean);
303 -- Assert that certain properties are true
305 function Better_Choice_Optimistic
307 U2
: Unit_Id
) return Boolean;
308 -- U1 and U2 are both permitted candidates for selection as the next unit
309 -- to be elaborated. This function determines whether U1 is a better choice
310 -- than U2, i.e. should be elaborated in preference to U2, based on a set
311 -- of heuristics that establish a friendly and predictable order (see body
312 -- for details). The result is True if U1 is a better choice than U2, and
313 -- False if it is a worse choice, or there is no preference between them.
315 function Better_Choice_Pessimistic
317 U2
: Unit_Id
) return Boolean;
318 -- This is like Better_Choice_Optimistic, and has the same interface, but
319 -- returns true if U1 is a worse choice than U2 in the sense of the -p
320 -- (pessimistic elaboration order) switch. We still have to obey Ada rules,
321 -- so it is not quite the direct inverse of Better_Choice_Optimistic.
323 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean;
324 -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
325 -- appropriate. Also takes care of the U2 = No_Unit_Id case.
331 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
);
332 -- Establish a successor link, Before must be elaborated before After, and
333 -- the reason for the link is R. Ea_Id is the contents to be placed in the
334 -- Elab_All_Link of the entry.
337 (Elab_Order
: in out Unit_Id_Table
;
340 -- Chosen is the next entry chosen in the elaboration order. This procedure
341 -- updates all data structures appropriately.
343 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
;
344 pragma Inline
(Corresponding_Body
);
345 -- Given a unit that is a spec for which there is a separate body, return
346 -- the unit id of the body. It is an error to call this routine with a unit
347 -- that is not a spec, or that does not have a separate body.
349 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
;
350 pragma Inline
(Corresponding_Spec
);
351 -- Given a unit that is a body for which there is a separate spec, return
352 -- the unit id of the spec. It is an error to call this routine with a unit
353 -- that is not a body, or that does not have a separate spec.
355 procedure Diagnose_Elaboration_Problem
356 (Elab_Order
: in out Unit_Id_Table
);
357 pragma No_Return
(Diagnose_Elaboration_Problem
);
358 -- Called when no elaboration order can be found. Outputs an appropriate
359 -- diagnosis of the problem, and then abandons the bind.
361 procedure Elab_All_Links
364 Reason
: Succ_Reason
;
366 -- Used to compute the transitive closure of elaboration links for an
367 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
368 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a
369 -- pragma Elaborate_All or the front end has determined that a reference
370 -- probably requires Elaborate_All, and unit Before must be previously
371 -- elaborated. First a link is built making sure that unit Before is
372 -- elaborated before After, then a recursive call ensures that we also
373 -- build links for any units needed by Before (i.e. these units must/should
374 -- also be elaborated before After). Link is used to build a chain of
375 -- Elab_All_Entries to explain the reason for a link. The value passed is
378 procedure Elab_Error_Msg
(S
: Successor_Id
);
379 -- Given a successor link, outputs an error message of the form
380 -- "$ must be elaborated before $ ..." where ... is the reason.
382 procedure Force_Elab_Order
;
383 -- Gather dependencies from the forced elaboration order file (-f switch)
385 procedure Gather_Dependencies
;
386 -- Compute dependencies, building the Succ and UNR tables
389 -- Initialize global data structures in this package body
391 function Is_Body_Unit
(U
: Unit_Id
) return Boolean;
392 pragma Inline
(Is_Body_Unit
);
393 -- Determines if given unit is a body
395 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean;
396 -- Returns True if corresponding unit is Pure or Preelaborate. Includes
397 -- dealing with testing flags on spec if it is given a body.
399 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean;
400 pragma Inline
(Is_Waiting_Body
);
401 -- Determines if U is a waiting body, defined as a body that has
402 -- not been elaborated, but whose spec has been elaborated.
404 function Make_Elab_All_Entry
405 (Unam
: Unit_Name_Type
;
406 Link
: Elab_All_Id
) return Elab_All_Id
;
407 -- Make an Elab_All_Entries table entry with the given Unam and Link
409 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
;
410 -- This function uses the Info field set in the names table to obtain
411 -- the unit Id of a unit, given its name id value.
413 procedure Write_Closure
(Order
: Unit_Id_Array
);
414 -- Write the closure. This is for the -R and -Ra switches, "list closure
417 procedure Write_Dependencies
;
418 -- Write out dependencies (called only if appropriate option is set)
420 procedure Write_Elab_All_Chain
(S
: Successor_Id
);
421 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
422 -- then this routine will output the "needed by" explanation chain.
424 procedure Write_Elab_Order
(Order
: Unit_Id_Array
; Title
: String);
425 -- Display elaboration order. This is for the -l switch. Title is a heading
426 -- to print; an empty string is passed to indicate Zero_Formatting.
430 -- Implementation of the new algorithm
432 procedure Write_SCC
(U
: Unit_Id
);
433 -- Write the unit names of the units in the SCC in which U lives
435 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
437 Elab_Cycle_Found
: Boolean := False;
438 -- Set True if Find_Elab_Order found a cycle (usually an illegal pragma
439 -- Elaborate_All, explicit or implicit).
441 function SCC
(U
: Unit_Id
) return Unit_Id
;
442 -- The root of the strongly connected component containing U
444 function SCC_Num_Pred
(U
: Unit_Id
) return Int
;
445 -- The SCC_Num_Pred of the SCC in which U lives
447 function Nodes
(U
: Unit_Id
) return Unit_Id_Array_Ptr
;
448 -- The nodes of the strongly connected component containing U
456 -- Implementation of the old algorithm
458 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
462 -- Most of the code is shared between old and new; such code is outside
463 -- packages Elab_Old and Elab_New.
469 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean is
470 pragma Assert
(U1
/= No_Unit_Id
);
472 if U2
= No_Unit_Id
then
476 if Pessimistic_Elab_Order
then
477 return Better_Choice_Pessimistic
(U1
, U2
);
479 return Better_Choice_Optimistic
(U1
, U2
);
483 ------------------------------
484 -- Better_Choice_Optimistic --
485 ------------------------------
487 function Better_Choice_Optimistic
489 U2
: Unit_Id
) return Boolean
491 UT1
: Unit_Record
renames Units
.Table
(U1
);
492 UT2
: Unit_Record
renames Units
.Table
(U2
);
496 Write_Str
("Better_Choice_Optimistic (");
497 Write_Unit_Name
(UT1
.Uname
);
499 Write_Unit_Name
(UT2
.Uname
);
503 -- Note: the checks here are applied in sequence, and the ordering is
504 -- significant (i.e. the more important criteria are applied first).
506 -- Prefer a waiting body to one that is not a waiting body
508 if Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
510 Write_Line
(" True: u1 is waiting body, u2 is not");
515 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
517 Write_Line
(" False: u2 is waiting body, u1 is not");
522 -- Prefer a predefined unit to a non-predefined unit
524 elsif UT1
.Predefined
and then not UT2
.Predefined
then
526 Write_Line
(" True: u1 is predefined, u2 is not");
531 elsif UT2
.Predefined
and then not UT1
.Predefined
then
533 Write_Line
(" False: u2 is predefined, u1 is not");
538 -- Prefer an internal unit to a non-internal unit
540 elsif UT1
.Internal
and then not UT2
.Internal
then
542 Write_Line
(" True: u1 is internal, u2 is not");
546 elsif UT2
.Internal
and then not UT1
.Internal
then
548 Write_Line
(" False: u2 is internal, u1 is not");
553 -- Prefer a pure or preelaborated unit to one that is not. Pure should
554 -- come before preelaborated.
556 elsif Is_Pure_Or_Preelab_Unit
(U1
)
558 Is_Pure_Or_Preelab_Unit
(U2
)
561 Write_Line
(" True: u1 is pure/preelab, u2 is not");
566 elsif Is_Pure_Or_Preelab_Unit
(U2
)
568 Is_Pure_Or_Preelab_Unit
(U1
)
571 Write_Line
(" False: u2 is pure/preelab, u1 is not");
576 -- Prefer a body to a spec
578 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
580 Write_Line
(" True: u1 is body, u2 is not");
585 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
587 Write_Line
(" False: u2 is body, u1 is not");
592 -- If both are waiting bodies, then prefer the one whose spec is more
593 -- recently elaborated. Consider the following:
599 -- The normal waiting body preference would have placed the body of A
600 -- before the spec of B if it could. Since it could not, then it must be
601 -- the case that A depends on B. It is therefore a good idea to put the
604 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
606 Result
: constant Boolean :=
607 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
>
608 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
612 Write_Line
(" True: based on waiting body elab positions");
614 Write_Line
(" False: based on waiting body elab positions");
622 -- Remaining choice rules are disabled by Debug flag -do
624 if not Debug_Flag_Older
then
626 -- The following deal with the case of specs that have been marked
627 -- as Elaborate_Body_Desirable. We generally want to delay these
628 -- specs as long as possible, so that the bodies have a better chance
629 -- of being elaborated closer to the specs.
631 -- If we have two units, one of which is a spec for which this flag
632 -- is set, and the other is not, we prefer to delay the spec for
633 -- which the flag is set.
635 if not UT1
.Elaborate_Body_Desirable
636 and then UT2
.Elaborate_Body_Desirable
639 Write_Line
(" True: u1 is elab body desirable, u2 is not");
644 elsif not UT2
.Elaborate_Body_Desirable
645 and then UT1
.Elaborate_Body_Desirable
648 Write_Line
(" False: u1 is elab body desirable, u2 is not");
653 -- If we have two specs that are both marked as Elaborate_Body
654 -- desirable, we prefer the one whose body is nearer to being able
655 -- to be elaborated, based on the Num_Pred count. This helps to
656 -- ensure bodies are as close to specs as possible.
658 elsif UT1
.Elaborate_Body_Desirable
659 and then UT2
.Elaborate_Body_Desirable
662 Result
: constant Boolean :=
663 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
664 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
668 Write_Line
(" True based on Num_Pred compare");
670 Write_Line
(" False based on Num_Pred compare");
679 -- If we have two specs in the same SCC, choose the one whose body is
680 -- closer to being ready.
683 and then SCC
(U1
) = SCC
(U2
)
684 and then Units
.Table
(U1
).Utype
= Is_Spec
685 and then Units
.Table
(U2
).Utype
= Is_Spec
686 and then UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
/=
687 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
689 if UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
690 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
693 Write_Str
(" True: same SCC; ");
694 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
696 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
703 Write_Str
(" False: same SCC; ");
704 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
706 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
714 -- If we fall through, it means that no preference rule applies, so we
715 -- use alphabetical order to at least give a deterministic result.
718 Write_Line
(" choose on alpha order");
721 return Uname_Less
(UT1
.Uname
, UT2
.Uname
);
722 end Better_Choice_Optimistic
;
724 -------------------------------
725 -- Better_Choice_Pessimistic --
726 -------------------------------
728 function Better_Choice_Pessimistic
730 U2
: Unit_Id
) return Boolean
732 UT1
: Unit_Record
renames Units
.Table
(U1
);
733 UT2
: Unit_Record
renames Units
.Table
(U2
);
737 Write_Str
("Better_Choice_Pessimistic (");
738 Write_Unit_Name
(UT1
.Uname
);
740 Write_Unit_Name
(UT2
.Uname
);
744 -- Note: the checks here are applied in sequence, and the ordering is
745 -- significant (i.e. the more important criteria are applied first).
747 -- If either unit is predefined or internal, then we use the normal
748 -- Better_Choice_Optimistic rule, since we don't want to disturb the
749 -- elaboration rules of the language with -p; same treatment for
752 -- Prefer a predefined unit to a non-predefined unit
754 if UT1
.Predefined
and then not UT2
.Predefined
then
756 Write_Line
(" True: u1 is predefined, u2 is not");
761 elsif UT2
.Predefined
and then not UT1
.Predefined
then
763 Write_Line
(" False: u2 is predefined, u1 is not");
768 -- Prefer an internal unit to a non-internal unit
770 elsif UT1
.Internal
and then not UT2
.Internal
then
772 Write_Line
(" True: u1 is internal, u2 is not");
777 elsif UT2
.Internal
and then not UT1
.Internal
then
779 Write_Line
(" False: u2 is internal, u1 is not");
784 -- Prefer a pure or preelaborated unit to one that is not
786 elsif Is_Pure_Or_Preelab_Unit
(U1
)
788 Is_Pure_Or_Preelab_Unit
(U2
)
791 Write_Line
(" True: u1 is pure/preelab, u2 is not");
796 elsif Is_Pure_Or_Preelab_Unit
(U2
)
798 Is_Pure_Or_Preelab_Unit
(U1
)
801 Write_Line
(" False: u2 is pure/preelab, u1 is not");
806 -- Prefer anything else to a waiting body. We want to make bodies wait
807 -- as long as possible, till we are forced to choose them.
809 elsif Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
811 Write_Line
(" False: u1 is waiting body, u2 is not");
816 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
818 Write_Line
(" True: u2 is waiting body, u1 is not");
823 -- Prefer a spec to a body (this is mandatory)
825 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
827 Write_Line
(" False: u1 is body, u2 is not");
832 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
834 Write_Line
(" True: u2 is body, u1 is not");
839 -- If both are waiting bodies, then prefer the one whose spec is less
840 -- recently elaborated. Consider the following:
846 -- The normal waiting body preference would have placed the body of A
847 -- before the spec of B if it could. Since it could not, then it must be
848 -- the case that A depends on B. It is therefore a good idea to put the
849 -- body of B last so that if there is an elaboration order problem, we
850 -- will find it (that's what pessimistic order is about).
852 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
854 Result
: constant Boolean :=
855 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
<
856 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
860 Write_Line
(" True: based on waiting body elab positions");
862 Write_Line
(" False: based on waiting body elab positions");
870 -- Remaining choice rules are disabled by Debug flag -do
872 if not Debug_Flag_Older
then
874 -- The following deal with the case of specs that have been marked as
875 -- Elaborate_Body_Desirable. In the normal case, we generally want to
876 -- delay the elaboration of these specs as long as possible, so that
877 -- bodies have better chance of being elaborated closer to the specs.
878 -- Better_Choice_Pessimistic as usual wants to do the opposite and
879 -- elaborate such specs as early as possible.
881 -- If we have two units, one of which is a spec for which this flag
882 -- is set, and the other is not, we normally prefer to delay the spec
883 -- for which the flag is set, so again Better_Choice_Pessimistic does
886 if not UT1
.Elaborate_Body_Desirable
887 and then UT2
.Elaborate_Body_Desirable
890 Write_Line
(" False: u1 is elab body desirable, u2 is not");
895 elsif not UT2
.Elaborate_Body_Desirable
896 and then UT1
.Elaborate_Body_Desirable
899 Write_Line
(" True: u1 is elab body desirable, u2 is not");
904 -- If we have two specs that are both marked as Elaborate_Body
905 -- desirable, we normally prefer the one whose body is nearer to
906 -- being able to be elaborated, based on the Num_Pred count. This
907 -- helps to ensure bodies are as close to specs as possible. As
908 -- usual, Better_Choice_Pessimistic does the opposite.
910 elsif UT1
.Elaborate_Body_Desirable
911 and then UT2
.Elaborate_Body_Desirable
914 Result
: constant Boolean :=
915 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
>=
916 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
920 Write_Line
(" True based on Num_Pred compare");
922 Write_Line
(" False based on Num_Pred compare");
931 -- If we fall through, it means that no preference rule applies, so we
932 -- use alphabetical order to at least give a deterministic result. Since
933 -- Better_Choice_Pessimistic is in the business of stirring up the
934 -- order, we will use reverse alphabetical ordering.
937 Write_Line
(" choose on reverse alpha order");
940 return Uname_Less
(UT2
.Uname
, UT1
.Uname
);
941 end Better_Choice_Pessimistic
;
951 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
)
958 After
=> No_Unit_Id
, -- filled in below
959 Next
=> UNR
.Table
(Before
).Successors
,
961 Elab_Body
=> False, -- set correctly below
962 Reason_Unit
=> Cur_Unit
,
963 Elab_All_Link
=> Ea_Id
));
964 UNR
.Table
(Before
).Successors
:= Succ
.Last
;
966 -- Deal with special Elab_Body case. If the After of this link is
967 -- a body whose spec has Elaborate_All set, and this is not the link
968 -- directly from the body to the spec, then we make the After of the
969 -- link reference its spec instead, marking the link appropriately.
971 if Units
.Table
(After
).Utype
= Is_Body
then
972 Cspec
:= Corresponding_Spec
(After
);
974 if Units
.Table
(Cspec
).Elaborate_Body
975 and then Cspec
/= Before
977 Succ
.Table
(Succ
.Last
).After
:= Cspec
;
978 Succ
.Table
(Succ
.Last
).Elab_Body
:= True;
979 UNR
.Table
(Cspec
).Num_Pred
:= UNR
.Table
(Cspec
).Num_Pred
+ 1;
984 -- Fall through on normal case
986 Succ
.Table
(Succ
.Last
).After
:= After
;
987 Succ
.Table
(Succ
.Last
).Elab_Body
:= False;
988 UNR
.Table
(After
).Num_Pred
:= UNR
.Table
(After
).Num_Pred
+ 1;
996 (Elab_Order
: in out Unit_Id_Table
;
1000 pragma Assert
(Chosen
/= No_Unit_Id
);
1005 if Debug_Flag_C
then
1006 Write_Str
("Choosing Unit ");
1007 Write_Unit_Name
(Units
.Table
(Chosen
).Uname
);
1011 -- We shouldn't be choosing something with unelaborated predecessors,
1012 -- and we shouldn't call this twice on the same unit. But that's not
1013 -- true when this is called from Diagnose_Elaboration_Problem.
1015 if Errors_Detected
= 0 then
1016 pragma Assert
(UNR
.Table
(Chosen
).Num_Pred
= 0);
1017 pragma Assert
(UNR
.Table
(Chosen
).Elab_Position
= 0);
1018 pragma Assert
(not Doing_New
or else SCC_Num_Pred
(Chosen
) = 0);
1022 -- Add to elaboration order. Note that units having no elaboration code
1023 -- are not treated specially yet. The special casing of this is in
1024 -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
1025 -- here, because the object file list is also driven by the contents of
1026 -- the Elab_Order table.
1028 Append
(Elab_Order
, Chosen
);
1030 -- Remove from No_Pred list. This is a little inefficient and may be we
1031 -- should doubly link the list, but it will do for now.
1033 if No_Pred
= Chosen
then
1034 No_Pred
:= UNR
.Table
(Chosen
).Nextnp
;
1037 while U
/= No_Unit_Id
loop
1038 if UNR
.Table
(U
).Nextnp
= Chosen
then
1039 UNR
.Table
(U
).Nextnp
:= UNR
.Table
(Chosen
).Nextnp
;
1043 U
:= UNR
.Table
(U
).Nextnp
;
1046 -- Here if we didn't find it on the No_Pred list. This can happen
1047 -- only in calls from the Diagnose_Elaboration_Problem routine,
1048 -- where cycles are being removed arbitrarily from the graph.
1050 pragma Assert
(Errors_Detected
> 0);
1051 <<Done_Removal
>> null;
1054 -- For all successors, decrement the number of predecessors, and if it
1055 -- becomes zero, then add to no-predecessor list.
1057 S
:= UNR
.Table
(Chosen
).Successors
;
1058 while S
/= No_Successor
loop
1059 U
:= Succ
.Table
(S
).After
;
1060 UNR
.Table
(U
).Num_Pred
:= UNR
.Table
(U
).Num_Pred
- 1;
1062 if Debug_Flag_N
then
1063 Write_Str
(" decrementing Num_Pred for unit ");
1064 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1065 Write_Str
(" new value = ");
1066 Write_Int
(UNR
.Table
(U
).Num_Pred
);
1070 if UNR
.Table
(U
).Num_Pred
= 0 then
1071 UNR
.Table
(U
).Nextnp
:= No_Pred
;
1075 if Doing_New
and then SCC
(U
) /= SCC
(Chosen
) then
1076 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
:=
1077 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
- 1;
1079 if Debug_Flag_N
then
1080 Write_Str
(" decrementing SCC_Num_Pred for unit ");
1081 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1082 Write_Str
(" new value = ");
1083 Write_Int
(SCC_Num_Pred
(U
));
1088 S
:= Succ
.Table
(S
).Next
;
1091 -- All done, adjust number of units left count and set elaboration pos
1093 Num_Left
:= Num_Left
- 1;
1094 Num_Chosen
:= Num_Chosen
+ 1;
1097 (Errors_Detected
> 0 or else Num_Chosen
= Last
(Elab_Order
));
1098 pragma Assert
(Units
.Last
= UNR
.Last
);
1099 pragma Assert
(Num_Chosen
+ Num_Left
= Int
(UNR
.Last
));
1101 if Debug_Flag_C
then
1103 Write_Int
(Int
(Num_Chosen
));
1105 Write_Int
(Num_Left
);
1107 Write_Int
(Int
(UNR
.Last
));
1111 UNR
.Table
(Chosen
).Elab_Position
:= Num_Chosen
;
1113 -- If we just chose a spec with Elaborate_Body set, then we must
1114 -- immediately elaborate the body, before any other units.
1116 if Units
.Table
(Chosen
).Elaborate_Body
then
1118 -- If the unit is a spec only, then there is no body. This is a bit
1119 -- odd given that Elaborate_Body is here, but it is valid in an RCI
1120 -- unit, where we only have the interface in the stub bind.
1122 if Units
.Table
(Chosen
).Utype
= Is_Spec_Only
1123 and then Units
.Table
(Chosen
).RCI
1127 -- If this unit is an interface to a stand-alone library, then we
1128 -- don't want to elaborate the body -- that will happen as part of
1131 elsif Units
.Table
(Chosen
).SAL_Interface
then
1136 (Elab_Order
=> Elab_Order
,
1137 Chosen
=> Corresponding_Body
(Chosen
),
1138 Msg
=> " [Elaborate_Body]");
1143 ------------------------
1144 -- Corresponding_Body --
1145 ------------------------
1147 -- Currently if the body and spec are separate, then they appear as two
1148 -- separate units in the same ALI file, with the body appearing first and
1149 -- the spec appearing second.
1151 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
is
1153 pragma Assert
(Units
.Table
(U
).Utype
= Is_Spec
);
1155 end Corresponding_Body
;
1157 ------------------------
1158 -- Corresponding_Spec --
1159 ------------------------
1161 -- Currently if the body and spec are separate, then they appear as two
1162 -- separate units in the same ALI file, with the body appearing first and
1163 -- the spec appearing second.
1165 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
is
1167 pragma Assert
(Units
.Table
(U
).Utype
= Is_Body
);
1169 end Corresponding_Spec
;
1171 --------------------
1172 -- Debug_Flag_Old --
1173 --------------------
1175 function Debug_Flag_Old
return Boolean is
1177 -- If the user specified both flags, we want to use the older algorithm,
1178 -- rather than some confusing mix of the two.
1180 return Debug_Flag_P
and not Debug_Flag_O
;
1183 ----------------------
1184 -- Debug_Flag_Older --
1185 ----------------------
1187 function Debug_Flag_Older
return Boolean is
1189 return Debug_Flag_O
;
1190 end Debug_Flag_Older
;
1192 ----------------------------------
1193 -- Diagnose_Elaboration_Problem --
1194 ----------------------------------
1196 procedure Diagnose_Elaboration_Problem
1197 (Elab_Order
: in out Unit_Id_Table
)
1202 ML
: Nat
) return Boolean;
1203 -- Recursive routine used to find a path from node Ufrom to node Uto.
1204 -- If a path exists, returns True and outputs an appropriate set of
1205 -- error messages giving the path. Also calls Choose for each of the
1206 -- nodes so that they get removed from the remaining set. There are
1207 -- two cases of calls, either Ufrom = Uto for an attempt to find a
1208 -- cycle, or Ufrom is a spec and Uto the corresponding body for the
1209 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
1210 -- acceptable length for a path.
1219 ML
: Nat
) return Boolean
1221 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean;
1222 -- This is the inner recursive routine, it determines if a path
1223 -- exists from U to Uto, and if so returns True and outputs the
1224 -- appropriate set of error messages. PL is the path length
1230 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean is
1234 -- Recursion ends if we are at terminating node and the path is
1235 -- sufficiently long, generate error message and return True.
1237 if U
= Uto
and then PL
>= ML
then
1238 Choose
(Elab_Order
, U
, " [Find_Link: base]");
1241 -- All done if already visited
1243 elsif UNR
.Table
(U
).Visited
then
1246 -- Otherwise mark as visited and look at all successors
1249 UNR
.Table
(U
).Visited
:= True;
1251 S
:= UNR
.Table
(U
).Successors
;
1252 while S
/= No_Successor
loop
1253 if Find_Link
(Succ
.Table
(S
).After
, PL
+ 1) then
1255 Choose
(Elab_Order
, U
, " [Find_Link: recursive]");
1259 S
:= Succ
.Table
(S
).Next
;
1262 -- Falling through means this does not lead to a path
1268 -- Start of processing for Find_Path
1271 -- Initialize all non-chosen nodes to not visited yet
1273 for U
in Units
.First
.. Units
.Last
loop
1274 UNR
.Table
(U
).Visited
:= UNR
.Table
(U
).Elab_Position
/= 0;
1277 -- Now try to find the path
1279 return Find_Link
(Ufrom
, 0);
1282 -- Start of processing for Diagnose_Elaboration_Problem
1285 Diagnose_Elaboration_Problem_Called
:= True;
1288 -- Output state of things if debug flag N set
1290 if Debug_Flag_N
then
1297 Write_Line
("Diagnose_Elaboration_Problem called");
1298 Write_Line
("List of remaining unchosen units and predecessors");
1300 for U
in Units
.First
.. Units
.Last
loop
1301 if UNR
.Table
(U
).Elab_Position
= 0 then
1302 NP
:= UNR
.Table
(U
).Num_Pred
;
1304 Write_Str
(" Unchosen unit: #");
1305 Write_Int
(Int
(U
));
1307 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1308 Write_Str
(" (Num_Pred = ");
1313 if Units
.Table
(U
).Elaborate_Body
then
1315 (" (not chosen because of Elaborate_Body)");
1317 Write_Line
(" ****************** why not chosen?");
1321 -- Search links list to find unchosen predecessors
1323 for S
in Succ
.First
.. Succ
.Last
loop
1325 SL
: Successor_Link
renames Succ
.Table
(S
);
1329 and then UNR
.Table
(SL
.Before
).Elab_Position
= 0
1331 Write_Str
(" unchosen predecessor: #");
1332 Write_Int
(Int
(SL
.Before
));
1334 Write_Unit_Name
(Units
.Table
(SL
.Before
).Uname
);
1342 Write_Line
(" **************** Num_Pred value wrong!");
1349 -- Output the header for the error, and manually increment the error
1350 -- count. We are using Error_Msg_Output rather than Error_Msg here for
1353 -- This is really only one error, not one for each line
1354 -- We want this output on standard output since it is voluminous
1356 -- But we do need to deal with the error count manually in this case
1358 Errors_Detected
:= Errors_Detected
+ 1;
1359 Error_Msg_Output
("elaboration circularity detected", Info
=> False);
1361 -- Try to find cycles starting with any of the remaining nodes that have
1362 -- not yet been chosen. There must be at least one (there is some reason
1363 -- we are being called).
1365 for U
in Units
.First
.. Units
.Last
loop
1366 if UNR
.Table
(U
).Elab_Position
= 0 then
1367 if Find_Path
(U
, U
, 1) then
1368 raise Unrecoverable_Error
;
1373 -- We should never get here, since we were called for some reason, and
1374 -- we should have found and eliminated at least one bad path.
1376 raise Program_Error
;
1377 end Diagnose_Elaboration_Problem
;
1379 --------------------
1380 -- Elab_All_Links --
1381 --------------------
1383 procedure Elab_All_Links
1386 Reason
: Succ_Reason
;
1390 if UNR
.Table
(Before
).Visited
then
1394 -- Build the direct link for Before
1396 UNR
.Table
(Before
).Visited
:= True;
1397 Build_Link
(Before
, After
, Reason
, Link
);
1399 -- Process all units with'ed by Before recursively
1401 for W
in Units
.Table
(Before
).First_With
..
1402 Units
.Table
(Before
).Last_With
1404 -- Skip if this with is an interface to a stand-alone library. Skip
1405 -- also if no ALI file for this WITH, happens for language defined
1406 -- generics while bootstrapping the compiler (see body of routine
1407 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
1408 -- clause, which does not impose an elaboration link.
1410 if not Withs
.Table
(W
).SAL_Interface
1411 and then Withs
.Table
(W
).Afile
/= No_File
1412 and then not Withs
.Table
(W
).Limited_With
1415 Info
: constant Int
:=
1416 Get_Name_Table_Int
(Withs
.Table
(W
).Uname
);
1419 -- If the unit is unknown, for some unknown reason, fail
1420 -- graciously explaining that the unit is unknown. Without
1421 -- this check, gnatbind will crash in Unit_Id_Of.
1423 if Info
= 0 or else Unit_Id
(Info
) = No_Unit_Id
then
1426 Get_Name_String
(Withs
.Table
(W
).Uname
);
1427 Last_Withed
: Natural := Withed
'Last;
1430 (Units
.Table
(Before
).Uname
);
1431 Last_Withing
: Natural := Withing
'Last;
1432 Spec_Body
: String := " (Spec)";
1439 and then Withed
(Last_Withed
- 1) = '%'
1441 Last_Withed
:= Last_Withed
- 2;
1445 and then Withing
(Last_Withing
- 1) = '%'
1447 Last_Withing
:= Last_Withing
- 2;
1450 if Units
.Table
(Before
).Utype
= Is_Body
1451 or else Units
.Table
(Before
).Utype
= Is_Body_Only
1453 Spec_Body
:= " (Body)";
1457 ("could not find unit "
1458 & Withed
(Withed
'First .. Last_Withed
) & " needed by "
1459 & Withing
(Withing
'First .. Last_Withing
) & Spec_Body
);
1464 (Unit_Id_Of
(Withs
.Table
(W
).Uname
),
1467 Make_Elab_All_Entry
(Withs
.Table
(W
).Uname
, Link
));
1472 -- Process corresponding body, if there is one
1474 if Units
.Table
(Before
).Utype
= Is_Spec
then
1476 (Corresponding_Body
(Before
),
1479 (Units
.Table
(Corresponding_Body
(Before
)).Uname
, Link
));
1483 --------------------
1484 -- Elab_Error_Msg --
1485 --------------------
1487 procedure Elab_Error_Msg
(S
: Successor_Id
) is
1488 SL
: Successor_Link
renames Succ
.Table
(S
);
1491 -- Nothing to do if internal unit involved and no -da flag
1495 (Is_Internal_File_Name
(Units
.Table
(SL
.Before
).Sfile
)
1497 Is_Internal_File_Name
(Units
.Table
(SL
.After
).Sfile
))
1502 -- Here we want to generate output
1504 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1506 if SL
.Elab_Body
then
1507 Error_Msg_Unit_2
:= Units
.Table
(Corresponding_Body
(SL
.After
)).Uname
;
1509 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1512 Error_Msg_Output
(" $ must be elaborated before $", Info
=> True);
1514 Error_Msg_Unit_1
:= Units
.Table
(SL
.Reason_Unit
).Uname
;
1519 (" reason: with clause",
1524 (" reason: forced by -f switch",
1529 (" reason: pragma Elaborate in unit $",
1534 (" reason: pragma Elaborate_All in unit $",
1537 when Elab_All_Desirable
=>
1539 (" reason: implicit Elaborate_All in unit $",
1543 (" recompile $ with -gnatel for full details",
1546 when Elab_Desirable
=>
1548 (" reason: implicit Elaborate in unit $",
1552 (" recompile $ with -gnatel for full details",
1557 (" reason: spec always elaborated before body",
1561 Write_Elab_All_Chain
(S
);
1563 if SL
.Elab_Body
then
1564 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1565 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1567 (" $ must therefore be elaborated before $", True);
1569 Error_Msg_Unit_1
:= Units
.Table
(SL
.After
).Uname
;
1571 (" (because $ has a pragma Elaborate_Body)", True);
1574 if not Zero_Formatting
then
1579 ---------------------
1580 -- Find_Elab_Order --
1581 ---------------------
1583 procedure Find_Elab_Order
1584 (Elab_Order
: out Unit_Id_Table
;
1585 First_Main_Lib_File
: File_Name_Type
)
1587 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
;
1588 -- Number of cases where the body of a unit immediately follows the
1589 -- corresponding spec. Such cases are good, because calls to that unit
1590 -- from outside can't get ABE.
1592 -------------------------
1593 -- Num_Spec_Body_Pairs --
1594 -------------------------
1596 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
is
1600 for J
in Order
'First + 1 .. Order
'Last loop
1601 if Units
.Table
(Order
(J
- 1)).Utype
= Is_Spec
1602 and then Units
.Table
(Order
(J
)).Utype
= Is_Body
1603 and then Corresponding_Spec
(Order
(J
)) = Order
(J
- 1)
1605 Result
:= Result
+ 1;
1610 end Num_Spec_Body_Pairs
;
1614 Old_Elab_Order
: Unit_Id_Table
;
1616 -- Start of processing for Find_Elab_Order
1619 -- Output warning if -p used with no -gnatE units
1621 if Pessimistic_Elab_Order
1622 and not Dynamic_Elaboration_Checks_Specified
1624 Error_Msg
("?use of -p switch questionable");
1625 Error_Msg
("?since all units compiled with static elaboration model");
1628 if Do_New
and not Debug_Flag_Old
and not Debug_Flag_Older
then
1629 if Debug_Flag_V
then
1630 Write_Line
("Doing new...");
1635 Elab_New
.Find_Elab_Order
(Elab_Order
);
1638 -- Elab_New does not support the pessimistic order, so if that was
1639 -- requested, use the old results. Use Elab_Old if -dp or -do was
1640 -- selected. Elab_New does not yet give proper error messages for
1641 -- illegal Elaborate_Alls, so if there is one, run Elab_Old.
1644 or Pessimistic_Elab_Order
1649 if Debug_Flag_V
then
1650 Write_Line
("Doing old...");
1655 Elab_Old
.Find_Elab_Order
(Old_Elab_Order
);
1658 pragma Assert
(Elab_Cycle_Found
<= -- implies
1659 Diagnose_Elaboration_Problem_Called
);
1662 Old_Order
: Unit_Id_Array
renames
1663 Old_Elab_Order
.Table
(1 .. Last
(Old_Elab_Order
));
1665 if Do_Old
and Do_New
then
1667 New_Order
: Unit_Id_Array
renames
1668 Elab_Order
.Table
(1 .. Last
(Elab_Order
));
1669 Old_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(Old_Order
);
1670 New_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(New_Order
);
1673 Write_Line
(Get_Name_String
(First_Main_Lib_File
));
1675 pragma Assert
(Old_Order
'Length = New_Order
'Length);
1676 pragma Debug
(Validate
(Old_Order
, Doing_New
=> False));
1677 pragma Debug
(Validate
(New_Order
, Doing_New
=> True));
1679 -- Misc debug printouts that can be used for experimentation by
1680 -- changing the 'if's below.
1683 if New_Order
= Old_Order
then
1684 Write_Line
("Elab_New: same order.");
1686 Write_Line
("Elab_New: diff order.");
1690 if New_Order
/= Old_Order
and then False then
1691 Write_Line
("Elaboration orders differ:");
1693 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1695 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1699 Write_Str
("Pairs: ");
1700 Write_Int
(Old_Pairs
);
1702 if Old_Pairs
= New_Pairs
then
1704 elsif Old_Pairs
< New_Pairs
then
1710 Write_Int
(New_Pairs
);
1714 if Old_Pairs
/= New_Pairs
and then False then
1715 Write_Str
("Pairs: ");
1716 Write_Int
(Old_Pairs
);
1718 if Old_Pairs
< New_Pairs
then
1724 Write_Int
(New_Pairs
);
1727 if Old_Pairs
/= New_Pairs
and then Debug_Flag_V
then
1729 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1731 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1732 pragma Assert
(New_Pairs
>= Old_Pairs
);
1738 -- The Elab_New algorithm doesn't implement the -p switch, so if that
1739 -- was used, use the results from the old algorithm. Likewise if the
1740 -- user has requested the old algorithm.
1742 if Pessimistic_Elab_Order
or Debug_Flag_Old
or Debug_Flag_Older
then
1744 (Last
(Elab_Order
) = 0
1745 or else Last
(Elab_Order
) = Old_Order
'Last);
1748 Append_All
(Elab_Order
, Old_Order
);
1751 -- Now set the Elab_Positions in the Units table. It is important to
1752 -- do this late, in case we're running both Elab_New and Elab_Old.
1755 New_Order
: Unit_Id_Array
renames
1756 Elab_Order
.Table
(1 .. Last
(Elab_Order
));
1757 Units_Array
: Units
.Table_Type
renames
1758 Units
.Table
(Units
.First
.. Units
.Last
);
1760 for J
in New_Order
'Range loop
1762 (UNR
.Table
(New_Order
(J
)).Elab_Position
= J
);
1763 Units_Array
(New_Order
(J
)).Elab_Position
:= J
;
1766 if Errors_Detected
= 0 then
1768 -- Display elaboration order if -l was specified
1770 if Elab_Order_Output
then
1771 if Zero_Formatting
then
1772 Write_Elab_Order
(New_Order
, Title
=> "");
1775 (New_Order
, Title
=> "ELABORATION ORDER");
1779 -- Display list of sources in the closure (except predefined
1780 -- sources) if -R was used. Include predefined sources if -Ra
1783 if List_Closure
then
1784 Write_Closure
(New_Order
);
1789 end Find_Elab_Order
;
1791 ----------------------
1792 -- Force_Elab_Order --
1793 ----------------------
1795 procedure Force_Elab_Order
is
1797 -- There is a lot of fiddly string manipulation below, because we don't
1798 -- want to depend on misc utility packages like Ada.Characters.Handling.
1800 function Get_Line
return String;
1801 -- Read the next line from the file content read by Read_File. Strip
1802 -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
1803 -- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
1805 function Read_File
(Name
: String) return String_Ptr
;
1806 -- Read the entire contents of the named file
1808 subtype Header_Num
is Unit_Name_Type
'Base range 0 .. 2**16 - 1;
1809 type Line_Number
is new Nat
;
1810 No_Line_Number
: constant Line_Number
:= 0;
1811 Cur_Line_Number
: Line_Number
:= 0;
1812 -- Current line number in the Force_Elab_Order_File.
1813 -- Incremented by Get_Line. Used in error messages.
1815 function Hash
(N
: Unit_Name_Type
) return Header_Num
;
1817 package Name_Map
is new System
.HTable
.Simple_HTable
1818 (Header_Num
=> Header_Num
,
1819 Element
=> Line_Number
,
1820 No_Element
=> No_Line_Number
,
1821 Key
=> Unit_Name_Type
,
1824 -- Name_Map contains an entry for each file name seen, mapped to the
1825 -- line number where we saw it first. This is used to give an error for
1832 function Hash
(N
: Unit_Name_Type
) return Header_Num
is
1833 -- Name_Ids are already widely dispersed; no need for any actual
1834 -- hashing. Just subtract to make it zero based, and "mod" to
1835 -- bring it in range.
1837 return (N
- Unit_Name_Type
'First) mod (Header_Num
'Last + 1);
1844 function Read_File
(Name
: String) return String_Ptr
is
1846 -- All of the following calls should succeed, because we checked the
1847 -- file in Switch.B, but we double check and raise Program_Error on
1848 -- failure, just in case.
1850 F
: constant File_Descriptor
:= Open_Read
(Name
, Binary
);
1853 if F
= Invalid_FD
then
1854 raise Program_Error
;
1858 Len
: constant Natural := Natural (File_Length
(F
));
1859 Result
: constant String_Ptr
:= new String (1 .. Len
);
1860 Len_Read
: constant Natural :=
1861 Read
(F
, Result
(1)'Address, Len
);
1866 if Len_Read
/= Len
then
1867 raise Program_Error
;
1873 raise Program_Error
;
1880 Cur
: Positive := 1;
1881 S
: String_Ptr
:= Read_File
(Force_Elab_Order_File
.all);
1887 function Get_Line
return String is
1888 First
: Positive := Cur
;
1892 Cur_Line_Number
:= Cur_Line_Number
+ 1;
1894 -- Skip to end of line
1897 and then S
(Cur
) /= ASCII
.LF
1898 and then S
(Cur
) /= ASCII
.CR
1903 -- Strip leading blanks
1905 while First
<= S
'Last and then S
(First
) = ' ' loop
1909 -- Strip trailing blanks and comment
1913 for J
in First
.. Last
- 1 loop
1914 if S
(J
.. J
+ 1) = "--" then
1920 while Last
>= First
and then S
(Last
) = ' ' loop
1924 -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks
1928 Body_String
: constant String := "(body)";
1929 BL
: constant Positive := Body_String
'Length;
1930 Spec_String
: constant String := "(spec)";
1931 SL
: constant Positive := Spec_String
'Length;
1933 Line
: String renames S
(First
.. Last
);
1935 Is_Body
: Boolean := False;
1936 Is_Spec
: Boolean := False;
1939 if Line
'Length >= SL
1940 and then Line
(Last
- SL
+ 1 .. Last
) = Spec_String
1944 elsif Line
'Length >= BL
1945 and then Line
(Last
- BL
+ 1 .. Last
) = Body_String
1951 while Last
>= First
and then S
(Last
) = ' ' loop
1955 -- Skip past LF or CR/LF
1957 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.CR
then
1961 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.LF
then
1966 return Line
(First
.. Last
) & "%s";
1968 return Line
(First
.. Last
) & "%b";
1977 Empty_Name
: constant Unit_Name_Type
:= Name_Find
("");
1978 Prev_Unit
: Unit_Id
:= No_Unit_Id
;
1980 -- Start of processing for Force_Elab_Order
1983 -- Loop through the file content, and build a dependency link for each
1984 -- pair of lines. Ignore lines that should be ignored.
1986 while Cur
<= S
'Last loop
1988 Uname
: constant Unit_Name_Type
:= Name_Find
(Get_Line
);
1989 Error
: Boolean := False;
1992 if Uname
= Empty_Name
then
1993 null; -- silently skip blank lines
1996 Dup
: constant Line_Number
:= Name_Map
.Get
(Uname
);
1998 if Dup
= No_Line_Number
then
1999 Name_Map
.Set
(Uname
, Cur_Line_Number
);
2001 -- We don't need to give the "not present" message in
2002 -- the case of "duplicate unit", because we would have
2003 -- already given the "not present" message on the
2004 -- first occurrence.
2006 if Get_Name_Table_Int
(Uname
) = 0
2007 or else Unit_Id
(Get_Name_Table_Int
(Uname
)) =
2013 ("""" & Get_Name_String
(Uname
)
2014 & """: not present; ignored");
2021 Error_Msg_Nat_1
:= Nat
(Cur_Line_Number
);
2022 Error_Msg_Unit_1
:= Uname
;
2023 Error_Msg_Nat_2
:= Nat
(Dup
);
2025 (Force_Elab_Order_File
.all
2026 & ":#: duplicate unit name $ from line #");
2033 Cur_Unit
: constant Unit_Id
:= Unit_Id_Of
(Uname
);
2035 if Is_Internal_File_Name
2036 (Units
.Table
(Cur_Unit
).Sfile
)
2040 ("""" & Get_Name_String
(Uname
)
2041 & """: predefined unit ignored");
2045 if Prev_Unit
/= No_Unit_Id
then
2047 Write_Unit_Name
(Units
.Table
(Prev_Unit
).Uname
);
2048 Write_Str
(" <-- ");
2049 Write_Unit_Name
(Units
.Table
(Cur_Unit
).Uname
);
2054 (Before
=> Prev_Unit
,
2059 Prev_Unit
:= Cur_Unit
;
2068 end Force_Elab_Order
;
2070 -------------------------
2071 -- Gather_Dependencies --
2072 -------------------------
2074 procedure Gather_Dependencies
is
2075 Withed_Unit
: Unit_Id
;
2078 -- Loop through all units
2080 for U
in Units
.First
.. Units
.Last
loop
2083 -- If this is not an interface to a stand-alone library and there is
2084 -- a body and a spec, then spec must be elaborated first. Note that
2085 -- the corresponding spec immediately follows the body.
2087 if not Units
.Table
(U
).SAL_Interface
2088 and then Units
.Table
(U
).Utype
= Is_Body
2090 Build_Link
(Corresponding_Spec
(U
), U
, Spec_First
);
2093 -- If this unit is not an interface to a stand-alone library, process
2094 -- WITH references for this unit ignoring interfaces to stand-alone
2097 if not Units
.Table
(U
).SAL_Interface
then
2098 for W
in Units
.Table
(U
).First_With
..
2099 Units
.Table
(U
).Last_With
2101 if Withs
.Table
(W
).Sfile
/= No_File
2102 and then (not Withs
.Table
(W
).SAL_Interface
)
2104 -- Check for special case of withing a unit that does not
2105 -- exist any more. If the unit was completely missing we
2106 -- would already have detected this, but a nasty case arises
2107 -- when we have a subprogram body with no spec, and some
2108 -- obsolete unit with's a previous (now disappeared) spec.
2110 if Get_Name_Table_Int
(Withs
.Table
(W
).Uname
) = 0 then
2112 Error_Msg_File_1
:= Units
.Table
(U
).Sfile
;
2113 Error_Msg_Unit_1
:= Withs
.Table
(W
).Uname
;
2114 Error_Msg
("{ depends on $ which no longer exists");
2120 Withed_Unit
:= Unit_Id_Of
(Withs
.Table
(W
).Uname
);
2122 -- Pragma Elaborate_All case, for this we use the recursive
2123 -- Elab_All_Links procedure to establish the links.
2125 -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
2126 -- except for error messages.
2128 if Withs
.Table
(W
).Elaborate_All
and then not Doing_New
then
2130 -- Reset flags used to stop multiple visits to a given
2133 for Uref
in UNR
.First
.. UNR
.Last
loop
2134 UNR
.Table
(Uref
).Visited
:= False;
2137 -- Now establish all the links we need
2140 (Withed_Unit
, U
, Elab_All
,
2142 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2144 -- Elaborate_All_Desirable case, for this we establish the
2145 -- same links as above, but with a different reason.
2147 elsif Withs
.Table
(W
).Elab_All_Desirable
2148 and then not Doing_New
2150 -- Reset flags used to stop multiple visits to a given
2153 for Uref
in UNR
.First
.. UNR
.Last
loop
2154 UNR
.Table
(Uref
).Visited
:= False;
2157 -- Now establish all the links we need
2160 (Withed_Unit
, U
, Elab_All_Desirable
,
2162 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2164 -- Pragma Elaborate case. We must build a link for the
2165 -- withed unit itself, and also the corresponding body if
2168 -- However, skip this processing if there is no ALI file for
2169 -- the WITH entry, because this means it is a generic (even
2170 -- when we fix the generics so that an ALI file is present,
2171 -- we probably still will have no ALI file for unchecked and
2172 -- other special cases).
2174 elsif Withs
.Table
(W
).Elaborate
2175 and then Withs
.Table
(W
).Afile
/= No_File
2177 Build_Link
(Withed_Unit
, U
, Withed
);
2179 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2181 (Corresponding_Body
(Withed_Unit
), U
, Elab
);
2184 -- Elaborate_Desirable case, for this we establish the same
2185 -- links as above, but with a different reason.
2187 elsif Withs
.Table
(W
).Elab_Desirable
then
2188 Build_Link
(Withed_Unit
, U
, Withed
);
2190 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2192 (Corresponding_Body
(Withed_Unit
),
2196 -- A limited_with does not establish an elaboration
2197 -- dependence (that's the whole point).
2199 elsif Withs
.Table
(W
).Limited_With
then
2202 -- Case of normal WITH with no elaboration pragmas, just
2203 -- build the single link to the directly referenced unit
2206 Build_Link
(Withed_Unit
, U
, Withed
);
2216 -- If -f<elab_order> switch was given, take into account dependences
2217 -- specified in the file <elab_order>.
2219 if Force_Elab_Order_File
/= null then
2223 -- Output elaboration dependencies if option is set
2225 if Elab_Dependency_Output
or Debug_Flag_E
then
2230 end Gather_Dependencies
;
2239 Num_Left
:= Int
(Units
.Last
- Units
.First
+ 1);
2241 Elab_All_Entries
.Init
;
2244 -- Initialize unit table for elaboration control
2246 for U
in Units
.First
.. Units
.Last
loop
2248 ((Successors
=> No_Successor
,
2250 Nextnp
=> No_Unit_Id
,
2253 SCC_Root
=> No_Unit_Id
,
2256 Validate_Seen
=> False));
2264 function Is_Body_Unit
(U
: Unit_Id
) return Boolean is
2267 Units
.Table
(U
).Utype
= Is_Body
2268 or else Units
.Table
(U
).Utype
= Is_Body_Only
;
2271 -----------------------------
2272 -- Is_Pure_Or_Preelab_Unit --
2273 -----------------------------
2275 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean is
2277 -- If we have a body with separate spec, test flags on the spec
2279 if Units
.Table
(U
).Utype
= Is_Body
then
2281 Units
.Table
(Corresponding_Spec
(U
)).Preelab
2282 or else Units
.Table
(Corresponding_Spec
(U
)).Pure
;
2284 -- Otherwise we have a spec or body acting as spec, test flags on unit
2287 return Units
.Table
(U
).Preelab
or else Units
.Table
(U
).Pure
;
2289 end Is_Pure_Or_Preelab_Unit
;
2291 ---------------------
2292 -- Is_Waiting_Body --
2293 ---------------------
2295 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean is
2298 Units
.Table
(U
).Utype
= Is_Body
2299 and then UNR
.Table
(Corresponding_Spec
(U
)).Elab_Position
/= 0;
2300 end Is_Waiting_Body
;
2302 -------------------------
2303 -- Make_Elab_All_Entry --
2304 -------------------------
2306 function Make_Elab_All_Entry
2307 (Unam
: Unit_Name_Type
;
2308 Link
: Elab_All_Id
) return Elab_All_Id
2311 Elab_All_Entries
.Append
((Needed_By
=> Unam
, Next_Elab
=> Link
));
2312 return Elab_All_Entries
.Last
;
2313 end Make_Elab_All_Entry
;
2319 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
is
2320 Info
: constant Int
:= Get_Name_Table_Int
(Uname
);
2323 pragma Assert
(Info
/= 0 and then Unit_Id
(Info
) /= No_Unit_Id
);
2324 return Unit_Id
(Info
);
2331 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean) is
2332 Cur_SCC
: Unit_Id
:= No_Unit_Id
;
2333 OK
: Boolean := True;
2334 Msg
: String := "Old: ";
2341 -- For each unit, assert that its successors are elaborated after it
2343 for J
in Order
'Range loop
2345 U
: constant Unit_Id
:= Order
(J
);
2346 S
: Successor_Id
:= UNR
.Table
(U
).Successors
;
2349 while S
/= No_Successor
loop
2350 if UNR
.Table
(Succ
.Table
(S
).After
).Elab_Position
<=
2351 UNR
.Table
(U
).Elab_Position
2354 Write_Line
(Msg
& " elab order failed");
2357 S
:= Succ
.Table
(S
).Next
;
2362 -- An SCC of size 2 units necessarily consists of a spec and the
2363 -- corresponding body. Assert that the body is elaborated immediately
2364 -- after the spec, with nothing in between. (We only have SCCs in the
2368 for J
in Order
'Range loop
2370 U
: constant Unit_Id
:= Order
(J
);
2373 if Nodes
(U
)'Length = 2 then
2374 if Units
.Table
(U
).Utype
= Is_Spec
then
2375 if Order
(J
+ 1) /= Corresponding_Body
(U
) then
2377 Write_Line
(Msg
& "Bad spec with SCC of size 2:");
2378 Write_SCC
(SCC
(U
));
2382 if Units
.Table
(U
).Utype
= Is_Body
then
2383 if Order
(J
- 1) /= Corresponding_Spec
(U
) then
2385 Write_Line
(Msg
& "Bad body with SCC of size 2:");
2386 Write_SCC
(SCC
(U
));
2393 -- Assert that all units of an SCC are elaborated together, with no
2394 -- units from other SCCs in between. The above spec/body case is a
2395 -- special case of this general rule.
2397 for J
in Order
'Range loop
2399 U
: constant Unit_Id
:= Order
(J
);
2402 if SCC
(U
) /= Cur_SCC
then
2404 if UNR
.Table
(Cur_SCC
).Validate_Seen
then
2406 Write_Line
(Msg
& "SCC not elaborated together:");
2407 Write_SCC
(Cur_SCC
);
2410 UNR
.Table
(Cur_SCC
).Validate_Seen
:= True;
2423 procedure Write_Closure
(Order
: Unit_Id_Array
) is
2424 package Closure_Sources
is new Table
.Table
2425 (Table_Component_Type
=> File_Name_Type
,
2426 Table_Index_Type
=> Natural,
2427 Table_Low_Bound
=> 1,
2428 Table_Initial
=> 10,
2429 Table_Increment
=> 100,
2430 Table_Name
=> "Gnatbind.Closure_Sources");
2431 -- Table to record the sources in the closure, to avoid duplications
2433 function Put_In_Sources
(S
: File_Name_Type
) return Boolean;
2434 -- Check if S is already in table Sources and put in Sources if it is
2435 -- not. Return False if the source is already in Sources, and True if
2438 --------------------
2439 -- Put_In_Sources --
2440 --------------------
2442 function Put_In_Sources
(S
: File_Name_Type
) return Boolean is
2444 for J
in 1 .. Closure_Sources
.Last
loop
2445 if Closure_Sources
.Table
(J
) = S
then
2450 Closure_Sources
.Append
(S
);
2456 Source
: File_Name_Type
;
2458 -- Start of processing for Write_Closure
2461 Closure_Sources
.Init
;
2463 if not Zero_Formatting
then
2465 Write_Line
("REFERENCED SOURCES");
2468 for J
in reverse Order
'Range loop
2469 Source
:= Units
.Table
(Order
(J
)).Sfile
;
2471 -- Do not include same source more than once
2473 if Put_In_Sources
(Source
)
2475 -- Do not include run-time units unless -Ra switch set
2477 and then (List_Closure_All
2478 or else not Is_Internal_File_Name
(Source
))
2480 if not Zero_Formatting
then
2484 Write_Line
(Get_Name_String
(Source
));
2488 -- Subunits do not appear in the elaboration table because they are
2489 -- subsumed by their parent units, but we need to list them for other
2490 -- tools. For now they are listed after other files, rather than right
2491 -- after their parent, since there is no easy link between the
2492 -- elaboration table and the ALIs table ??? As subunits may appear
2493 -- repeatedly in the list, if the parent unit appears in the context of
2494 -- several units in the closure, duplicates are suppressed.
2496 for J
in Sdep
.First
.. Sdep
.Last
loop
2497 Source
:= Sdep
.Table
(J
).Sfile
;
2499 if Sdep
.Table
(J
).Subunit_Name
/= No_Name
2500 and then Put_In_Sources
(Source
)
2501 and then not Is_Internal_File_Name
(Source
)
2503 if not Zero_Formatting
then
2507 Write_Line
(Get_Name_String
(Source
));
2511 if not Zero_Formatting
then
2516 ------------------------
2517 -- Write_Dependencies --
2518 ------------------------
2520 procedure Write_Dependencies
is
2522 if not Zero_Formatting
then
2524 Write_Line
(" ELABORATION ORDER DEPENDENCIES");
2528 Info_Prefix_Suppress
:= True;
2530 for S
in Succ_First
.. Succ
.Last
loop
2534 Info_Prefix_Suppress
:= False;
2536 if not Zero_Formatting
then
2539 end Write_Dependencies
;
2541 --------------------------
2542 -- Write_Elab_All_Chain --
2543 --------------------------
2545 procedure Write_Elab_All_Chain
(S
: Successor_Id
) is
2546 ST
: constant Successor_Link
:= Succ
.Table
(S
);
2547 After
: constant Unit_Name_Type
:= Units
.Table
(ST
.After
).Uname
;
2550 Nam
: Unit_Name_Type
;
2552 First_Name
: Boolean := True;
2555 if ST
.Reason
in Elab_All
.. Elab_All_Desirable
then
2556 L
:= ST
.Elab_All_Link
;
2557 while L
/= No_Elab_All_Link
loop
2558 Nam
:= Elab_All_Entries
.Table
(L
).Needed_By
;
2559 Error_Msg_Unit_1
:= Nam
;
2560 Error_Msg_Output
(" $", Info
=> True);
2562 Get_Name_String
(Nam
);
2564 if Name_Buffer
(Name_Len
) = 'b' then
2567 (" must be elaborated along with its spec:",
2572 (" which must be elaborated along with its "
2585 (" which is withed by:",
2590 First_Name
:= False;
2592 L
:= Elab_All_Entries
.Table
(L
).Next_Elab
;
2595 Error_Msg_Unit_1
:= After
;
2596 Error_Msg_Output
(" $", Info
=> True);
2598 end Write_Elab_All_Chain
;
2600 ----------------------
2601 -- Write_Elab_Order --
2602 ----------------------
2604 procedure Write_Elab_Order
2605 (Order
: Unit_Id_Array
; Title
: String)
2613 for J
in Order
'Range loop
2614 if not Units
.Table
(Order
(J
)).SAL_Interface
then
2615 if not Zero_Formatting
then
2619 Write_Unit_Name
(Units
.Table
(Order
(J
)).Uname
);
2627 end Write_Elab_Order
;
2633 package body Elab_New
is
2639 type Node_Array
is array (Pos
range <>) of Node
;
2640 with function Successors
(N
: Node
) return Node_Array
;
2641 with procedure Create_SCC
(Root
: Node
; Nodes
: Node_Array
);
2643 procedure Compute_Strongly_Connected_Components
;
2644 -- Compute SCCs for a directed graph. The nodes in the graph are all
2645 -- values of type Node in the range First_Node .. Last_Node.
2646 -- Successors(N) returns the nodes pointed to by the edges emanating
2647 -- from N. Create_SCC is a callback that is called once for each SCC,
2648 -- passing in the Root node for that SCC (which is an arbitrary node in
2649 -- the SCC used as a representative of that SCC), and the set of Nodes
2652 -- This is generic, in case we want to use it elsewhere; then we could
2653 -- move this into a separate library unit. Unfortunately, it's not as
2654 -- generic as one might like. Ideally, we would have "type Node is
2655 -- private;", and pass in iterators to iterate over all nodes, and over
2656 -- the successors of a given node. However, that leads to using advanced
2657 -- features of Ada that are not allowed in the compiler and binder for
2658 -- bootstrapping reasons. It also leads to trampolines, which are not
2659 -- allowed in the compiler and binder. Restricting Node to be discrete
2660 -- allows us to iterate over all nodes with a 'for' loop, and allows us
2661 -- to attach temporary information to nodes by having an array indexed
2664 procedure Compute_Unit_SCCs
;
2665 -- Use the above generic procedure to compute the SCCs for the graph of
2666 -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
2667 -- components. Also initialize the SCC_Num_Pred components.
2669 procedure Find_Elab_All_Errors
;
2670 -- Generate an error for illegal Elaborate_All pragmas (explicit or
2671 -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
2672 -- if X and Y are in different SCCs.
2674 -------------------------------------------
2675 -- Compute_Strongly_Connected_Components --
2676 -------------------------------------------
2678 procedure Compute_Strongly_Connected_Components
is
2680 -- This uses Tarjan's algorithm for finding SCCs. Comments here are
2681 -- intended to tell what it does, but if you want to know how it
2682 -- works, you have to look it up. Please do not modify this code
2683 -- without reading up on Tarjan's algorithm.
2685 subtype Node_Index
is Nat
;
2686 No_Index
: constant Node_Index
:= 0;
2688 Num_Nodes
: constant Nat
:=
2689 Node
'Pos (Last_Node
) - Node
'Pos (First_Node
) + 1;
2690 Stack
: Node_Array
(1 .. Num_Nodes
);
2691 Top
: Node_Index
:= 0;
2692 -- Stack of nodes, pushed when first visited. All nodes of an SCC are
2693 -- popped at once when the SCC is found.
2695 subtype Valid_Node
is Node
range First_Node
.. Last_Node
;
2696 Node_Indices
: array (Valid_Node
) of Node_Index
:=
2697 (others => No_Index
);
2698 -- Each node has an "index", which is the sequential number in the
2699 -- order in which they are visited in the recursive walk. No_Index
2700 -- means "not yet visited"; we want to avoid walking any node more
2703 Index
: Node_Index
:= 1;
2704 -- Next value to be assigned to a node index
2706 Low_Links
: array (Valid_Node
) of Node_Index
;
2707 -- Low_Links (N) is the smallest index of nodes reachable from N
2709 On_Stack
: array (Valid_Node
) of Boolean := (others => False);
2710 -- True if the node is currently on the stack
2712 procedure Walk
(N
: Valid_Node
);
2713 -- Recursive depth-first graph walk, with the node index used to
2714 -- avoid visiting a node more than once.
2720 procedure Walk
(N
: Valid_Node
) is
2721 Stack_Position_Of_N
: constant Pos
:= Top
+ 1;
2722 S
: constant Node_Array
:= Successors
(N
);
2725 -- Assign the index and low link, increment Index for next call to
2728 Node_Indices
(N
) := Index
;
2729 Low_Links
(N
) := Index
;
2732 -- Push it on the stack:
2734 Top
:= Stack_Position_Of_N
;
2736 On_Stack
(N
) := True;
2738 -- Walk not-yet-visited subnodes, and update low link for visited
2739 -- ones as appropriate.
2741 for J
in S
'Range loop
2742 if Node_Indices
(S
(J
)) = No_Index
then
2745 Node_Index
'Min (Low_Links
(N
), Low_Links
(S
(J
)));
2746 elsif On_Stack
(S
(J
)) then
2748 Node_Index
'Min (Low_Links
(N
), Node_Indices
(S
(J
)));
2752 -- If the index is (still) equal to the low link, we've found an
2753 -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
2755 if Low_Links
(N
) = Node_Indices
(N
) then
2757 SCC
: Node_Array
renames
2758 Stack
(Stack_Position_Of_N
.. Top
);
2759 pragma Assert
(SCC
'Length >= 1);
2760 pragma Assert
(SCC
(SCC
'First) = N
);
2763 for J
in SCC
'Range loop
2764 On_Stack
(SCC
(J
)) := False;
2767 Create_SCC
(Root
=> N
, Nodes
=> SCC
);
2768 pragma Assert
(Top
- SCC
'Length = Stack_Position_Of_N
- 1);
2769 Top
:= Stack_Position_Of_N
- 1; -- pop all
2774 -- Start of processing for Compute_Strongly_Connected_Components
2777 -- Walk all the nodes that have not yet been walked
2779 for N
in Valid_Node
loop
2780 if Node_Indices
(N
) = No_Index
then
2784 end Compute_Strongly_Connected_Components
;
2786 -----------------------
2787 -- Compute_Unit_SCCs --
2788 -----------------------
2790 procedure Compute_Unit_SCCs
is
2791 function Successors
(U
: Unit_Id
) return Unit_Id_Array
;
2792 -- Return all the units that must be elaborated after U. In addition,
2793 -- if U is a body, include the corresponding spec; this ensures that
2794 -- a spec/body pair are always in the same SCC.
2796 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
);
2797 -- Set Nodes of the Root, and set SCC_Root of all the Nodes
2799 procedure Init_SCC_Num_Pred
(U
: Unit_Id
);
2800 -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
2801 -- has a count of the number of successors of all the units in the
2802 -- SCC, but only for successors outside the SCC.
2804 procedure Compute_SCCs
is new Compute_Strongly_Connected_Components
2806 First_Node
=> Units
.First
,
2807 Last_Node
=> Units
.Last
,
2808 Node_Array
=> Unit_Id_Array
,
2809 Successors
=> Successors
,
2810 Create_SCC
=> Create_SCC
);
2816 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
) is
2818 if Debug_Flag_V
then
2819 Write_Str
("Root = ");
2820 Write_Int
(Int
(Root
));
2822 Write_Unit_Name
(Units
.Table
(Root
).Uname
);
2824 Write_Int
(Nodes
'Length);
2825 Write_Line
(" units:");
2827 for J
in Nodes
'Range loop
2829 Write_Int
(Int
(Nodes
(J
)));
2831 Write_Unit_Name
(Units
.Table
(Nodes
(J
)).Uname
);
2836 pragma Assert
(Nodes
(Nodes
'First) = Root
);
2837 pragma Assert
(UNR
.Table
(Root
).Nodes
= null);
2838 UNR
.Table
(Root
).Nodes
:= new Unit_Id_Array
'(Nodes);
2840 for J in Nodes'Range loop
2841 pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
2842 UNR.Table (Nodes (J)).SCC_Root := Root;
2850 function Successors (U : Unit_Id) return Unit_Id_Array is
2851 S : Successor_Id := UNR.Table (U).Successors;
2852 Tab : Unit_Id_Table;
2855 -- Pretend that a spec is a successor of its body (even though it
2856 -- isn't), just so both get included.
2858 if Units.Table (U).Utype = Is_Body then
2859 Append (Tab, Corresponding_Spec (U));
2862 -- Now include the real successors
2864 while S /= No_Successor loop
2865 pragma Assert (Succ.Table (S).Before = U);
2866 Append (Tab, Succ.Table (S).After);
2867 S := Succ.Table (S).Next;
2871 Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
2879 -----------------------
2880 -- Init_SCC_Num_Pred --
2881 -----------------------
2883 procedure Init_SCC_Num_Pred (U : Unit_Id) is
2885 if UNR.Table (U).Visited then
2889 UNR.Table (U).Visited := True;
2892 S : Successor_Id := UNR.Table (U).Successors;
2895 while S /= No_Successor loop
2896 pragma Assert (Succ.Table (S).Before = U);
2897 Init_SCC_Num_Pred (Succ.Table (S).After);
2899 if SCC (U) /= SCC (Succ.Table (S).After) then
2900 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
2901 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
2904 S := Succ.Table (S).Next;
2907 end Init_SCC_Num_Pred;
2909 -- Start of processing for Compute_Unit_SCCs
2914 for Uref in UNR.First .. UNR.Last loop
2915 pragma Assert (not UNR.Table (Uref).Visited);
2919 for Uref in UNR.First .. UNR.Last loop
2920 Init_SCC_Num_Pred (Uref);
2923 -- Assert that SCC_Root of all units has been set to a valid unit,
2924 -- and that SCC_Num_Pred has not been modified in non-root units.
2926 for Uref in UNR.First .. UNR.Last loop
2927 pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
2928 pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
2930 if SCC (Uref) /= Uref then
2931 pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
2935 end Compute_Unit_SCCs;
2937 --------------------------
2938 -- Find_Elab_All_Errors --
2939 --------------------------
2941 procedure Find_Elab_All_Errors is
2942 Withed_Unit : Unit_Id;
2945 for U in Units.First .. Units.Last loop
2947 -- If this unit is not an interface to a stand-alone library,
2948 -- process WITH references for this unit ignoring interfaces to
2949 -- stand-alone libraries.
2951 if not Units.Table (U).SAL_Interface then
2952 for W in Units.Table (U).First_With ..
2953 Units.Table (U).Last_With
2955 if Withs.Table (W).Sfile /= No_File
2956 and then (not Withs.Table (W).SAL_Interface)
2958 -- Check for special case of withing a unit that does not
2961 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
2965 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
2967 -- If it's Elaborate_All or Elab_All_Desirable, check
2968 -- that the withER and withEE are not in the same SCC.
2970 if Withs.Table (W).Elaborate_All
2971 or else Withs.Table (W).Elab_All_Desirable
2973 if SCC (U) = SCC (Withed_Unit) then
2974 Elab_Cycle_Found := True; -- ???
2976 -- We could probably give better error messages
2977 -- than Elab_Old here, but for now, to avoid
2978 -- disruption, we don't give any error here.
2979 -- Instead, we set the Elab_Cycle_Found flag above,
2980 -- and then run the Elab_Old algorithm to issue the
2981 -- error message. Ideally, we would like to print
2982 -- multiple errors rather than stopping after the
2987 ("illegal pragma Elaborate_All",
2999 end Find_Elab_All_Errors;
3001 ---------------------
3002 -- Find_Elab_Order --
3003 ---------------------
3005 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
3006 Best_So_Far : Unit_Id;
3010 -- Gather dependencies and output them if option set
3012 Gather_Dependencies;
3016 -- Initialize the no-predecessor list
3018 No_Pred := No_Unit_Id;
3019 for U in UNR.First .. UNR.Last loop
3020 if UNR.Table (U).Num_Pred = 0 then
3021 UNR.Table (U).Nextnp := No_Pred;
3026 -- OK, now we determine the elaboration order proper. All we do is to
3027 -- select the best choice from the no-predecessor list until all the
3028 -- nodes have been chosen.
3031 if Debug_Flag_N then
3032 Write_Line ("Outer loop");
3035 -- If there are no nodes with predecessors, then either we are
3036 -- done, as indicated by Num_Left being set to zero, or we have
3037 -- a circularity. In the latter case, diagnose the circularity,
3038 -- removing it from the graph and continue.
3039 -- ????But Diagnose_Elaboration_Problem always raises an
3040 -- exception, so the loop never goes around more than once.
3042 Get_No_Pred : while No_Pred = No_Unit_Id loop
3043 exit Outer when Num_Left < 1;
3044 Diagnose_Elaboration_Problem (Elab_Order);
3045 end loop Get_No_Pred;
3048 Best_So_Far := No_Unit_Id;
3050 -- Loop to choose best entry in No_Pred list
3052 No_Pred_Search : loop
3053 if Debug_Flag_N then
3054 Write_Str (" considering choice of ");
3055 Write_Unit_Name (Units.Table (U).Uname);
3058 if Units.Table (U).Elaborate_Body then
3060 (" Elaborate_Body = True, Num_Pred for body = ");
3062 (UNR.Table (Corresponding_Body (U)).Num_Pred);
3065 (" Elaborate_Body = False");
3071 -- Don't even consider units whose SCC is not ready. This
3072 -- ensures that all units of an SCC will be elaborated
3073 -- together, with no other units in between.
3075 if SCC_Num_Pred (U) = 0
3076 and then Better_Choice (U, Best_So_Far)
3078 if Debug_Flag_N then
3079 Write_Line (" tentatively chosen (best so far)");
3084 if Debug_Flag_N then
3085 Write_Line (" SCC not ready");
3089 U := UNR.Table (U).Nextnp;
3090 exit No_Pred_Search when U = No_Unit_Id;
3091 end loop No_Pred_Search;
3093 -- If there are no units on the No_Pred list whose SCC is ready,
3094 -- there must be a cycle. Defer to Elab_Old to print an error
3097 if Best_So_Far = No_Unit_Id then
3098 Elab_Cycle_Found := True;
3102 -- Choose the best candidate found
3104 Choose (Elab_Order, Best_So_Far, " [Best_So_Far]");
3106 -- If it's a spec with a body, and the body is not yet chosen,
3107 -- choose the body if possible. The case where the body is
3108 -- already chosen is Elaborate_Body; the above call to Choose
3109 -- the spec will also Choose the body.
3111 if Units.Table (Best_So_Far).Utype = Is_Spec
3113 (Corresponding_Body (Best_So_Far)).Elab_Position = 0
3116 Choose_The_Body : constant Boolean :=
3117 UNR.Table (Corresponding_Body
3118 (Best_So_Far)).Num_Pred = 0;
3121 if Debug_Flag_B then
3122 Write_Str ("Can we choose the body?... ");
3124 if Choose_The_Body then
3125 Write_Line ("Yes!");
3131 if Choose_The_Body then
3133 (Elab_Order => Elab_Order,
3134 Chosen => Corresponding_Body (Best_So_Far),
3140 -- Finally, choose all the rest of the units in the same SCC as
3141 -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
3142 -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
3146 Chose_One_Or_More : Boolean := False;
3147 SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
3150 for J in SCC'Range loop
3151 if UNR.Table (SCC (J)).Elab_Position = 0
3152 and then UNR.Table (SCC (J)).Num_Pred = 0
3154 Chose_One_Or_More := True;
3155 Choose (Elab_Order, SCC (J), " [same SCC]");
3159 exit when not Chose_One_Or_More;
3164 Find_Elab_All_Errors;
3165 end Find_Elab_Order;
3171 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
3173 return UNR.Table (SCC (U)).Nodes;
3180 function SCC (U : Unit_Id) return Unit_Id is
3182 return UNR.Table (U).SCC_Root;
3189 function SCC_Num_Pred (U : Unit_Id) return Int is
3191 return UNR.Table (SCC (U)).SCC_Num_Pred;
3198 procedure Write_SCC (U : Unit_Id) is
3199 pragma Assert (SCC (U) = U);
3201 for J in Nodes (U)'Range loop
3202 Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position);
3204 Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
3217 package body Elab_Old is
3219 ---------------------
3220 -- Find_Elab_Order --
3221 ---------------------
3223 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
3224 Best_So_Far : Unit_Id;
3228 -- Gather dependencies and output them if option set
3230 Gather_Dependencies;
3232 -- Initialize the no-predecessor list
3234 No_Pred := No_Unit_Id;
3235 for U in UNR.First .. UNR.Last loop
3236 if UNR.Table (U).Num_Pred = 0 then
3237 UNR.Table (U).Nextnp := No_Pred;
3242 -- OK, now we determine the elaboration order proper. All we do is to
3243 -- select the best choice from the no-predecessor list until all the
3244 -- nodes have been chosen.
3248 -- If there are no nodes with predecessors, then either we are
3249 -- done, as indicated by Num_Left being set to zero, or we have
3250 -- a circularity. In the latter case, diagnose the circularity,
3251 -- removing it from the graph and continue.
3252 -- ????But Diagnose_Elaboration_Problem always raises an
3253 -- exception, so the loop never goes around more than once.
3255 Get_No_Pred : while No_Pred = No_Unit_Id loop
3256 exit Outer when Num_Left < 1;
3257 Diagnose_Elaboration_Problem (Elab_Order);
3258 end loop Get_No_Pred;
3261 Best_So_Far := No_Unit_Id;
3263 -- Loop to choose best entry in No_Pred list
3265 No_Pred_Search : loop
3266 if Debug_Flag_N then
3267 Write_Str (" considering choice of ");
3268 Write_Unit_Name (Units.Table (U).Uname);
3271 if Units.Table (U).Elaborate_Body then
3273 (" Elaborate_Body = True, Num_Pred for body = ");
3275 (UNR.Table (Corresponding_Body (U)).Num_Pred);
3278 (" Elaborate_Body = False");
3284 -- This is a candididate to be considered for choice
3286 if Better_Choice (U, Best_So_Far) then
3287 if Debug_Flag_N then
3288 Write_Line (" tentatively chosen (best so far)");
3294 U := UNR.Table (U).Nextnp;
3295 exit No_Pred_Search when U = No_Unit_Id;
3296 end loop No_Pred_Search;
3298 -- Choose the best candidate found
3300 Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]");
3302 end Find_Elab_Order;