1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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
;
40 -- We now have Elab_New, a new elaboration-order algorithm.
42 -- However, any change to elaboration order can break some programs.
43 -- Therefore, we are keeping the old algorithm in place, to be selected
46 -- The new algorithm has the following interesting properties:
48 -- * The static and dynamic models use the same elaboration order. The
49 -- static model might get an error, but if it does not, it will use
50 -- the same order as the dynamic model.
52 -- * Each SCC (see below) is elaborated together; that is, units from
53 -- different SCCs are not interspersed.
55 -- * In particular, this implies that if an SCC contains just a spec and
56 -- the corresponding body, and nothing else, the body will be
57 -- elaborated immediately after the spec. This is expected to result
58 -- in a better elaboration order for most programs, because in this
59 -- case, a call from outside the library unit cannot get ABE.
61 -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
62 -- we behave as if every legal pragma Elaborate_All were present. That
63 -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
64 -- then we behave as if such a pragma exists, even if it does not.
66 Do_Old
: constant Boolean := False;
67 Do_New
: constant Boolean := True;
68 -- True to enable the old and new algorithms, respectively. Used for
69 -- debugging/experimentation.
71 Doing_New
: Boolean := False;
72 -- True if we are currently doing the new algorithm. Print certain
73 -- messages only when doing the "new" elab order algorithm, so we don't get
74 -- duplicates. And use different heuristics in Better_Choice_Optimistic.
76 -- The following data structures are used to represent the graph that is
77 -- used to determine the elaboration order (using a topological sort).
79 -- The following structures are used to record successors. If B is a
80 -- successor of A in this table, it means that A must be elaborated before
81 -- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
82 -- will be a successor of X (spec), and X (spec) will be a predecessor of
85 -- Note that we store the successors of each unit explicitly. We don't
86 -- store the predecessors, but we store a count of them.
88 -- The basic algorithm is to first compute a directed graph of units (type
89 -- Unit_Node_Record, below), with successors as edges. A unit is "ready"
90 -- (to be chosen as the next to be elaborated) if it has no predecessors
91 -- that have not yet been chosen. We use heuristics to decide which of the
92 -- ready units should be elaborated next, and "choose" that one (which
93 -- means we append it to the elaboration-order table).
95 type Successor_Id
is new Nat
;
96 -- Identification of single successor entry
98 No_Successor
: constant Successor_Id
:= 0;
99 -- Used to indicate end of list of successors
101 type Elab_All_Id
is new Nat
;
102 -- Identification of Elab_All entry link
104 No_Elab_All_Link
: constant Elab_All_Id
:= 0;
105 -- Used to indicate end of list
107 -- Succ_Reason indicates the reason for a particular elaboration link
111 -- After directly with's Before, so the spec of Before must be
112 -- elaborated before After is elaborated.
115 -- Before and After come from a pair of lines in the forced elaboration
119 -- After directly mentions Before in a pragma Elaborate, so the body of
120 -- Before must be elaborated before After is elaborated.
123 -- After either mentions Before directly in a pragma Elaborate_All, or
124 -- mentions a third unit, X, which itself requires that Before be
125 -- elaborated before unit X is elaborated. The Elab_All_Link list traces
126 -- the dependencies in the latter case.
129 -- This is just like Elab_All, except that the Elaborate_All was not
130 -- explicitly present in the source, but rather was created by the front
131 -- end, which decided that it was "desirable".
134 -- This is just like Elab, except that the Elaborate was not explicitly
135 -- present in the source, but rather was created by the front end, which
136 -- decided that it was "desirable".
139 -- After is a body, and Before is the corresponding spec
141 -- Successor_Link contains the information for one link
143 type Successor_Link
is record
151 -- Next successor on this list
153 Reason
: Succ_Reason
;
154 -- Reason for this link
157 -- Set True if this link is needed for the special Elaborate_Body
158 -- processing described below.
160 Reason_Unit
: Unit_Id
;
161 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
162 -- containing the pragma leading to the link.
164 Elab_All_Link
: Elab_All_Id
;
165 -- If Reason = Elab_All or Elab_Desirable, then this points to the
166 -- first element in a list of Elab_All entries that record the with
167 -- chain resulting in this particular dependency.
170 -- Note on handling of Elaborate_Body. Basically, if we have a pragma
171 -- Elaborate_Body in a unit, it means that the spec and body have to be
172 -- handled as a single entity from the point of view of determining an
173 -- elaboration order. What we do is to essentially remove the body from
174 -- consideration completely, and transfer all its links (other than the
175 -- spec link) to the spec. Then when the spec gets chosen, we choose the
176 -- body right afterwards. We mark the links that get moved from the body to
177 -- the spec by setting their Elab_Body flag True, so that we can understand
180 Succ_First
: constant := 1;
182 package Succ
is new Table
.Table
183 (Table_Component_Type
=> Successor_Link
,
184 Table_Index_Type
=> Successor_Id
,
185 Table_Low_Bound
=> Succ_First
,
186 Table_Initial
=> 500,
187 Table_Increment
=> 200,
188 Table_Name
=> "Succ");
190 -- For the case of Elaborate_All, the following table is used to record
191 -- chains of with relationships that lead to the Elab_All link. These are
192 -- used solely for diagnostic purposes
194 type Elab_All_Entry
is record
195 Needed_By
: Unit_Name_Type
;
196 -- Name of unit from which referencing unit was with'ed or otherwise
197 -- needed as a result of Elaborate_All or Elaborate_Desirable.
199 Next_Elab
: Elab_All_Id
;
200 -- Link to next entry on chain (No_Elab_All_Link marks end of list)
203 package Elab_All_Entries
is new Table
.Table
204 (Table_Component_Type
=> Elab_All_Entry
,
205 Table_Index_Type
=> Elab_All_Id
,
206 Table_Low_Bound
=> 1,
207 Table_Initial
=> 2000,
208 Table_Increment
=> 200,
209 Table_Name
=> "Elab_All_Entries");
211 type Unit_Id_Array_Ptr
is access Unit_Id_Array
;
213 -- A Unit_Node_Record is built for each active unit
215 type Unit_Node_Record
is record
216 Successors
: Successor_Id
;
217 -- Pointer to list of links for successor nodes
220 -- Number of predecessors for this unit that have not yet been chosen.
221 -- Normally non-negative, but can go negative in the case of units
222 -- chosen by the diagnose error procedure (when cycles are being removed
226 -- Forward pointer for list of units with no predecessors
229 -- Used in computing transitive closure for Elaborate_All and also in
230 -- locating cycles and paths in the diagnose routines.
232 Elab_Position
: Natural;
233 -- Initialized to zero. Set non-zero when a unit is chosen and placed in
234 -- the elaboration order. The value represents the ordinal position in
235 -- the elaboration order.
237 -- The following are for Elab_New. We compute the strongly connected
238 -- components (SCCs) of the directed graph of units. The edges are the
239 -- Successors, which do not include pragmas Elaborate_All (explicit or
240 -- implicit) in Elab_New. In addition, we assume there is a edge
241 -- pointing from a body to its corresponding spec; this edge is not
242 -- included in Successors, because of course a spec is elaborated BEFORE
243 -- its body, not after.
246 -- Each unit points to the root of its SCC, which is just an arbitrary
247 -- member of the SCC. Two units are in the same SCC if and only if their
248 -- SCC_Roots are equal. U is the root of its SCC if and only if
251 Nodes
: Unit_Id_Array_Ptr
;
252 -- Present only in the root of an SCC. This is the set of units in the
253 -- SCC, in no particular order.
256 -- Present only in the root of an SCC. This is the number of predecessor
257 -- units of the SCC that are in other SCCs, and that have not yet been
260 Validate_Seen
: Boolean := False;
261 -- See procedure Validate below
264 package UNR
is new Table
.Table
265 (Table_Component_Type
=> Unit_Node_Record
,
266 Table_Index_Type
=> Unit_Id
,
267 Table_Low_Bound
=> First_Unit_Entry
,
268 Table_Initial
=> 500,
269 Table_Increment
=> 200,
270 Table_Name
=> "UNR");
273 -- Head of list of items with no predecessors
276 -- Number of entries not yet dealt with
279 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
280 -- set the Reason_Unit field of the created dependency link.
282 Num_Chosen
: Natural;
283 -- Number of units chosen in the elaboration order so far
285 -----------------------
286 -- Local Subprograms --
287 -----------------------
289 function Debug_Flag_Older
return Boolean;
290 function Debug_Flag_Old
return Boolean;
291 -- True if debug flags select the old or older algorithms. Pretty much any
292 -- change to elaboration order can break some programs. For example,
293 -- programs can depend on elaboration order even without failing
294 -- access-before-elaboration checks. A trivial example is a program that
295 -- prints text during elaboration. Therefore, we have flags to revert to
296 -- the old(er) algorithms.
298 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean);
299 -- Assert that certain properties are true
301 function Better_Choice_Optimistic
303 U2
: Unit_Id
) return Boolean;
304 -- U1 and U2 are both permitted candidates for selection as the next unit
305 -- to be elaborated. This function determines whether U1 is a better choice
306 -- than U2, i.e. should be elaborated in preference to U2, based on a set
307 -- of heuristics that establish a friendly and predictable order (see body
308 -- for details). The result is True if U1 is a better choice than U2, and
309 -- False if it is a worse choice, or there is no preference between them.
311 function Better_Choice_Pessimistic
313 U2
: Unit_Id
) return Boolean;
314 -- This is like Better_Choice_Optimistic, and has the same interface, but
315 -- returns true if U1 is a worse choice than U2 in the sense of the -p
316 -- (pessimistic elaboration order) switch. We still have to obey Ada rules,
317 -- so it is not quite the direct inverse of Better_Choice_Optimistic.
319 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean;
320 -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
321 -- appropriate. Also takes care of the U2 = No_Unit_Id case.
327 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
);
328 -- Establish a successor link, Before must be elaborated before After, and
329 -- the reason for the link is R. Ea_Id is the contents to be placed in the
330 -- Elab_All_Link of the entry.
332 procedure Choose
(Elab_Order
: in out Unit_Id_Table
; Chosen
: Unit_Id
);
333 -- Chosen is the next entry chosen in the elaboration order. This procedure
334 -- updates all data structures appropriately.
336 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
;
337 pragma Inline
(Corresponding_Body
);
338 -- Given a unit that is a spec for which there is a separate body, return
339 -- the unit id of the body. It is an error to call this routine with a unit
340 -- that is not a spec, or that does not have a separate body.
342 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
;
343 pragma Inline
(Corresponding_Spec
);
344 -- Given a unit that is a body for which there is a separate spec, return
345 -- the unit id of the spec. It is an error to call this routine with a unit
346 -- that is not a body, or that does not have a separate spec.
348 procedure Diagnose_Elaboration_Problem
349 (Elab_Order
: in out Unit_Id_Table
);
350 -- Called when no elaboration order can be found. Outputs an appropriate
351 -- diagnosis of the problem, and then abandons the bind.
353 procedure Elab_All_Links
356 Reason
: Succ_Reason
;
358 -- Used to compute the transitive closure of elaboration links for an
359 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
360 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a
361 -- pragma Elaborate_All or the front end has determined that a reference
362 -- probably requires Elaborate_All, and unit Before must be previously
363 -- elaborated. First a link is built making sure that unit Before is
364 -- elaborated before After, then a recursive call ensures that we also
365 -- build links for any units needed by Before (i.e. these units must/should
366 -- also be elaborated before After). Link is used to build a chain of
367 -- Elab_All_Entries to explain the reason for a link. The value passed is
370 procedure Elab_Error_Msg
(S
: Successor_Id
);
371 -- Given a successor link, outputs an error message of the form
372 -- "$ must be elaborated before $ ..." where ... is the reason.
374 procedure Force_Elab_Order
;
375 -- Gather dependencies from the forced elaboration order file (-f switch)
377 procedure Gather_Dependencies
;
378 -- Compute dependencies, building the Succ and UNR tables
381 -- Initialize global data structures in this package body
383 function Is_Body_Unit
(U
: Unit_Id
) return Boolean;
384 pragma Inline
(Is_Body_Unit
);
385 -- Determines if given unit is a body
387 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean;
388 -- Returns True if corresponding unit is Pure or Preelaborate. Includes
389 -- dealing with testing flags on spec if it is given a body.
391 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean;
392 pragma Inline
(Is_Waiting_Body
);
393 -- Determines if U is a waiting body, defined as a body that has
394 -- not been elaborated, but whose spec has been elaborated.
396 function Make_Elab_All_Entry
397 (Unam
: Unit_Name_Type
;
398 Link
: Elab_All_Id
) return Elab_All_Id
;
399 -- Make an Elab_All_Entries table entry with the given Unam and Link
401 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
;
402 -- This function uses the Info field set in the names table to obtain
403 -- the unit Id of a unit, given its name id value.
405 procedure Write_Closure
(Order
: Unit_Id_Array
);
406 -- Write the closure. This is for the -R and -Ra switches, "list closure
409 procedure Write_Dependencies
;
410 -- Write out dependencies (called only if appropriate option is set)
412 procedure Write_Elab_All_Chain
(S
: Successor_Id
);
413 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
414 -- then this routine will output the "needed by" explanation chain.
416 procedure Write_Elab_Order
(Order
: Unit_Id_Array
; Title
: String);
417 -- Display elaboration order. This is for the -l switch. Title is a heading
418 -- to print; an empty string is passed to indicate Zero_Formatting.
422 -- Implementation of the new algorithm
424 procedure Write_SCC
(U
: Unit_Id
);
425 -- Write the unit names of the units in the SCC in which U lives
427 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
429 Illegal_Elab_All
: Boolean := False;
430 -- Set true if Find_Elab_Order found an illegal pragma Elaborate_All
431 -- (explicit or implicit).
433 function SCC
(U
: Unit_Id
) return Unit_Id
;
434 -- The root of the strongly connected component containing U
436 function SCC_Num_Pred
(U
: Unit_Id
) return Int
;
437 -- The SCC_Num_Pred of the SCC in which U lives
439 function Nodes
(U
: Unit_Id
) return Unit_Id_Array_Ptr
;
440 -- The nodes of the strongly connected component containing U
448 -- Implementation of the old algorithm
450 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
454 -- Most of the code is shared between old and new; such code is outside
455 -- packages Elab_Old and Elab_New.
461 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean is
462 pragma Assert
(U1
/= No_Unit_Id
);
464 if U2
= No_Unit_Id
then
468 if Pessimistic_Elab_Order
then
469 return Better_Choice_Pessimistic
(U1
, U2
);
471 return Better_Choice_Optimistic
(U1
, U2
);
475 ------------------------------
476 -- Better_Choice_Optimistic --
477 ------------------------------
479 function Better_Choice_Optimistic
481 U2
: Unit_Id
) return Boolean
483 UT1
: Unit_Record
renames Units
.Table
(U1
);
484 UT2
: Unit_Record
renames Units
.Table
(U2
);
488 Write_Str
("Better_Choice_Optimistic (");
489 Write_Unit_Name
(UT1
.Uname
);
491 Write_Unit_Name
(UT2
.Uname
);
495 -- Note: the checks here are applied in sequence, and the ordering is
496 -- significant (i.e. the more important criteria are applied first).
498 -- Prefer a waiting body to one that is not a waiting body
500 if Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
502 Write_Line
(" True: u1 is waiting body, u2 is not");
507 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
509 Write_Line
(" False: u2 is waiting body, u1 is not");
514 -- Prefer a predefined unit to a non-predefined unit
516 elsif UT1
.Predefined
and then not UT2
.Predefined
then
518 Write_Line
(" True: u1 is predefined, u2 is not");
523 elsif UT2
.Predefined
and then not UT1
.Predefined
then
525 Write_Line
(" False: u2 is predefined, u1 is not");
530 -- Prefer an internal unit to a non-internal unit
532 elsif UT1
.Internal
and then not UT2
.Internal
then
534 Write_Line
(" True: u1 is internal, u2 is not");
538 elsif UT2
.Internal
and then not UT1
.Internal
then
540 Write_Line
(" False: u2 is internal, u1 is not");
545 -- Prefer a pure or preelaborated unit to one that is not. Pure should
546 -- come before preelaborated.
548 elsif Is_Pure_Or_Preelab_Unit
(U1
)
550 Is_Pure_Or_Preelab_Unit
(U2
)
553 Write_Line
(" True: u1 is pure/preelab, u2 is not");
558 elsif Is_Pure_Or_Preelab_Unit
(U2
)
560 Is_Pure_Or_Preelab_Unit
(U1
)
563 Write_Line
(" False: u2 is pure/preelab, u1 is not");
568 -- Prefer a body to a spec
570 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
572 Write_Line
(" True: u1 is body, u2 is not");
577 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
579 Write_Line
(" False: u2 is body, u1 is not");
584 -- If both are waiting bodies, then prefer the one whose spec is more
585 -- recently elaborated. Consider the following:
591 -- The normal waiting body preference would have placed the body of A
592 -- before the spec of B if it could. Since it could not, then it must be
593 -- the case that A depends on B. It is therefore a good idea to put the
596 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
598 Result
: constant Boolean :=
599 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
>
600 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
604 Write_Line
(" True: based on waiting body elab positions");
606 Write_Line
(" False: based on waiting body elab positions");
614 -- Remaining choice rules are disabled by Debug flag -do
616 if not Debug_Flag_Older
then
618 -- The following deal with the case of specs that have been marked
619 -- as Elaborate_Body_Desirable. We generally want to delay these
620 -- specs as long as possible, so that the bodies have a better chance
621 -- of being elaborated closer to the specs.
623 -- If we have two units, one of which is a spec for which this flag
624 -- is set, and the other is not, we prefer to delay the spec for
625 -- which the flag is set.
627 if not UT1
.Elaborate_Body_Desirable
628 and then UT2
.Elaborate_Body_Desirable
631 Write_Line
(" True: u1 is elab body desirable, u2 is not");
636 elsif not UT2
.Elaborate_Body_Desirable
637 and then UT1
.Elaborate_Body_Desirable
640 Write_Line
(" False: u1 is elab body desirable, u2 is not");
645 -- If we have two specs that are both marked as Elaborate_Body
646 -- desirable, we prefer the one whose body is nearer to being able
647 -- to be elaborated, based on the Num_Pred count. This helps to
648 -- ensure bodies are as close to specs as possible.
650 elsif UT1
.Elaborate_Body_Desirable
651 and then UT2
.Elaborate_Body_Desirable
654 Result
: constant Boolean :=
655 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
656 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
660 Write_Line
(" True based on Num_Pred compare");
662 Write_Line
(" False based on Num_Pred compare");
671 -- If we have two specs in the same SCC, choose the one whose body is
672 -- closer to being ready.
675 and then SCC
(U1
) = SCC
(U2
)
676 and then Units
.Table
(U1
).Utype
= Is_Spec
677 and then Units
.Table
(U2
).Utype
= Is_Spec
678 and then UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
/=
679 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
681 if UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
682 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
685 Write_Str
(" True: same SCC; ");
686 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
688 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
695 Write_Str
(" False: same SCC; ");
696 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
698 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
706 -- If we fall through, it means that no preference rule applies, so we
707 -- use alphabetical order to at least give a deterministic result.
710 Write_Line
(" choose on alpha order");
713 return Uname_Less
(UT1
.Uname
, UT2
.Uname
);
714 end Better_Choice_Optimistic
;
716 -------------------------------
717 -- Better_Choice_Pessimistic --
718 -------------------------------
720 function Better_Choice_Pessimistic
722 U2
: Unit_Id
) return Boolean
724 UT1
: Unit_Record
renames Units
.Table
(U1
);
725 UT2
: Unit_Record
renames Units
.Table
(U2
);
729 Write_Str
("Better_Choice_Pessimistic (");
730 Write_Unit_Name
(UT1
.Uname
);
732 Write_Unit_Name
(UT2
.Uname
);
736 -- Note: the checks here are applied in sequence, and the ordering is
737 -- significant (i.e. the more important criteria are applied first).
739 -- If either unit is predefined or internal, then we use the normal
740 -- Better_Choice_Optimistic rule, since we don't want to disturb the
741 -- elaboration rules of the language with -p; same treatment for
744 -- Prefer a predefined unit to a non-predefined unit
746 if UT1
.Predefined
and then not UT2
.Predefined
then
748 Write_Line
(" True: u1 is predefined, u2 is not");
753 elsif UT2
.Predefined
and then not UT1
.Predefined
then
755 Write_Line
(" False: u2 is predefined, u1 is not");
760 -- Prefer an internal unit to a non-internal unit
762 elsif UT1
.Internal
and then not UT2
.Internal
then
764 Write_Line
(" True: u1 is internal, u2 is not");
769 elsif UT2
.Internal
and then not UT1
.Internal
then
771 Write_Line
(" False: u2 is internal, u1 is not");
776 -- Prefer a pure or preelaborated unit to one that is not
778 elsif Is_Pure_Or_Preelab_Unit
(U1
)
780 Is_Pure_Or_Preelab_Unit
(U2
)
783 Write_Line
(" True: u1 is pure/preelab, u2 is not");
788 elsif Is_Pure_Or_Preelab_Unit
(U2
)
790 Is_Pure_Or_Preelab_Unit
(U1
)
793 Write_Line
(" False: u2 is pure/preelab, u1 is not");
798 -- Prefer anything else to a waiting body. We want to make bodies wait
799 -- as long as possible, till we are forced to choose them.
801 elsif Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
803 Write_Line
(" False: u1 is waiting body, u2 is not");
808 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
810 Write_Line
(" True: u2 is waiting body, u1 is not");
815 -- Prefer a spec to a body (this is mandatory)
817 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
819 Write_Line
(" False: u1 is body, u2 is not");
824 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
826 Write_Line
(" True: u2 is body, u1 is not");
831 -- If both are waiting bodies, then prefer the one whose spec is less
832 -- recently elaborated. Consider the following:
838 -- The normal waiting body preference would have placed the body of A
839 -- before the spec of B if it could. Since it could not, then it must be
840 -- the case that A depends on B. It is therefore a good idea to put the
841 -- body of B last so that if there is an elaboration order problem, we
842 -- will find it (that's what pessimistic order is about).
844 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
846 Result
: constant Boolean :=
847 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
<
848 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
852 Write_Line
(" True: based on waiting body elab positions");
854 Write_Line
(" False: based on waiting body elab positions");
862 -- Remaining choice rules are disabled by Debug flag -do
864 if not Debug_Flag_Older
then
866 -- The following deal with the case of specs that have been marked as
867 -- Elaborate_Body_Desirable. In the normal case, we generally want to
868 -- delay the elaboration of these specs as long as possible, so that
869 -- bodies have better chance of being elaborated closer to the specs.
870 -- Better_Choice_Pessimistic as usual wants to do the opposite and
871 -- elaborate such specs as early as possible.
873 -- If we have two units, one of which is a spec for which this flag
874 -- is set, and the other is not, we normally prefer to delay the spec
875 -- for which the flag is set, so again Better_Choice_Pessimistic does
878 if not UT1
.Elaborate_Body_Desirable
879 and then UT2
.Elaborate_Body_Desirable
882 Write_Line
(" False: u1 is elab body desirable, u2 is not");
887 elsif not UT2
.Elaborate_Body_Desirable
888 and then UT1
.Elaborate_Body_Desirable
891 Write_Line
(" True: u1 is elab body desirable, u2 is not");
896 -- If we have two specs that are both marked as Elaborate_Body
897 -- desirable, we normally prefer the one whose body is nearer to
898 -- being able to be elaborated, based on the Num_Pred count. This
899 -- helps to ensure bodies are as close to specs as possible. As
900 -- usual, Better_Choice_Pessimistic does the opposite.
902 elsif UT1
.Elaborate_Body_Desirable
903 and then UT2
.Elaborate_Body_Desirable
906 Result
: constant Boolean :=
907 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
>=
908 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
912 Write_Line
(" True based on Num_Pred compare");
914 Write_Line
(" False based on Num_Pred compare");
923 -- If we fall through, it means that no preference rule applies, so we
924 -- use alphabetical order to at least give a deterministic result. Since
925 -- Better_Choice_Pessimistic is in the business of stirring up the
926 -- order, we will use reverse alphabetical ordering.
929 Write_Line
(" choose on reverse alpha order");
932 return Uname_Less
(UT2
.Uname
, UT1
.Uname
);
933 end Better_Choice_Pessimistic
;
943 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
)
950 After
=> No_Unit_Id
, -- filled in below
951 Next
=> UNR
.Table
(Before
).Successors
,
953 Elab_Body
=> False, -- set correctly below
954 Reason_Unit
=> Cur_Unit
,
955 Elab_All_Link
=> Ea_Id
));
956 UNR
.Table
(Before
).Successors
:= Succ
.Last
;
958 -- Deal with special Elab_Body case. If the After of this link is
959 -- a body whose spec has Elaborate_All set, and this is not the link
960 -- directly from the body to the spec, then we make the After of the
961 -- link reference its spec instead, marking the link appropriately.
963 if Units
.Table
(After
).Utype
= Is_Body
then
964 Cspec
:= Corresponding_Spec
(After
);
966 if Units
.Table
(Cspec
).Elaborate_Body
967 and then Cspec
/= Before
969 Succ
.Table
(Succ
.Last
).After
:= Cspec
;
970 Succ
.Table
(Succ
.Last
).Elab_Body
:= True;
971 UNR
.Table
(Cspec
).Num_Pred
:= UNR
.Table
(Cspec
).Num_Pred
+ 1;
976 -- Fall through on normal case
978 Succ
.Table
(Succ
.Last
).After
:= After
;
979 Succ
.Table
(Succ
.Last
).Elab_Body
:= False;
980 UNR
.Table
(After
).Num_Pred
:= UNR
.Table
(After
).Num_Pred
+ 1;
987 procedure Choose
(Elab_Order
: in out Unit_Id_Table
; Chosen
: Unit_Id
) is
988 pragma Assert
(Chosen
/= No_Unit_Id
);
994 Write_Str
("Choosing Unit ");
995 Write_Unit_Name
(Units
.Table
(Chosen
).Uname
);
999 -- We shouldn't be choosing something with unelaborated predecessors,
1000 -- and we shouldn't call this twice on the same unit. But that's not
1001 -- true when this is called from Diagnose_Elaboration_Problem.
1003 if Errors_Detected
= 0 then
1004 pragma Assert
(UNR
.Table
(Chosen
).Num_Pred
= 0);
1005 pragma Assert
(UNR
.Table
(Chosen
).Elab_Position
= 0);
1006 pragma Assert
(not Doing_New
or else SCC_Num_Pred
(Chosen
) = 0);
1010 -- Add to elaboration order. Note that units having no elaboration code
1011 -- are not treated specially yet. The special casing of this is in
1012 -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
1013 -- here, because the object file list is also driven by the contents of
1014 -- the Elab_Order table.
1016 Append
(Elab_Order
, Chosen
);
1018 -- Remove from No_Pred list. This is a little inefficient and may be we
1019 -- should doubly link the list, but it will do for now.
1021 if No_Pred
= Chosen
then
1022 No_Pred
:= UNR
.Table
(Chosen
).Nextnp
;
1025 -- Note that we just ignore the situation where it does not
1026 -- appear in the No_Pred list, this happens in calls from the
1027 -- Diagnose_Elaboration_Problem routine, where cycles are being
1028 -- removed arbitrarily from the graph.
1031 while U
/= No_Unit_Id
loop
1032 if UNR
.Table
(U
).Nextnp
= Chosen
then
1033 UNR
.Table
(U
).Nextnp
:= UNR
.Table
(Chosen
).Nextnp
;
1037 U
:= UNR
.Table
(U
).Nextnp
;
1041 -- For all successors, decrement the number of predecessors, and if it
1042 -- becomes zero, then add to no-predecessor list.
1044 S
:= UNR
.Table
(Chosen
).Successors
;
1045 while S
/= No_Successor
loop
1046 U
:= Succ
.Table
(S
).After
;
1047 UNR
.Table
(U
).Num_Pred
:= UNR
.Table
(U
).Num_Pred
- 1;
1049 if Debug_Flag_N
then
1050 Write_Str
(" decrementing Num_Pred for unit ");
1051 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1052 Write_Str
(" new value = ");
1053 Write_Int
(UNR
.Table
(U
).Num_Pred
);
1057 if UNR
.Table
(U
).Num_Pred
= 0 then
1058 UNR
.Table
(U
).Nextnp
:= No_Pred
;
1062 if Doing_New
and then SCC
(U
) /= SCC
(Chosen
) then
1063 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
:=
1064 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
- 1;
1066 if Debug_Flag_N
then
1067 Write_Str
(" decrementing SCC_Num_Pred for unit ");
1068 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1069 Write_Str
(" new value = ");
1070 Write_Int
(SCC_Num_Pred
(U
));
1075 S
:= Succ
.Table
(S
).Next
;
1078 -- All done, adjust number of units left count and set elaboration pos
1080 Num_Left
:= Num_Left
- 1;
1081 Num_Chosen
:= Num_Chosen
+ 1;
1084 (Errors_Detected
> 0 or else Num_Chosen
= Natural (Last
(Elab_Order
)));
1086 UNR
.Table
(Chosen
).Elab_Position
:= Num_Chosen
;
1088 -- If we just chose a spec with Elaborate_Body set, then we must
1089 -- immediately elaborate the body, before any other units.
1091 if Units
.Table
(Chosen
).Elaborate_Body
then
1093 -- If the unit is a spec only, then there is no body. This is a bit
1094 -- odd given that Elaborate_Body is here, but it is valid in an RCI
1095 -- unit, where we only have the interface in the stub bind.
1097 if Units
.Table
(Chosen
).Utype
= Is_Spec_Only
1098 and then Units
.Table
(Chosen
).RCI
1102 Choose
(Elab_Order
, Corresponding_Body
(Chosen
));
1107 ------------------------
1108 -- Corresponding_Body --
1109 ------------------------
1111 -- Currently if the body and spec are separate, then they appear as two
1112 -- separate units in the same ALI file, with the body appearing first and
1113 -- the spec appearing second.
1115 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
is
1117 pragma Assert
(Units
.Table
(U
).Utype
= Is_Spec
);
1119 end Corresponding_Body
;
1121 ------------------------
1122 -- Corresponding_Spec --
1123 ------------------------
1125 -- Currently if the body and spec are separate, then they appear as two
1126 -- separate units in the same ALI file, with the body appearing first and
1127 -- the spec appearing second.
1129 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
is
1131 pragma Assert
(Units
.Table
(U
).Utype
= Is_Body
);
1133 end Corresponding_Spec
;
1135 --------------------
1136 -- Debug_Flag_Old --
1137 --------------------
1139 function Debug_Flag_Old
return Boolean is
1141 return Debug_Flag_P
;
1144 ----------------------
1145 -- Debug_Flag_Older --
1146 ----------------------
1148 function Debug_Flag_Older
return Boolean is
1150 return Debug_Flag_O
;
1151 end Debug_Flag_Older
;
1153 ----------------------------------
1154 -- Diagnose_Elaboration_Problem --
1155 ----------------------------------
1157 procedure Diagnose_Elaboration_Problem
1158 (Elab_Order
: in out Unit_Id_Table
)
1163 ML
: Nat
) return Boolean;
1164 -- Recursive routine used to find a path from node Ufrom to node Uto.
1165 -- If a path exists, returns True and outputs an appropriate set of
1166 -- error messages giving the path. Also calls Choose for each of the
1167 -- nodes so that they get removed from the remaining set. There are
1168 -- two cases of calls, either Ufrom = Uto for an attempt to find a
1169 -- cycle, or Ufrom is a spec and Uto the corresponding body for the
1170 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
1171 -- acceptable length for a path.
1180 ML
: Nat
) return Boolean
1182 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean;
1183 -- This is the inner recursive routine, it determines if a path
1184 -- exists from U to Uto, and if so returns True and outputs the
1185 -- appropriate set of error messages. PL is the path length
1191 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean is
1195 -- Recursion ends if we are at terminating node and the path is
1196 -- sufficiently long, generate error message and return True.
1198 if U
= Uto
and then PL
>= ML
then
1199 Choose
(Elab_Order
, U
);
1202 -- All done if already visited
1204 elsif UNR
.Table
(U
).Visited
then
1207 -- Otherwise mark as visited and look at all successors
1210 UNR
.Table
(U
).Visited
:= True;
1212 S
:= UNR
.Table
(U
).Successors
;
1213 while S
/= No_Successor
loop
1214 if Find_Link
(Succ
.Table
(S
).After
, PL
+ 1) then
1216 Choose
(Elab_Order
, U
);
1220 S
:= Succ
.Table
(S
).Next
;
1223 -- Falling through means this does not lead to a path
1229 -- Start of processing for Find_Path
1232 -- Initialize all non-chosen nodes to not visited yet
1234 for U
in Units
.First
.. Units
.Last
loop
1235 UNR
.Table
(U
).Visited
:= UNR
.Table
(U
).Elab_Position
/= 0;
1238 -- Now try to find the path
1240 return Find_Link
(Ufrom
, 0);
1243 -- Start of processing for Diagnose_Elaboration_Problem
1248 -- Output state of things if debug flag N set
1250 if Debug_Flag_N
then
1257 Write_Str
("Diagnose_Elaboration_Problem called");
1259 Write_Str
("List of remaining unchosen units and predecessors");
1262 for U
in Units
.First
.. Units
.Last
loop
1263 if UNR
.Table
(U
).Elab_Position
= 0 then
1264 NP
:= UNR
.Table
(U
).Num_Pred
;
1266 Write_Str
(" Unchosen unit: #");
1267 Write_Int
(Int
(U
));
1269 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1270 Write_Str
(" (Num_Pred = ");
1276 if Units
.Table
(U
).Elaborate_Body
then
1278 (" (not chosen because of Elaborate_Body)");
1281 Write_Str
(" ****************** why not chosen?");
1286 -- Search links list to find unchosen predecessors
1288 for S
in Succ
.First
.. Succ
.Last
loop
1290 SL
: Successor_Link
renames Succ
.Table
(S
);
1294 and then UNR
.Table
(SL
.Before
).Elab_Position
= 0
1296 Write_Str
(" unchosen predecessor: #");
1297 Write_Int
(Int
(SL
.Before
));
1299 Write_Unit_Name
(Units
.Table
(SL
.Before
).Uname
);
1307 Write_Str
(" **************** Num_Pred value wrong!");
1315 -- Output the header for the error, and manually increment the error
1316 -- count. We are using Error_Msg_Output rather than Error_Msg here for
1319 -- This is really only one error, not one for each line
1320 -- We want this output on standard output since it is voluminous
1322 -- But we do need to deal with the error count manually in this case
1324 Errors_Detected
:= Errors_Detected
+ 1;
1325 Error_Msg_Output
("elaboration circularity detected", Info
=> False);
1327 -- Try to find cycles starting with any of the remaining nodes that have
1328 -- not yet been chosen. There must be at least one (there is some reason
1329 -- we are being called).
1331 for U
in Units
.First
.. Units
.Last
loop
1332 if UNR
.Table
(U
).Elab_Position
= 0 then
1333 if Find_Path
(U
, U
, 1) then
1334 raise Unrecoverable_Error
;
1339 -- We should never get here, since we were called for some reason, and
1340 -- we should have found and eliminated at least one bad path.
1342 raise Program_Error
;
1343 end Diagnose_Elaboration_Problem
;
1345 --------------------
1346 -- Elab_All_Links --
1347 --------------------
1349 procedure Elab_All_Links
1352 Reason
: Succ_Reason
;
1356 if UNR
.Table
(Before
).Visited
then
1360 -- Build the direct link for Before
1362 UNR
.Table
(Before
).Visited
:= True;
1363 Build_Link
(Before
, After
, Reason
, Link
);
1365 -- Process all units with'ed by Before recursively
1367 for W
in Units
.Table
(Before
).First_With
..
1368 Units
.Table
(Before
).Last_With
1370 -- Skip if this with is an interface to a stand-alone library. Skip
1371 -- also if no ALI file for this WITH, happens for language defined
1372 -- generics while bootstrapping the compiler (see body of routine
1373 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
1374 -- clause, which does not impose an elaboration link.
1376 if not Withs
.Table
(W
).SAL_Interface
1377 and then Withs
.Table
(W
).Afile
/= No_File
1378 and then not Withs
.Table
(W
).Limited_With
1381 Info
: constant Int
:=
1382 Get_Name_Table_Int
(Withs
.Table
(W
).Uname
);
1385 -- If the unit is unknown, for some unknown reason, fail
1386 -- graciously explaining that the unit is unknown. Without
1387 -- this check, gnatbind will crash in Unit_Id_Of.
1389 if Info
= 0 or else Unit_Id
(Info
) = No_Unit_Id
then
1392 Get_Name_String
(Withs
.Table
(W
).Uname
);
1393 Last_Withed
: Natural := Withed
'Last;
1396 (Units
.Table
(Before
).Uname
);
1397 Last_Withing
: Natural := Withing
'Last;
1398 Spec_Body
: String := " (Spec)";
1405 and then Withed
(Last_Withed
- 1) = '%'
1407 Last_Withed
:= Last_Withed
- 2;
1411 and then Withing
(Last_Withing
- 1) = '%'
1413 Last_Withing
:= Last_Withing
- 2;
1416 if Units
.Table
(Before
).Utype
= Is_Body
1417 or else Units
.Table
(Before
).Utype
= Is_Body_Only
1419 Spec_Body
:= " (Body)";
1423 ("could not find unit "
1424 & Withed
(Withed
'First .. Last_Withed
) & " needed by "
1425 & Withing
(Withing
'First .. Last_Withing
) & Spec_Body
);
1430 (Unit_Id_Of
(Withs
.Table
(W
).Uname
),
1433 Make_Elab_All_Entry
(Withs
.Table
(W
).Uname
, Link
));
1438 -- Process corresponding body, if there is one
1440 if Units
.Table
(Before
).Utype
= Is_Spec
then
1442 (Corresponding_Body
(Before
),
1445 (Units
.Table
(Corresponding_Body
(Before
)).Uname
, Link
));
1449 --------------------
1450 -- Elab_Error_Msg --
1451 --------------------
1453 procedure Elab_Error_Msg
(S
: Successor_Id
) is
1454 SL
: Successor_Link
renames Succ
.Table
(S
);
1457 -- Nothing to do if internal unit involved and no -da flag
1461 (Is_Internal_File_Name
(Units
.Table
(SL
.Before
).Sfile
)
1463 Is_Internal_File_Name
(Units
.Table
(SL
.After
).Sfile
))
1468 -- Here we want to generate output
1470 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1472 if SL
.Elab_Body
then
1473 Error_Msg_Unit_2
:= Units
.Table
(Corresponding_Body
(SL
.After
)).Uname
;
1475 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1478 Error_Msg_Output
(" $ must be elaborated before $", Info
=> True);
1480 Error_Msg_Unit_1
:= Units
.Table
(SL
.Reason_Unit
).Uname
;
1485 (" reason: with clause",
1490 (" reason: forced by -f switch",
1495 (" reason: pragma Elaborate in unit $",
1500 (" reason: pragma Elaborate_All in unit $",
1503 when Elab_All_Desirable
=>
1505 (" reason: implicit Elaborate_All in unit $",
1509 (" recompile $ with -gnatel for full details",
1512 when Elab_Desirable
=>
1514 (" reason: implicit Elaborate in unit $",
1518 (" recompile $ with -gnatel for full details",
1523 (" reason: spec always elaborated before body",
1527 Write_Elab_All_Chain
(S
);
1529 if SL
.Elab_Body
then
1530 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1531 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1533 (" $ must therefore be elaborated before $", True);
1535 Error_Msg_Unit_1
:= Units
.Table
(SL
.After
).Uname
;
1537 (" (because $ has a pragma Elaborate_Body)", True);
1540 if not Zero_Formatting
then
1545 ---------------------
1546 -- Find_Elab_Order --
1547 ---------------------
1549 procedure Find_Elab_Order
1550 (Elab_Order
: out Unit_Id_Table
;
1551 First_Main_Lib_File
: File_Name_Type
)
1553 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
;
1554 -- Number of cases where the body of a unit immediately follows the
1555 -- corresponding spec. Such cases are good, because calls to that unit
1556 -- from outside can't get ABE.
1558 -------------------------
1559 -- Num_Spec_Body_Pairs --
1560 -------------------------
1562 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
is
1566 for J
in Order
'First + 1 .. Order
'Last loop
1567 if Units
.Table
(Order
(J
- 1)).Utype
= Is_Spec
1568 and then Units
.Table
(Order
(J
)).Utype
= Is_Body
1569 and then Corresponding_Spec
(Order
(J
)) = Order
(J
- 1)
1571 Result
:= Result
+ 1;
1576 end Num_Spec_Body_Pairs
;
1580 Old_Elab_Order
: Unit_Id_Table
;
1582 -- Start of processing for Find_Elab_Order
1585 -- Output warning if -p used with no -gnatE units
1587 if Pessimistic_Elab_Order
1588 and not Dynamic_Elaboration_Checks_Specified
1590 Error_Msg
("?use of -p switch questionable");
1591 Error_Msg
("?since all units compiled with static elaboration model");
1595 if Debug_Flag_V
then
1596 Write_Line
("Doing new...");
1601 Elab_New
.Find_Elab_Order
(Elab_Order
);
1604 -- Elab_New does not support the pessimistic order, so if that was
1605 -- requested, use the old results. Use Elab_Old if -dp was selected.
1606 -- Elab_New does not yet give proper error messages for illegal
1607 -- Elaborate_Alls, so if there is one, run Elab_Old.
1610 or Pessimistic_Elab_Order
1614 if Debug_Flag_V
then
1615 Write_Line
("Doing old...");
1620 Elab_Old
.Find_Elab_Order
(Old_Elab_Order
);
1624 Old_Order
: Unit_Id_Array
renames
1625 Old_Elab_Order
.Table
(1 .. Last
(Old_Elab_Order
));
1626 New_Order
: Unit_Id_Array
renames
1627 Elab_Order
.Table
(1 .. Last
(Elab_Order
));
1628 Old_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(Old_Order
);
1629 New_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(New_Order
);
1632 if Do_Old
and Do_New
then
1633 Write_Line
(Get_Name_String
(First_Main_Lib_File
));
1635 pragma Assert
(Old_Order
'Length = New_Order
'Length);
1636 pragma Debug
(Validate
(Old_Order
, Doing_New
=> False));
1637 pragma Debug
(Validate
(New_Order
, Doing_New
=> True));
1639 -- Misc debug printouts that can be used for experimentation by
1640 -- changing the 'if's below.
1643 if New_Order
= Old_Order
then
1644 Write_Line
("Elab_New: same order.");
1646 Write_Line
("Elab_New: diff order.");
1650 if New_Order
/= Old_Order
and then False then
1651 Write_Line
("Elaboration orders differ:");
1653 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1655 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1659 Write_Str
("Pairs: ");
1660 Write_Int
(Old_Pairs
);
1662 if Old_Pairs
= New_Pairs
then
1664 elsif Old_Pairs
< New_Pairs
then
1670 Write_Int
(New_Pairs
);
1674 if Old_Pairs
/= New_Pairs
and then False then
1675 Write_Str
("Pairs: ");
1676 Write_Int
(Old_Pairs
);
1678 if Old_Pairs
< New_Pairs
then
1684 Write_Int
(New_Pairs
);
1687 if Old_Pairs
/= New_Pairs
and then Debug_Flag_V
then
1689 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1691 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1692 pragma Assert
(New_Pairs
>= Old_Pairs
);
1697 -- The Elab_New algorithm doesn't implement the -p switch, so if that
1698 -- was used, use the results from the old algorithm.
1700 if Pessimistic_Elab_Order
or Debug_Flag_Old
then
1701 New_Order
:= Old_Order
;
1704 -- Now set the Elab_Positions in the Units table. It is important to
1705 -- do this late, in case we're running both Elab_New and Elab_Old.
1708 Units_Array
: Units
.Table_Type
renames
1709 Units
.Table
(Units
.First
.. Units
.Last
);
1712 for J
in New_Order
'Range loop
1714 (UNR
.Table
(New_Order
(J
)).Elab_Position
= Positive (J
));
1715 Units_Array
(New_Order
(J
)).Elab_Position
:= Positive (J
);
1719 if Errors_Detected
= 0 then
1721 -- Display elaboration order if -l was specified
1723 if Elab_Order_Output
then
1724 if Zero_Formatting
then
1725 Write_Elab_Order
(New_Order
, Title
=> "");
1727 Write_Elab_Order
(New_Order
, Title
=> "ELABORATION ORDER");
1731 -- Display list of sources in the closure (except predefined
1732 -- sources) if -R was used. Include predefined sources if -Ra
1735 if List_Closure
then
1736 Write_Closure
(New_Order
);
1740 end Find_Elab_Order
;
1742 ----------------------
1743 -- Force_Elab_Order --
1744 ----------------------
1746 procedure Force_Elab_Order
is
1748 -- There is a lot of fiddly string manipulation below, because we don't
1749 -- want to depend on misc utility packages like Ada.Characters.Handling.
1751 function Get_Line
return String;
1752 -- Read the next line from the file content read by Read_File. Strip
1753 -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
1754 -- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
1756 function Read_File
(Name
: String) return String_Ptr
;
1757 -- Read the entire contents of the named file
1763 function Read_File
(Name
: String) return String_Ptr
is
1765 -- All of the following calls should succeed, because we checked the
1766 -- file in Switch.B, but we double check and raise Program_Error on
1767 -- failure, just in case.
1769 F
: constant File_Descriptor
:= Open_Read
(Name
, Binary
);
1772 if F
= Invalid_FD
then
1773 raise Program_Error
;
1777 Len
: constant Natural := Natural (File_Length
(F
));
1778 Result
: constant String_Ptr
:= new String (1 .. Len
);
1779 Len_Read
: constant Natural :=
1780 Read
(F
, Result
(1)'Address, Len
);
1785 if Len_Read
/= Len
then
1786 raise Program_Error
;
1792 raise Program_Error
;
1799 Cur
: Positive := 1;
1800 S
: String_Ptr
:= Read_File
(Force_Elab_Order_File
.all);
1806 function Get_Line
return String is
1807 First
: Positive := Cur
;
1811 -- Skip to end of line
1814 and then S
(Cur
) /= ASCII
.LF
1815 and then S
(Cur
) /= ASCII
.CR
1820 -- Strip leading blanks
1822 while First
<= S
'Last and then S
(First
) = ' ' loop
1826 -- Strip trailing blanks and comment
1830 for J
in First
.. Last
- 1 loop
1831 if S
(J
.. J
+ 1) = "--" then
1837 while Last
>= First
and then S
(Last
) = ' ' loop
1841 -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks
1845 Body_String
: constant String := "(body)";
1846 BL
: constant Positive := Body_String
'Length;
1847 Spec_String
: constant String := "(spec)";
1848 SL
: constant Positive := Spec_String
'Length;
1850 Line
: String renames S
(First
.. Last
);
1852 Is_Body
: Boolean := False;
1853 Is_Spec
: Boolean := False;
1856 if Line
'Length >= SL
1857 and then Line
(Last
- SL
+ 1 .. Last
) = Spec_String
1861 elsif Line
'Length >= BL
1862 and then Line
(Last
- BL
+ 1 .. Last
) = Body_String
1868 while Last
>= First
and then S
(Last
) = ' ' loop
1872 -- Skip past LF or CR/LF
1874 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.CR
then
1878 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.LF
then
1883 return Line
(First
.. Last
) & "%s";
1885 return Line
(First
.. Last
) & "%b";
1894 Empty_Name
: constant Unit_Name_Type
:= Name_Find
("");
1895 Prev_Unit
: Unit_Id
:= No_Unit_Id
;
1897 -- Start of processing for Force_Elab_Order
1900 -- Loop through the file content, and build a dependency link for each
1901 -- pair of lines. Ignore lines that should be ignored.
1903 while Cur
<= S
'Last loop
1905 Uname
: constant Unit_Name_Type
:= Name_Find
(Get_Line
);
1908 if Uname
= Empty_Name
then
1909 null; -- silently skip blank lines
1911 elsif Get_Name_Table_Int
(Uname
) = 0
1912 or else Unit_Id
(Get_Name_Table_Int
(Uname
)) = No_Unit_Id
1916 ("""" & Get_Name_String
(Uname
)
1917 & """: not present; ignored");
1922 Cur_Unit
: constant Unit_Id
:= Unit_Id_Of
(Uname
);
1925 if Is_Internal_File_Name
(Units
.Table
(Cur_Unit
).Sfile
) then
1928 ("""" & Get_Name_String
(Uname
) &
1929 """: predefined unit ignored");
1933 if Prev_Unit
/= No_Unit_Id
then
1935 Write_Unit_Name
(Units
.Table
(Prev_Unit
).Uname
);
1936 Write_Str
(" <-- ");
1937 Write_Unit_Name
(Units
.Table
(Cur_Unit
).Uname
);
1942 (Before
=> Prev_Unit
,
1947 Prev_Unit
:= Cur_Unit
;
1955 end Force_Elab_Order
;
1957 -------------------------
1958 -- Gather_Dependencies --
1959 -------------------------
1961 procedure Gather_Dependencies
is
1962 Withed_Unit
: Unit_Id
;
1965 -- Loop through all units
1967 for U
in Units
.First
.. Units
.Last
loop
1970 -- If this is not an interface to a stand-alone library and there is
1971 -- a body and a spec, then spec must be elaborated first. Note that
1972 -- the corresponding spec immediately follows the body.
1974 if not Units
.Table
(U
).SAL_Interface
1975 and then Units
.Table
(U
).Utype
= Is_Body
1977 Build_Link
(Corresponding_Spec
(U
), U
, Spec_First
);
1980 -- If this unit is not an interface to a stand-alone library, process
1981 -- WITH references for this unit ignoring interfaces to stand-alone
1984 if not Units
.Table
(U
).SAL_Interface
then
1985 for W
in Units
.Table
(U
).First_With
..
1986 Units
.Table
(U
).Last_With
1988 if Withs
.Table
(W
).Sfile
/= No_File
1989 and then (not Withs
.Table
(W
).SAL_Interface
)
1991 -- Check for special case of withing a unit that does not
1992 -- exist any more. If the unit was completely missing we
1993 -- would already have detected this, but a nasty case arises
1994 -- when we have a subprogram body with no spec, and some
1995 -- obsolete unit with's a previous (now disappeared) spec.
1997 if Get_Name_Table_Int
(Withs
.Table
(W
).Uname
) = 0 then
1999 Error_Msg_File_1
:= Units
.Table
(U
).Sfile
;
2000 Error_Msg_Unit_1
:= Withs
.Table
(W
).Uname
;
2001 Error_Msg
("{ depends on $ which no longer exists");
2007 Withed_Unit
:= Unit_Id_Of
(Withs
.Table
(W
).Uname
);
2009 -- Pragma Elaborate_All case, for this we use the recursive
2010 -- Elab_All_Links procedure to establish the links.
2012 -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
2013 -- except for error messages.
2015 if Withs
.Table
(W
).Elaborate_All
and then not Doing_New
then
2017 -- Reset flags used to stop multiple visits to a given
2020 for Uref
in UNR
.First
.. UNR
.Last
loop
2021 UNR
.Table
(Uref
).Visited
:= False;
2024 -- Now establish all the links we need
2027 (Withed_Unit
, U
, Elab_All
,
2029 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2031 -- Elaborate_All_Desirable case, for this we establish the
2032 -- same links as above, but with a different reason.
2034 elsif Withs
.Table
(W
).Elab_All_Desirable
2035 and then not Doing_New
2037 -- Reset flags used to stop multiple visits to a given
2040 for Uref
in UNR
.First
.. UNR
.Last
loop
2041 UNR
.Table
(Uref
).Visited
:= False;
2044 -- Now establish all the links we need
2047 (Withed_Unit
, U
, Elab_All_Desirable
,
2049 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2051 -- Pragma Elaborate case. We must build a link for the
2052 -- withed unit itself, and also the corresponding body if
2055 -- However, skip this processing if there is no ALI file for
2056 -- the WITH entry, because this means it is a generic (even
2057 -- when we fix the generics so that an ALI file is present,
2058 -- we probably still will have no ALI file for unchecked and
2059 -- other special cases).
2061 elsif Withs
.Table
(W
).Elaborate
2062 and then Withs
.Table
(W
).Afile
/= No_File
2064 Build_Link
(Withed_Unit
, U
, Withed
);
2066 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2068 (Corresponding_Body
(Withed_Unit
), U
, Elab
);
2071 -- Elaborate_Desirable case, for this we establish the same
2072 -- links as above, but with a different reason.
2074 elsif Withs
.Table
(W
).Elab_Desirable
then
2075 Build_Link
(Withed_Unit
, U
, Withed
);
2077 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2079 (Corresponding_Body
(Withed_Unit
),
2083 -- A limited_with does not establish an elaboration
2084 -- dependence (that's the whole point).
2086 elsif Withs
.Table
(W
).Limited_With
then
2089 -- Case of normal WITH with no elaboration pragmas, just
2090 -- build the single link to the directly referenced unit
2093 Build_Link
(Withed_Unit
, U
, Withed
);
2103 -- If -f<elab_order> switch was given, take into account dependences
2104 -- specified in the file <elab_order>.
2106 if Force_Elab_Order_File
/= null then
2110 -- Output elaboration dependencies if option is set
2112 if Elab_Dependency_Output
or Debug_Flag_E
then
2117 end Gather_Dependencies
;
2126 Num_Left
:= Int
(Units
.Last
- Units
.First
+ 1);
2128 Elab_All_Entries
.Init
;
2131 -- Initialize unit table for elaboration control
2133 for U
in Units
.First
.. Units
.Last
loop
2135 ((Successors
=> No_Successor
,
2137 Nextnp
=> No_Unit_Id
,
2140 SCC_Root
=> No_Unit_Id
,
2143 Validate_Seen
=> False));
2151 function Is_Body_Unit
(U
: Unit_Id
) return Boolean is
2154 Units
.Table
(U
).Utype
= Is_Body
2155 or else Units
.Table
(U
).Utype
= Is_Body_Only
;
2158 -----------------------------
2159 -- Is_Pure_Or_Preelab_Unit --
2160 -----------------------------
2162 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean is
2164 -- If we have a body with separate spec, test flags on the spec
2166 if Units
.Table
(U
).Utype
= Is_Body
then
2168 Units
.Table
(Corresponding_Spec
(U
)).Preelab
2169 or else Units
.Table
(Corresponding_Spec
(U
)).Pure
;
2171 -- Otherwise we have a spec or body acting as spec, test flags on unit
2174 return Units
.Table
(U
).Preelab
or else Units
.Table
(U
).Pure
;
2176 end Is_Pure_Or_Preelab_Unit
;
2178 ---------------------
2179 -- Is_Waiting_Body --
2180 ---------------------
2182 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean is
2185 Units
.Table
(U
).Utype
= Is_Body
2186 and then UNR
.Table
(Corresponding_Spec
(U
)).Elab_Position
/= 0;
2187 end Is_Waiting_Body
;
2189 -------------------------
2190 -- Make_Elab_All_Entry --
2191 -------------------------
2193 function Make_Elab_All_Entry
2194 (Unam
: Unit_Name_Type
;
2195 Link
: Elab_All_Id
) return Elab_All_Id
2198 Elab_All_Entries
.Append
((Needed_By
=> Unam
, Next_Elab
=> Link
));
2199 return Elab_All_Entries
.Last
;
2200 end Make_Elab_All_Entry
;
2206 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
is
2207 Info
: constant Int
:= Get_Name_Table_Int
(Uname
);
2210 pragma Assert
(Info
/= 0 and then Unit_Id
(Info
) /= No_Unit_Id
);
2211 return Unit_Id
(Info
);
2218 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean) is
2219 Cur_SCC
: Unit_Id
:= No_Unit_Id
;
2220 OK
: Boolean := True;
2221 Msg
: String := "Old: ";
2228 -- For each unit, assert that its successors are elaborated after it
2230 for J
in Order
'Range loop
2232 U
: constant Unit_Id
:= Order
(J
);
2233 S
: Successor_Id
:= UNR
.Table
(U
).Successors
;
2236 while S
/= No_Successor
loop
2238 (UNR
.Table
(Succ
.Table
(S
).After
).Elab_Position
>
2239 UNR
.Table
(U
).Elab_Position
,
2240 Msg
& " elab order failed");
2241 S
:= Succ
.Table
(S
).Next
;
2246 -- An SCC of size 2 units necessarily consists of a spec and the
2247 -- corresponding body. Assert that the body is elaborated immediately
2248 -- after the spec, with nothing in between. (We only have SCCs in the
2252 for J
in Order
'Range loop
2254 U
: constant Unit_Id
:= Order
(J
);
2257 if Nodes
(U
)'Length = 2 then
2258 if Units
.Table
(U
).Utype
= Is_Spec
then
2259 if Order
(J
+ 1) /= Corresponding_Body
(U
) then
2261 Write_Line
(Msg
& "Bad spec with SCC of size 2:");
2262 Write_SCC
(SCC
(U
));
2266 if Units
.Table
(U
).Utype
= Is_Body
then
2267 if Order
(J
- 1) /= Corresponding_Spec
(U
) then
2269 Write_Line
(Msg
& "Bad body with SCC of size 2:");
2270 Write_SCC
(SCC
(U
));
2277 -- Assert that all units of an SCC are elaborated together, with no
2278 -- units from other SCCs in between. The above spec/body case is a
2279 -- special case of this general rule.
2281 for J
in Order
'Range loop
2283 U
: constant Unit_Id
:= Order
(J
);
2286 if SCC
(U
) /= Cur_SCC
then
2288 if UNR
.Table
(Cur_SCC
).Validate_Seen
then
2290 Write_Line
(Msg
& "SCC not elaborated together:");
2291 Write_SCC
(Cur_SCC
);
2294 UNR
.Table
(Cur_SCC
).Validate_Seen
:= True;
2307 procedure Write_Closure
(Order
: Unit_Id_Array
) is
2308 package Closure_Sources
is new Table
.Table
2309 (Table_Component_Type
=> File_Name_Type
,
2310 Table_Index_Type
=> Natural,
2311 Table_Low_Bound
=> 1,
2312 Table_Initial
=> 10,
2313 Table_Increment
=> 100,
2314 Table_Name
=> "Gnatbind.Closure_Sources");
2315 -- Table to record the sources in the closure, to avoid duplications
2317 function Put_In_Sources
(S
: File_Name_Type
) return Boolean;
2318 -- Check if S is already in table Sources and put in Sources if it is
2319 -- not. Return False if the source is already in Sources, and True if
2322 --------------------
2323 -- Put_In_Sources --
2324 --------------------
2326 function Put_In_Sources
(S
: File_Name_Type
) return Boolean is
2328 for J
in 1 .. Closure_Sources
.Last
loop
2329 if Closure_Sources
.Table
(J
) = S
then
2334 Closure_Sources
.Append
(S
);
2340 Source
: File_Name_Type
;
2342 -- Start of processing for Write_Closure
2345 Closure_Sources
.Init
;
2347 if not Zero_Formatting
then
2349 Write_Str
("REFERENCED SOURCES");
2353 for J
in reverse Order
'Range loop
2354 Source
:= Units
.Table
(Order
(J
)).Sfile
;
2356 -- Do not include same source more than once
2358 if Put_In_Sources
(Source
)
2360 -- Do not include run-time units unless -Ra switch set
2362 and then (List_Closure_All
2363 or else not Is_Internal_File_Name
(Source
))
2365 if not Zero_Formatting
then
2369 Write_Str
(Get_Name_String
(Source
));
2374 -- Subunits do not appear in the elaboration table because they are
2375 -- subsumed by their parent units, but we need to list them for other
2376 -- tools. For now they are listed after other files, rather than right
2377 -- after their parent, since there is no easy link between the
2378 -- elaboration table and the ALIs table ??? As subunits may appear
2379 -- repeatedly in the list, if the parent unit appears in the context of
2380 -- several units in the closure, duplicates are suppressed.
2382 for J
in Sdep
.First
.. Sdep
.Last
loop
2383 Source
:= Sdep
.Table
(J
).Sfile
;
2385 if Sdep
.Table
(J
).Subunit_Name
/= No_Name
2386 and then Put_In_Sources
(Source
)
2387 and then not Is_Internal_File_Name
(Source
)
2389 if not Zero_Formatting
then
2393 Write_Str
(Get_Name_String
(Source
));
2398 if not Zero_Formatting
then
2403 ------------------------
2404 -- Write_Dependencies --
2405 ------------------------
2407 procedure Write_Dependencies
is
2409 if not Zero_Formatting
then
2411 Write_Str
(" ELABORATION ORDER DEPENDENCIES");
2416 Info_Prefix_Suppress
:= True;
2418 for S
in Succ_First
.. Succ
.Last
loop
2422 Info_Prefix_Suppress
:= False;
2424 if not Zero_Formatting
then
2427 end Write_Dependencies
;
2429 --------------------------
2430 -- Write_Elab_All_Chain --
2431 --------------------------
2433 procedure Write_Elab_All_Chain
(S
: Successor_Id
) is
2434 ST
: constant Successor_Link
:= Succ
.Table
(S
);
2435 After
: constant Unit_Name_Type
:= Units
.Table
(ST
.After
).Uname
;
2438 Nam
: Unit_Name_Type
;
2440 First_Name
: Boolean := True;
2443 if ST
.Reason
in Elab_All
.. Elab_All_Desirable
then
2444 L
:= ST
.Elab_All_Link
;
2445 while L
/= No_Elab_All_Link
loop
2446 Nam
:= Elab_All_Entries
.Table
(L
).Needed_By
;
2447 Error_Msg_Unit_1
:= Nam
;
2448 Error_Msg_Output
(" $", Info
=> True);
2450 Get_Name_String
(Nam
);
2452 if Name_Buffer
(Name_Len
) = 'b' then
2455 (" must be elaborated along with its spec:",
2460 (" which must be elaborated along with its "
2473 (" which is withed by:",
2478 First_Name
:= False;
2480 L
:= Elab_All_Entries
.Table
(L
).Next_Elab
;
2483 Error_Msg_Unit_1
:= After
;
2484 Error_Msg_Output
(" $", Info
=> True);
2486 end Write_Elab_All_Chain
;
2488 ----------------------
2489 -- Write_Elab_Order --
2490 ----------------------
2492 procedure Write_Elab_Order
2493 (Order
: Unit_Id_Array
; Title
: String)
2502 for J
in Order
'Range loop
2503 if not Units
.Table
(Order
(J
)).SAL_Interface
then
2504 if not Zero_Formatting
then
2508 Write_Unit_Name
(Units
.Table
(Order
(J
)).Uname
);
2516 end Write_Elab_Order
;
2522 package body Elab_New
is
2528 type Node_Array
is array (Pos
range <>) of Node
;
2529 with function Successors
(N
: Node
) return Node_Array
;
2530 with procedure Create_SCC
(Root
: Node
; Nodes
: Node_Array
);
2532 procedure Compute_Strongly_Connected_Components
;
2533 -- Compute SCCs for a directed graph. The nodes in the graph are all
2534 -- values of type Node in the range First_Node .. Last_Node.
2535 -- Successors(N) returns the nodes pointed to by the edges emanating
2536 -- from N. Create_SCC is a callback that is called once for each SCC,
2537 -- passing in the Root node for that SCC (which is an arbitrary node in
2538 -- the SCC used as a representative of that SCC), and the set of Nodes
2541 -- This is generic, in case we want to use it elsewhere; then we could
2542 -- move this into a separate library unit. Unfortunately, it's not as
2543 -- generic as one might like. Ideally, we would have "type Node is
2544 -- private;", and pass in iterators to iterate over all nodes, and over
2545 -- the successors of a given node. However, that leads to using advanced
2546 -- features of Ada that are not allowed in the compiler and binder for
2547 -- bootstrapping reasons. It also leads to trampolines, which are not
2548 -- allowed in the compiler and binder. Restricting Node to be discrete
2549 -- allows us to iterate over all nodes with a 'for' loop, and allows us
2550 -- to attach temporary information to nodes by having an array indexed
2553 procedure Compute_Unit_SCCs
;
2554 -- Use the above generic procedure to compute the SCCs for the graph of
2555 -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
2556 -- components. Also initialize the SCC_Num_Pred components.
2558 procedure Find_Elab_All_Errors
;
2559 -- Generate an error for illegal Elaborate_All pragmas (explicit or
2560 -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
2561 -- if X and Y are in different SCCs.
2563 -------------------------------------------
2564 -- Compute_Strongly_Connected_Components --
2565 -------------------------------------------
2567 procedure Compute_Strongly_Connected_Components
is
2569 -- This uses Tarjan's algorithm for finding SCCs. Comments here are
2570 -- intended to tell what it does, but if you want to know how it
2571 -- works, you have to look it up. Please do not modify this code
2572 -- without reading up on Tarjan's algorithm.
2574 subtype Node_Index
is Nat
;
2575 No_Index
: constant Node_Index
:= 0;
2577 Num_Nodes
: constant Nat
:=
2578 Node
'Pos (Last_Node
) - Node
'Pos (First_Node
) + 1;
2579 Stack
: Node_Array
(1 .. Num_Nodes
);
2580 Top
: Node_Index
:= 0;
2581 -- Stack of nodes, pushed when first visited. All nodes of an SCC are
2582 -- popped at once when the SCC is found.
2584 subtype Valid_Node
is Node
range First_Node
.. Last_Node
;
2585 Node_Indices
: array (Valid_Node
) of Node_Index
:=
2586 (others => No_Index
);
2587 -- Each node has an "index", which is the sequential number in the
2588 -- order in which they are visited in the recursive walk. No_Index
2589 -- means "not yet visited"; we want to avoid walking any node more
2592 Index
: Node_Index
:= 1;
2593 -- Next value to be assigned to a node index
2595 Low_Links
: array (Valid_Node
) of Node_Index
;
2596 -- Low_Links (N) is the smallest index of nodes reachable from N
2598 On_Stack
: array (Valid_Node
) of Boolean := (others => False);
2599 -- True if the node is currently on the stack
2601 procedure Walk
(N
: Valid_Node
);
2602 -- Recursive depth-first graph walk, with the node index used to
2603 -- avoid visiting a node more than once.
2609 procedure Walk
(N
: Valid_Node
) is
2610 Stack_Position_Of_N
: constant Pos
:= Top
+ 1;
2611 S
: constant Node_Array
:= Successors
(N
);
2614 -- Assign the index and low link, increment Index for next call to
2617 Node_Indices
(N
) := Index
;
2618 Low_Links
(N
) := Index
;
2621 -- Push it on the stack:
2623 Top
:= Stack_Position_Of_N
;
2625 On_Stack
(N
) := True;
2627 -- Walk not-yet-visited subnodes, and update low link for visited
2628 -- ones as appropriate.
2630 for J
in S
'Range loop
2631 if Node_Indices
(S
(J
)) = No_Index
then
2634 Node_Index
'Min (Low_Links
(N
), Low_Links
(S
(J
)));
2635 elsif On_Stack
(S
(J
)) then
2637 Node_Index
'Min (Low_Links
(N
), Node_Indices
(S
(J
)));
2641 -- If the index is (still) equal to the low link, we've found an
2642 -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
2644 if Low_Links
(N
) = Node_Indices
(N
) then
2646 SCC
: Node_Array
renames
2647 Stack
(Stack_Position_Of_N
.. Top
);
2648 pragma Assert
(SCC
'Length >= 1);
2649 pragma Assert
(SCC
(SCC
'First) = N
);
2652 for J
in SCC
'Range loop
2653 On_Stack
(SCC
(J
)) := False;
2656 Create_SCC
(Root
=> N
, Nodes
=> SCC
);
2657 pragma Assert
(Top
- SCC
'Length = Stack_Position_Of_N
- 1);
2658 Top
:= Stack_Position_Of_N
- 1; -- pop all
2663 -- Start of processing for Compute_Strongly_Connected_Components
2666 -- Walk all the nodes that have not yet been walked
2668 for N
in Valid_Node
loop
2669 if Node_Indices
(N
) = No_Index
then
2673 end Compute_Strongly_Connected_Components
;
2675 -----------------------
2676 -- Compute_Unit_SCCs --
2677 -----------------------
2679 procedure Compute_Unit_SCCs
is
2680 function Successors
(U
: Unit_Id
) return Unit_Id_Array
;
2681 -- Return all the units that must be elaborated after U. In addition,
2682 -- if U is a body, include the corresponding spec; this ensures that
2683 -- a spec/body pair are always in the same SCC.
2685 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
);
2686 -- Set Nodes of the Root, and set SCC_Root of all the Nodes
2688 procedure Init_SCC_Num_Pred
(U
: Unit_Id
);
2689 -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
2690 -- has a count of the number of successors of all the units in the
2691 -- SCC, but only for successors outside the SCC.
2693 procedure Compute_SCCs
is new Compute_Strongly_Connected_Components
2695 First_Node
=> Units
.First
,
2696 Last_Node
=> Units
.Last
,
2697 Node_Array
=> Unit_Id_Array
,
2698 Successors
=> Successors
,
2699 Create_SCC
=> Create_SCC
);
2705 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
) is
2707 if Debug_Flag_V
then
2708 Write_Str
("Root = ");
2709 Write_Int
(Int
(Root
));
2711 Write_Unit_Name
(Units
.Table
(Root
).Uname
);
2713 Write_Int
(Nodes
'Length);
2714 Write_Str
(" units:");
2717 for J
in Nodes
'Range loop
2719 Write_Int
(Int
(Nodes
(J
)));
2721 Write_Unit_Name
(Units
.Table
(Nodes
(J
)).Uname
);
2726 pragma Assert
(Nodes
(Nodes
'First) = Root
);
2727 pragma Assert
(UNR
.Table
(Root
).Nodes
= null);
2728 UNR
.Table
(Root
).Nodes
:= new Unit_Id_Array
'(Nodes);
2730 for J in Nodes'Range loop
2731 pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
2732 UNR.Table (Nodes (J)).SCC_Root := Root;
2740 function Successors (U : Unit_Id) return Unit_Id_Array is
2741 S : Successor_Id := UNR.Table (U).Successors;
2742 Tab : Unit_Id_Table;
2745 -- Pretend that a spec is a successor of its body (even though it
2746 -- isn't), just so both get included.
2748 if Units.Table (U).Utype = Is_Body then
2749 Append (Tab, Corresponding_Spec (U));
2752 -- Now include the real successors
2754 while S /= No_Successor loop
2755 pragma Assert (Succ.Table (S).Before = U);
2756 Append (Tab, Succ.Table (S).After);
2757 S := Succ.Table (S).Next;
2761 Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
2769 -----------------------
2770 -- Init_SCC_Num_Pred --
2771 -----------------------
2773 procedure Init_SCC_Num_Pred (U : Unit_Id) is
2775 if UNR.Table (U).Visited then
2779 UNR.Table (U).Visited := True;
2782 S : Successor_Id := UNR.Table (U).Successors;
2785 while S /= No_Successor loop
2786 pragma Assert (Succ.Table (S).Before = U);
2787 Init_SCC_Num_Pred (Succ.Table (S).After);
2789 if SCC (U) /= SCC (Succ.Table (S).After) then
2790 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
2791 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
2794 S := Succ.Table (S).Next;
2797 end Init_SCC_Num_Pred;
2799 -- Start of processing for Compute_Unit_SCCs
2804 for Uref in UNR.First .. UNR.Last loop
2805 pragma Assert (not UNR.Table (Uref).Visited);
2809 for Uref in UNR.First .. UNR.Last loop
2810 Init_SCC_Num_Pred (Uref);
2813 -- Assert that SCC_Root of all units has been set to a valid unit,
2814 -- and that SCC_Num_Pred has not been modified in non-root units.
2816 for Uref in UNR.First .. UNR.Last loop
2817 pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
2818 pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
2820 if SCC (Uref) /= Uref then
2821 pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
2825 end Compute_Unit_SCCs;
2827 --------------------------
2828 -- Find_Elab_All_Errors --
2829 --------------------------
2831 procedure Find_Elab_All_Errors is
2832 Withed_Unit : Unit_Id;
2835 for U in Units.First .. Units.Last loop
2837 -- If this unit is not an interface to a stand-alone library,
2838 -- process WITH references for this unit ignoring interfaces to
2839 -- stand-alone libraries.
2841 if not Units.Table (U).SAL_Interface then
2842 for W in Units.Table (U).First_With ..
2843 Units.Table (U).Last_With
2845 if Withs.Table (W).Sfile /= No_File
2846 and then (not Withs.Table (W).SAL_Interface)
2848 -- Check for special case of withing a unit that does not
2851 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
2855 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
2857 -- If it's Elaborate_All or Elab_All_Desirable, check
2858 -- that the withER and withEE are not in the same SCC.
2860 if Withs.Table (W).Elaborate_All
2861 or else Withs.Table (W).Elab_All_Desirable
2863 if SCC (U) = SCC (Withed_Unit) then
2864 Illegal_Elab_All := True; -- ????
2866 -- We could probably give better error messages
2867 -- than Elab_Old here, but for now, to avoid
2868 -- disruption, we don't give any error here.
2869 -- Instead, we set the Illegal_Elab_All flag above,
2870 -- and then run the Elab_Old algorithm to issue the
2871 -- error message. Ideally, we would like to print
2872 -- multiple errors rather than stopping after the
2877 ("illegal pragma Elaborate_All",
2889 end Find_Elab_All_Errors;
2891 ---------------------
2892 -- Find_Elab_Order --
2893 ---------------------
2895 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
2896 Best_So_Far : Unit_Id;
2900 -- Gather dependencies and output them if option set
2902 Gather_Dependencies;
2906 -- Initialize the no-predecessor list
2908 No_Pred := No_Unit_Id;
2909 for U in UNR.First .. UNR.Last loop
2910 if UNR.Table (U).Num_Pred = 0 then
2911 UNR.Table (U).Nextnp := No_Pred;
2916 -- OK, now we determine the elaboration order proper. All we do is to
2917 -- select the best choice from the no-predecessor list until all the
2918 -- nodes have been chosen.
2922 -- If there are no nodes with predecessors, then either we are
2923 -- done, as indicated by Num_Left being set to zero, or we have
2924 -- a circularity. In the latter case, diagnose the circularity,
2925 -- removing it from the graph and continue.
2926 -- ????But Diagnose_Elaboration_Problem always raises an
2929 Get_No_Pred : while No_Pred = No_Unit_Id loop
2930 exit Outer when Num_Left < 1;
2931 Diagnose_Elaboration_Problem (Elab_Order);
2932 end loop Get_No_Pred;
2935 Best_So_Far := No_Unit_Id;
2937 -- Loop to choose best entry in No_Pred list
2939 No_Pred_Search : loop
2940 if Debug_Flag_N then
2941 Write_Str (" considering choice of ");
2942 Write_Unit_Name (Units.Table (U).Uname);
2945 if Units.Table (U).Elaborate_Body then
2947 (" Elaborate_Body = True, Num_Pred for body = ");
2949 (UNR.Table (Corresponding_Body (U)).Num_Pred);
2952 (" Elaborate_Body = False");
2958 -- Don't even consider units whose SCC is not ready. This
2959 -- ensures that all units of an SCC will be elaborated
2960 -- together, with no other units in between.
2962 if SCC_Num_Pred (U) = 0
2963 and then Better_Choice (U, Best_So_Far)
2965 if Debug_Flag_N then
2966 Write_Str (" tentatively chosen (best so far)");
2973 U := UNR.Table (U).Nextnp;
2974 exit No_Pred_Search when U = No_Unit_Id;
2975 end loop No_Pred_Search;
2977 -- Choose the best candidate found
2979 Choose (Elab_Order, Best_So_Far);
2981 -- If it's a spec with a body, and the body is not yet chosen,
2982 -- choose the body if possible. The case where the body is
2983 -- already chosen is Elaborate_Body; the above call to Choose
2984 -- the spec will also Choose the body.
2986 if Units.Table (Best_So_Far).Utype = Is_Spec
2988 (Corresponding_Body (Best_So_Far)).Elab_Position = 0
2991 Choose_The_Body : constant Boolean :=
2992 UNR.Table (Corresponding_Body
2993 (Best_So_Far)).Num_Pred = 0;
2996 if Debug_Flag_B then
2997 Write_Str ("Can we choose the body?... ");
2999 if Choose_The_Body then
3000 Write_Line ("Yes!");
3006 if Choose_The_Body then
3007 Choose (Elab_Order, Corresponding_Body (Best_So_Far));
3012 -- Finally, choose all the rest of the units in the same SCC as
3013 -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
3014 -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
3018 Chose_One_Or_More : Boolean := False;
3019 SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
3022 for J in SCC'Range loop
3023 if UNR.Table (SCC (J)).Elab_Position = 0
3024 and then UNR.Table (SCC (J)).Num_Pred = 0
3026 Chose_One_Or_More := True;
3027 Choose (Elab_Order, SCC (J));
3031 exit when not Chose_One_Or_More;
3036 Find_Elab_All_Errors;
3037 end Find_Elab_Order;
3043 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
3045 return UNR.Table (SCC (U)).Nodes;
3052 function SCC (U : Unit_Id) return Unit_Id is
3054 return UNR.Table (U).SCC_Root;
3061 function SCC_Num_Pred (U : Unit_Id) return Int is
3063 return UNR.Table (SCC (U)).SCC_Num_Pred;
3070 procedure Write_SCC (U : Unit_Id) is
3071 pragma Assert (SCC (U) = U);
3073 for J in Nodes (U)'Range loop
3074 Write_Int (Int (UNR.Table (Nodes (U) (J)).Elab_Position));
3076 Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
3089 package body Elab_Old is
3091 ---------------------
3092 -- Find_Elab_Order --
3093 ---------------------
3095 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
3096 Best_So_Far : Unit_Id;
3100 -- Gather dependencies and output them if option set
3102 Gather_Dependencies;
3104 -- Initialize the no-predecessor list
3106 No_Pred := No_Unit_Id;
3107 for U in UNR.First .. UNR.Last loop
3108 if UNR.Table (U).Num_Pred = 0 then
3109 UNR.Table (U).Nextnp := No_Pred;
3114 -- OK, now we determine the elaboration order proper. All we do is to
3115 -- select the best choice from the no-predecessor list until all the
3116 -- nodes have been chosen.
3120 -- If there are no nodes with predecessors, then either we are
3121 -- done, as indicated by Num_Left being set to zero, or we have
3122 -- a circularity. In the latter case, diagnose the circularity,
3123 -- removing it from the graph and continue.
3124 -- ????But Diagnose_Elaboration_Problem always raises an
3127 Get_No_Pred : while No_Pred = No_Unit_Id loop
3128 exit Outer when Num_Left < 1;
3129 Diagnose_Elaboration_Problem (Elab_Order);
3130 end loop Get_No_Pred;
3133 Best_So_Far := No_Unit_Id;
3135 -- Loop to choose best entry in No_Pred list
3137 No_Pred_Search : loop
3138 if Debug_Flag_N then
3139 Write_Str (" considering choice of ");
3140 Write_Unit_Name (Units.Table (U).Uname);
3143 if Units.Table (U).Elaborate_Body then
3145 (" Elaborate_Body = True, Num_Pred for body = ");
3147 (UNR.Table (Corresponding_Body (U)).Num_Pred);
3150 (" Elaborate_Body = False");
3156 -- This is a candididate to be considered for choice
3158 if Better_Choice (U, Best_So_Far) then
3159 if Debug_Flag_N then
3160 Write_Str (" tentatively chosen (best so far)");
3167 U := UNR.Table (U).Nextnp;
3168 exit No_Pred_Search when U = No_Unit_Id;
3169 end loop No_Pred_Search;
3171 -- Choose the best candidate found
3173 Choose (Elab_Order, Best_So_Far);
3175 end Find_Elab_Order;