1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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.
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.
283 -- Number of units chosen in the elaboration order so far
285 Diagnose_Elaboration_Problem_Called
: Boolean := False;
286 -- True if Diagnose_Elaboration_Problem was called. Used in an assertion.
288 -----------------------
289 -- Local Subprograms --
290 -----------------------
292 function Debug_Flag_Older
return Boolean;
293 function Debug_Flag_Old
return Boolean;
294 -- True if debug flags select the old or older algorithms. Pretty much any
295 -- change to elaboration order can break some programs. For example,
296 -- programs can depend on elaboration order even without failing
297 -- access-before-elaboration checks. A trivial example is a program that
298 -- prints text during elaboration. Therefore, we have flags to revert to
299 -- the old(er) algorithms.
301 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean);
302 -- Assert that certain properties are true
304 function Better_Choice_Optimistic
306 U2
: Unit_Id
) return Boolean;
307 -- U1 and U2 are both permitted candidates for selection as the next unit
308 -- to be elaborated. This function determines whether U1 is a better choice
309 -- than U2, i.e. should be elaborated in preference to U2, based on a set
310 -- of heuristics that establish a friendly and predictable order (see body
311 -- for details). The result is True if U1 is a better choice than U2, and
312 -- False if it is a worse choice, or there is no preference between them.
314 function Better_Choice_Pessimistic
316 U2
: Unit_Id
) return Boolean;
317 -- This is like Better_Choice_Optimistic, and has the same interface, but
318 -- returns true if U1 is a worse choice than U2 in the sense of the -p
319 -- (pessimistic elaboration order) switch. We still have to obey Ada rules,
320 -- so it is not quite the direct inverse of Better_Choice_Optimistic.
322 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean;
323 -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
324 -- appropriate. Also takes care of the U2 = No_Unit_Id case.
330 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
);
331 -- Establish a successor link, Before must be elaborated before After, and
332 -- the reason for the link is R. Ea_Id is the contents to be placed in the
333 -- Elab_All_Link of the entry.
336 (Elab_Order
: in out Unit_Id_Table
;
339 -- Chosen is the next entry chosen in the elaboration order. This procedure
340 -- updates all data structures appropriately.
342 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
;
343 pragma Inline
(Corresponding_Body
);
344 -- Given a unit that is a spec for which there is a separate body, return
345 -- the unit id of the body. It is an error to call this routine with a unit
346 -- that is not a spec, or that does not have a separate body.
348 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
;
349 pragma Inline
(Corresponding_Spec
);
350 -- Given a unit that is a body for which there is a separate spec, return
351 -- the unit id of the spec. It is an error to call this routine with a unit
352 -- that is not a body, or that does not have a separate spec.
354 procedure Diagnose_Elaboration_Problem
355 (Elab_Order
: in out Unit_Id_Table
);
356 -- Called when no elaboration order can be found. Outputs an appropriate
357 -- diagnosis of the problem, and then abandons the bind.
359 procedure Elab_All_Links
362 Reason
: Succ_Reason
;
364 -- Used to compute the transitive closure of elaboration links for an
365 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
366 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a
367 -- pragma Elaborate_All or the front end has determined that a reference
368 -- probably requires Elaborate_All, and unit Before must be previously
369 -- elaborated. First a link is built making sure that unit Before is
370 -- elaborated before After, then a recursive call ensures that we also
371 -- build links for any units needed by Before (i.e. these units must/should
372 -- also be elaborated before After). Link is used to build a chain of
373 -- Elab_All_Entries to explain the reason for a link. The value passed is
376 procedure Elab_Error_Msg
(S
: Successor_Id
);
377 -- Given a successor link, outputs an error message of the form
378 -- "$ must be elaborated before $ ..." where ... is the reason.
380 procedure Force_Elab_Order
;
381 -- Gather dependencies from the forced elaboration order file (-f switch)
383 procedure Gather_Dependencies
;
384 -- Compute dependencies, building the Succ and UNR tables
387 -- Initialize global data structures in this package body
389 function Is_Body_Unit
(U
: Unit_Id
) return Boolean;
390 pragma Inline
(Is_Body_Unit
);
391 -- Determines if given unit is a body
393 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean;
394 -- Returns True if corresponding unit is Pure or Preelaborate. Includes
395 -- dealing with testing flags on spec if it is given a body.
397 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean;
398 pragma Inline
(Is_Waiting_Body
);
399 -- Determines if U is a waiting body, defined as a body that has
400 -- not been elaborated, but whose spec has been elaborated.
402 function Make_Elab_All_Entry
403 (Unam
: Unit_Name_Type
;
404 Link
: Elab_All_Id
) return Elab_All_Id
;
405 -- Make an Elab_All_Entries table entry with the given Unam and Link
407 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
;
408 -- This function uses the Info field set in the names table to obtain
409 -- the unit Id of a unit, given its name id value.
411 procedure Write_Closure
(Order
: Unit_Id_Array
);
412 -- Write the closure. This is for the -R and -Ra switches, "list closure
415 procedure Write_Dependencies
;
416 -- Write out dependencies (called only if appropriate option is set)
418 procedure Write_Elab_All_Chain
(S
: Successor_Id
);
419 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
420 -- then this routine will output the "needed by" explanation chain.
422 procedure Write_Elab_Order
(Order
: Unit_Id_Array
; Title
: String);
423 -- Display elaboration order. This is for the -l switch. Title is a heading
424 -- to print; an empty string is passed to indicate Zero_Formatting.
428 -- Implementation of the new algorithm
430 procedure Write_SCC
(U
: Unit_Id
);
431 -- Write the unit names of the units in the SCC in which U lives
433 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
435 Elab_Cycle_Found
: Boolean := False;
436 -- Set True if Find_Elab_Order found a cycle (usually an illegal pragma
437 -- Elaborate_All, explicit or implicit).
439 function SCC
(U
: Unit_Id
) return Unit_Id
;
440 -- The root of the strongly connected component containing U
442 function SCC_Num_Pred
(U
: Unit_Id
) return Int
;
443 -- The SCC_Num_Pred of the SCC in which U lives
445 function Nodes
(U
: Unit_Id
) return Unit_Id_Array_Ptr
;
446 -- The nodes of the strongly connected component containing U
454 -- Implementation of the old algorithm
456 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
460 -- Most of the code is shared between old and new; such code is outside
461 -- packages Elab_Old and Elab_New.
467 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean is
468 pragma Assert
(U1
/= No_Unit_Id
);
470 if U2
= No_Unit_Id
then
474 if Pessimistic_Elab_Order
then
475 return Better_Choice_Pessimistic
(U1
, U2
);
477 return Better_Choice_Optimistic
(U1
, U2
);
481 ------------------------------
482 -- Better_Choice_Optimistic --
483 ------------------------------
485 function Better_Choice_Optimistic
487 U2
: Unit_Id
) return Boolean
489 UT1
: Unit_Record
renames Units
.Table
(U1
);
490 UT2
: Unit_Record
renames Units
.Table
(U2
);
494 Write_Str
("Better_Choice_Optimistic (");
495 Write_Unit_Name
(UT1
.Uname
);
497 Write_Unit_Name
(UT2
.Uname
);
501 -- Note: the checks here are applied in sequence, and the ordering is
502 -- significant (i.e. the more important criteria are applied first).
504 -- Prefer a waiting body to one that is not a waiting body
506 if Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
508 Write_Line
(" True: u1 is waiting body, u2 is not");
513 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
515 Write_Line
(" False: u2 is waiting body, u1 is not");
520 -- Prefer a predefined unit to a non-predefined unit
522 elsif UT1
.Predefined
and then not UT2
.Predefined
then
524 Write_Line
(" True: u1 is predefined, u2 is not");
529 elsif UT2
.Predefined
and then not UT1
.Predefined
then
531 Write_Line
(" False: u2 is predefined, u1 is not");
536 -- Prefer an internal unit to a non-internal unit
538 elsif UT1
.Internal
and then not UT2
.Internal
then
540 Write_Line
(" True: u1 is internal, u2 is not");
544 elsif UT2
.Internal
and then not UT1
.Internal
then
546 Write_Line
(" False: u2 is internal, u1 is not");
551 -- Prefer a pure or preelaborated unit to one that is not. Pure should
552 -- come before preelaborated.
554 elsif Is_Pure_Or_Preelab_Unit
(U1
)
556 Is_Pure_Or_Preelab_Unit
(U2
)
559 Write_Line
(" True: u1 is pure/preelab, u2 is not");
564 elsif Is_Pure_Or_Preelab_Unit
(U2
)
566 Is_Pure_Or_Preelab_Unit
(U1
)
569 Write_Line
(" False: u2 is pure/preelab, u1 is not");
574 -- Prefer a body to a spec
576 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
578 Write_Line
(" True: u1 is body, u2 is not");
583 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
585 Write_Line
(" False: u2 is body, u1 is not");
590 -- If both are waiting bodies, then prefer the one whose spec is more
591 -- recently elaborated. Consider the following:
597 -- The normal waiting body preference would have placed the body of A
598 -- before the spec of B if it could. Since it could not, then it must be
599 -- the case that A depends on B. It is therefore a good idea to put the
602 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
604 Result
: constant Boolean :=
605 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
>
606 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
610 Write_Line
(" True: based on waiting body elab positions");
612 Write_Line
(" False: based on waiting body elab positions");
620 -- Remaining choice rules are disabled by Debug flag -do
622 if not Debug_Flag_Older
then
624 -- The following deal with the case of specs that have been marked
625 -- as Elaborate_Body_Desirable. We generally want to delay these
626 -- specs as long as possible, so that the bodies have a better chance
627 -- of being elaborated closer to the specs.
629 -- If we have two units, one of which is a spec for which this flag
630 -- is set, and the other is not, we prefer to delay the spec for
631 -- which the flag is set.
633 if not UT1
.Elaborate_Body_Desirable
634 and then UT2
.Elaborate_Body_Desirable
637 Write_Line
(" True: u1 is elab body desirable, u2 is not");
642 elsif not UT2
.Elaborate_Body_Desirable
643 and then UT1
.Elaborate_Body_Desirable
646 Write_Line
(" False: u1 is elab body desirable, u2 is not");
651 -- If we have two specs that are both marked as Elaborate_Body
652 -- desirable, we prefer the one whose body is nearer to being able
653 -- to be elaborated, based on the Num_Pred count. This helps to
654 -- ensure bodies are as close to specs as possible.
656 elsif UT1
.Elaborate_Body_Desirable
657 and then UT2
.Elaborate_Body_Desirable
660 Result
: constant Boolean :=
661 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
662 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
666 Write_Line
(" True based on Num_Pred compare");
668 Write_Line
(" False based on Num_Pred compare");
677 -- If we have two specs in the same SCC, choose the one whose body is
678 -- closer to being ready.
681 and then SCC
(U1
) = SCC
(U2
)
682 and then Units
.Table
(U1
).Utype
= Is_Spec
683 and then Units
.Table
(U2
).Utype
= Is_Spec
684 and then UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
/=
685 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
687 if UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
688 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
691 Write_Str
(" True: same SCC; ");
692 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
694 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
701 Write_Str
(" False: same SCC; ");
702 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
704 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
712 -- If we fall through, it means that no preference rule applies, so we
713 -- use alphabetical order to at least give a deterministic result.
716 Write_Line
(" choose on alpha order");
719 return Uname_Less
(UT1
.Uname
, UT2
.Uname
);
720 end Better_Choice_Optimistic
;
722 -------------------------------
723 -- Better_Choice_Pessimistic --
724 -------------------------------
726 function Better_Choice_Pessimistic
728 U2
: Unit_Id
) return Boolean
730 UT1
: Unit_Record
renames Units
.Table
(U1
);
731 UT2
: Unit_Record
renames Units
.Table
(U2
);
735 Write_Str
("Better_Choice_Pessimistic (");
736 Write_Unit_Name
(UT1
.Uname
);
738 Write_Unit_Name
(UT2
.Uname
);
742 -- Note: the checks here are applied in sequence, and the ordering is
743 -- significant (i.e. the more important criteria are applied first).
745 -- If either unit is predefined or internal, then we use the normal
746 -- Better_Choice_Optimistic rule, since we don't want to disturb the
747 -- elaboration rules of the language with -p; same treatment for
750 -- Prefer a predefined unit to a non-predefined unit
752 if UT1
.Predefined
and then not UT2
.Predefined
then
754 Write_Line
(" True: u1 is predefined, u2 is not");
759 elsif UT2
.Predefined
and then not UT1
.Predefined
then
761 Write_Line
(" False: u2 is predefined, u1 is not");
766 -- Prefer an internal unit to a non-internal unit
768 elsif UT1
.Internal
and then not UT2
.Internal
then
770 Write_Line
(" True: u1 is internal, u2 is not");
775 elsif UT2
.Internal
and then not UT1
.Internal
then
777 Write_Line
(" False: u2 is internal, u1 is not");
782 -- Prefer a pure or preelaborated unit to one that is not
784 elsif Is_Pure_Or_Preelab_Unit
(U1
)
786 Is_Pure_Or_Preelab_Unit
(U2
)
789 Write_Line
(" True: u1 is pure/preelab, u2 is not");
794 elsif Is_Pure_Or_Preelab_Unit
(U2
)
796 Is_Pure_Or_Preelab_Unit
(U1
)
799 Write_Line
(" False: u2 is pure/preelab, u1 is not");
804 -- Prefer anything else to a waiting body. We want to make bodies wait
805 -- as long as possible, till we are forced to choose them.
807 elsif Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
809 Write_Line
(" False: u1 is waiting body, u2 is not");
814 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
816 Write_Line
(" True: u2 is waiting body, u1 is not");
821 -- Prefer a spec to a body (this is mandatory)
823 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
825 Write_Line
(" False: u1 is body, u2 is not");
830 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
832 Write_Line
(" True: u2 is body, u1 is not");
837 -- If both are waiting bodies, then prefer the one whose spec is less
838 -- recently elaborated. Consider the following:
844 -- The normal waiting body preference would have placed the body of A
845 -- before the spec of B if it could. Since it could not, then it must be
846 -- the case that A depends on B. It is therefore a good idea to put the
847 -- body of B last so that if there is an elaboration order problem, we
848 -- will find it (that's what pessimistic order is about).
850 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
852 Result
: constant Boolean :=
853 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
<
854 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
858 Write_Line
(" True: based on waiting body elab positions");
860 Write_Line
(" False: based on waiting body elab positions");
868 -- Remaining choice rules are disabled by Debug flag -do
870 if not Debug_Flag_Older
then
872 -- The following deal with the case of specs that have been marked as
873 -- Elaborate_Body_Desirable. In the normal case, we generally want to
874 -- delay the elaboration of these specs as long as possible, so that
875 -- bodies have better chance of being elaborated closer to the specs.
876 -- Better_Choice_Pessimistic as usual wants to do the opposite and
877 -- elaborate such specs as early as possible.
879 -- If we have two units, one of which is a spec for which this flag
880 -- is set, and the other is not, we normally prefer to delay the spec
881 -- for which the flag is set, so again Better_Choice_Pessimistic does
884 if not UT1
.Elaborate_Body_Desirable
885 and then UT2
.Elaborate_Body_Desirable
888 Write_Line
(" False: u1 is elab body desirable, u2 is not");
893 elsif not UT2
.Elaborate_Body_Desirable
894 and then UT1
.Elaborate_Body_Desirable
897 Write_Line
(" True: u1 is elab body desirable, u2 is not");
902 -- If we have two specs that are both marked as Elaborate_Body
903 -- desirable, we normally prefer the one whose body is nearer to
904 -- being able to be elaborated, based on the Num_Pred count. This
905 -- helps to ensure bodies are as close to specs as possible. As
906 -- usual, Better_Choice_Pessimistic does the opposite.
908 elsif UT1
.Elaborate_Body_Desirable
909 and then UT2
.Elaborate_Body_Desirable
912 Result
: constant Boolean :=
913 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
>=
914 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
918 Write_Line
(" True based on Num_Pred compare");
920 Write_Line
(" False based on Num_Pred compare");
929 -- If we fall through, it means that no preference rule applies, so we
930 -- use alphabetical order to at least give a deterministic result. Since
931 -- Better_Choice_Pessimistic is in the business of stirring up the
932 -- order, we will use reverse alphabetical ordering.
935 Write_Line
(" choose on reverse alpha order");
938 return Uname_Less
(UT2
.Uname
, UT1
.Uname
);
939 end Better_Choice_Pessimistic
;
949 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
)
956 After
=> No_Unit_Id
, -- filled in below
957 Next
=> UNR
.Table
(Before
).Successors
,
959 Elab_Body
=> False, -- set correctly below
960 Reason_Unit
=> Cur_Unit
,
961 Elab_All_Link
=> Ea_Id
));
962 UNR
.Table
(Before
).Successors
:= Succ
.Last
;
964 -- Deal with special Elab_Body case. If the After of this link is
965 -- a body whose spec has Elaborate_All set, and this is not the link
966 -- directly from the body to the spec, then we make the After of the
967 -- link reference its spec instead, marking the link appropriately.
969 if Units
.Table
(After
).Utype
= Is_Body
then
970 Cspec
:= Corresponding_Spec
(After
);
972 if Units
.Table
(Cspec
).Elaborate_Body
973 and then Cspec
/= Before
975 Succ
.Table
(Succ
.Last
).After
:= Cspec
;
976 Succ
.Table
(Succ
.Last
).Elab_Body
:= True;
977 UNR
.Table
(Cspec
).Num_Pred
:= UNR
.Table
(Cspec
).Num_Pred
+ 1;
982 -- Fall through on normal case
984 Succ
.Table
(Succ
.Last
).After
:= After
;
985 Succ
.Table
(Succ
.Last
).Elab_Body
:= False;
986 UNR
.Table
(After
).Num_Pred
:= UNR
.Table
(After
).Num_Pred
+ 1;
994 (Elab_Order
: in out Unit_Id_Table
;
998 pragma Assert
(Chosen
/= No_Unit_Id
);
1003 if Debug_Flag_C
then
1004 Write_Str
("Choosing Unit ");
1005 Write_Unit_Name
(Units
.Table
(Chosen
).Uname
);
1009 -- We shouldn't be choosing something with unelaborated predecessors,
1010 -- and we shouldn't call this twice on the same unit. But that's not
1011 -- true when this is called from Diagnose_Elaboration_Problem.
1013 if Errors_Detected
= 0 then
1014 pragma Assert
(UNR
.Table
(Chosen
).Num_Pred
= 0);
1015 pragma Assert
(UNR
.Table
(Chosen
).Elab_Position
= 0);
1016 pragma Assert
(not Doing_New
or else SCC_Num_Pred
(Chosen
) = 0);
1020 -- Add to elaboration order. Note that units having no elaboration code
1021 -- are not treated specially yet. The special casing of this is in
1022 -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
1023 -- here, because the object file list is also driven by the contents of
1024 -- the Elab_Order table.
1026 Append
(Elab_Order
, Chosen
);
1028 -- Remove from No_Pred list. This is a little inefficient and may be we
1029 -- should doubly link the list, but it will do for now.
1031 if No_Pred
= Chosen
then
1032 No_Pred
:= UNR
.Table
(Chosen
).Nextnp
;
1035 while U
/= No_Unit_Id
loop
1036 if UNR
.Table
(U
).Nextnp
= Chosen
then
1037 UNR
.Table
(U
).Nextnp
:= UNR
.Table
(Chosen
).Nextnp
;
1041 U
:= UNR
.Table
(U
).Nextnp
;
1044 -- Here if we didn't find it on the No_Pred list. This can happen
1045 -- only in calls from the Diagnose_Elaboration_Problem routine,
1046 -- where cycles are being removed arbitrarily from the graph.
1048 pragma Assert
(Errors_Detected
> 0);
1049 <<Done_Removal
>> null;
1052 -- For all successors, decrement the number of predecessors, and if it
1053 -- becomes zero, then add to no-predecessor list.
1055 S
:= UNR
.Table
(Chosen
).Successors
;
1056 while S
/= No_Successor
loop
1057 U
:= Succ
.Table
(S
).After
;
1058 UNR
.Table
(U
).Num_Pred
:= UNR
.Table
(U
).Num_Pred
- 1;
1060 if Debug_Flag_N
then
1061 Write_Str
(" decrementing Num_Pred for unit ");
1062 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1063 Write_Str
(" new value = ");
1064 Write_Int
(UNR
.Table
(U
).Num_Pred
);
1068 if UNR
.Table
(U
).Num_Pred
= 0 then
1069 UNR
.Table
(U
).Nextnp
:= No_Pred
;
1073 if Doing_New
and then SCC
(U
) /= SCC
(Chosen
) then
1074 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
:=
1075 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
- 1;
1077 if Debug_Flag_N
then
1078 Write_Str
(" decrementing SCC_Num_Pred for unit ");
1079 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1080 Write_Str
(" new value = ");
1081 Write_Int
(SCC_Num_Pred
(U
));
1086 S
:= Succ
.Table
(S
).Next
;
1089 -- All done, adjust number of units left count and set elaboration pos
1091 Num_Left
:= Num_Left
- 1;
1092 Num_Chosen
:= Num_Chosen
+ 1;
1095 (Errors_Detected
> 0 or else Num_Chosen
= Last
(Elab_Order
));
1096 pragma Assert
(Units
.Last
= UNR
.Last
);
1097 pragma Assert
(Num_Chosen
+ Num_Left
= Int
(UNR
.Last
));
1099 if Debug_Flag_C
then
1101 Write_Int
(Int
(Num_Chosen
));
1103 Write_Int
(Num_Left
);
1105 Write_Int
(Int
(UNR
.Last
));
1109 UNR
.Table
(Chosen
).Elab_Position
:= Num_Chosen
;
1111 -- If we just chose a spec with Elaborate_Body set, then we must
1112 -- immediately elaborate the body, before any other units.
1114 if Units
.Table
(Chosen
).Elaborate_Body
then
1116 -- If the unit is a spec only, then there is no body. This is a bit
1117 -- odd given that Elaborate_Body is here, but it is valid in an RCI
1118 -- unit, where we only have the interface in the stub bind.
1120 if Units
.Table
(Chosen
).Utype
= Is_Spec_Only
1121 and then Units
.Table
(Chosen
).RCI
1126 (Elab_Order
=> Elab_Order
,
1127 Chosen
=> Corresponding_Body
(Chosen
),
1128 Msg
=> " [Elaborate_Body]");
1133 ------------------------
1134 -- Corresponding_Body --
1135 ------------------------
1137 -- Currently if the body and spec are separate, then they appear as two
1138 -- separate units in the same ALI file, with the body appearing first and
1139 -- the spec appearing second.
1141 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
is
1143 pragma Assert
(Units
.Table
(U
).Utype
= Is_Spec
);
1145 end Corresponding_Body
;
1147 ------------------------
1148 -- Corresponding_Spec --
1149 ------------------------
1151 -- Currently if the body and spec are separate, then they appear as two
1152 -- separate units in the same ALI file, with the body appearing first and
1153 -- the spec appearing second.
1155 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
is
1157 pragma Assert
(Units
.Table
(U
).Utype
= Is_Body
);
1159 end Corresponding_Spec
;
1161 --------------------
1162 -- Debug_Flag_Old --
1163 --------------------
1165 function Debug_Flag_Old
return Boolean is
1167 -- If the user specified both flags, we want to use the older algorithm,
1168 -- rather than some confusing mix of the two.
1170 return Debug_Flag_P
and not Debug_Flag_O
;
1173 ----------------------
1174 -- Debug_Flag_Older --
1175 ----------------------
1177 function Debug_Flag_Older
return Boolean is
1179 return Debug_Flag_O
;
1180 end Debug_Flag_Older
;
1182 ----------------------------------
1183 -- Diagnose_Elaboration_Problem --
1184 ----------------------------------
1186 procedure Diagnose_Elaboration_Problem
1187 (Elab_Order
: in out Unit_Id_Table
)
1192 ML
: Nat
) return Boolean;
1193 -- Recursive routine used to find a path from node Ufrom to node Uto.
1194 -- If a path exists, returns True and outputs an appropriate set of
1195 -- error messages giving the path. Also calls Choose for each of the
1196 -- nodes so that they get removed from the remaining set. There are
1197 -- two cases of calls, either Ufrom = Uto for an attempt to find a
1198 -- cycle, or Ufrom is a spec and Uto the corresponding body for the
1199 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
1200 -- acceptable length for a path.
1209 ML
: Nat
) return Boolean
1211 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean;
1212 -- This is the inner recursive routine, it determines if a path
1213 -- exists from U to Uto, and if so returns True and outputs the
1214 -- appropriate set of error messages. PL is the path length
1220 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean is
1224 -- Recursion ends if we are at terminating node and the path is
1225 -- sufficiently long, generate error message and return True.
1227 if U
= Uto
and then PL
>= ML
then
1228 Choose
(Elab_Order
, U
, " [Find_Link: base]");
1231 -- All done if already visited
1233 elsif UNR
.Table
(U
).Visited
then
1236 -- Otherwise mark as visited and look at all successors
1239 UNR
.Table
(U
).Visited
:= True;
1241 S
:= UNR
.Table
(U
).Successors
;
1242 while S
/= No_Successor
loop
1243 if Find_Link
(Succ
.Table
(S
).After
, PL
+ 1) then
1245 Choose
(Elab_Order
, U
, " [Find_Link: recursive]");
1249 S
:= Succ
.Table
(S
).Next
;
1252 -- Falling through means this does not lead to a path
1258 -- Start of processing for Find_Path
1261 -- Initialize all non-chosen nodes to not visited yet
1263 for U
in Units
.First
.. Units
.Last
loop
1264 UNR
.Table
(U
).Visited
:= UNR
.Table
(U
).Elab_Position
/= 0;
1267 -- Now try to find the path
1269 return Find_Link
(Ufrom
, 0);
1272 -- Start of processing for Diagnose_Elaboration_Problem
1275 Diagnose_Elaboration_Problem_Called
:= True;
1278 -- Output state of things if debug flag N set
1280 if Debug_Flag_N
then
1287 Write_Line
("Diagnose_Elaboration_Problem called");
1288 Write_Line
("List of remaining unchosen units and predecessors");
1290 for U
in Units
.First
.. Units
.Last
loop
1291 if UNR
.Table
(U
).Elab_Position
= 0 then
1292 NP
:= UNR
.Table
(U
).Num_Pred
;
1294 Write_Str
(" Unchosen unit: #");
1295 Write_Int
(Int
(U
));
1297 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1298 Write_Str
(" (Num_Pred = ");
1303 if Units
.Table
(U
).Elaborate_Body
then
1305 (" (not chosen because of Elaborate_Body)");
1307 Write_Line
(" ****************** why not chosen?");
1311 -- Search links list to find unchosen predecessors
1313 for S
in Succ
.First
.. Succ
.Last
loop
1315 SL
: Successor_Link
renames Succ
.Table
(S
);
1319 and then UNR
.Table
(SL
.Before
).Elab_Position
= 0
1321 Write_Str
(" unchosen predecessor: #");
1322 Write_Int
(Int
(SL
.Before
));
1324 Write_Unit_Name
(Units
.Table
(SL
.Before
).Uname
);
1332 Write_Line
(" **************** Num_Pred value wrong!");
1339 -- Output the header for the error, and manually increment the error
1340 -- count. We are using Error_Msg_Output rather than Error_Msg here for
1343 -- This is really only one error, not one for each line
1344 -- We want this output on standard output since it is voluminous
1346 -- But we do need to deal with the error count manually in this case
1348 Errors_Detected
:= Errors_Detected
+ 1;
1349 Error_Msg_Output
("elaboration circularity detected", Info
=> False);
1351 -- Try to find cycles starting with any of the remaining nodes that have
1352 -- not yet been chosen. There must be at least one (there is some reason
1353 -- we are being called).
1355 for U
in Units
.First
.. Units
.Last
loop
1356 if UNR
.Table
(U
).Elab_Position
= 0 then
1357 if Find_Path
(U
, U
, 1) then
1358 raise Unrecoverable_Error
;
1363 -- We should never get here, since we were called for some reason, and
1364 -- we should have found and eliminated at least one bad path.
1366 raise Program_Error
;
1367 end Diagnose_Elaboration_Problem
;
1369 --------------------
1370 -- Elab_All_Links --
1371 --------------------
1373 procedure Elab_All_Links
1376 Reason
: Succ_Reason
;
1380 if UNR
.Table
(Before
).Visited
then
1384 -- Build the direct link for Before
1386 UNR
.Table
(Before
).Visited
:= True;
1387 Build_Link
(Before
, After
, Reason
, Link
);
1389 -- Process all units with'ed by Before recursively
1391 for W
in Units
.Table
(Before
).First_With
..
1392 Units
.Table
(Before
).Last_With
1394 -- Skip if this with is an interface to a stand-alone library. Skip
1395 -- also if no ALI file for this WITH, happens for language defined
1396 -- generics while bootstrapping the compiler (see body of routine
1397 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
1398 -- clause, which does not impose an elaboration link.
1400 if not Withs
.Table
(W
).SAL_Interface
1401 and then Withs
.Table
(W
).Afile
/= No_File
1402 and then not Withs
.Table
(W
).Limited_With
1405 Info
: constant Int
:=
1406 Get_Name_Table_Int
(Withs
.Table
(W
).Uname
);
1409 -- If the unit is unknown, for some unknown reason, fail
1410 -- graciously explaining that the unit is unknown. Without
1411 -- this check, gnatbind will crash in Unit_Id_Of.
1413 if Info
= 0 or else Unit_Id
(Info
) = No_Unit_Id
then
1416 Get_Name_String
(Withs
.Table
(W
).Uname
);
1417 Last_Withed
: Natural := Withed
'Last;
1420 (Units
.Table
(Before
).Uname
);
1421 Last_Withing
: Natural := Withing
'Last;
1422 Spec_Body
: String := " (Spec)";
1429 and then Withed
(Last_Withed
- 1) = '%'
1431 Last_Withed
:= Last_Withed
- 2;
1435 and then Withing
(Last_Withing
- 1) = '%'
1437 Last_Withing
:= Last_Withing
- 2;
1440 if Units
.Table
(Before
).Utype
= Is_Body
1441 or else Units
.Table
(Before
).Utype
= Is_Body_Only
1443 Spec_Body
:= " (Body)";
1447 ("could not find unit "
1448 & Withed
(Withed
'First .. Last_Withed
) & " needed by "
1449 & Withing
(Withing
'First .. Last_Withing
) & Spec_Body
);
1454 (Unit_Id_Of
(Withs
.Table
(W
).Uname
),
1457 Make_Elab_All_Entry
(Withs
.Table
(W
).Uname
, Link
));
1462 -- Process corresponding body, if there is one
1464 if Units
.Table
(Before
).Utype
= Is_Spec
then
1466 (Corresponding_Body
(Before
),
1469 (Units
.Table
(Corresponding_Body
(Before
)).Uname
, Link
));
1473 --------------------
1474 -- Elab_Error_Msg --
1475 --------------------
1477 procedure Elab_Error_Msg
(S
: Successor_Id
) is
1478 SL
: Successor_Link
renames Succ
.Table
(S
);
1481 -- Nothing to do if internal unit involved and no -da flag
1485 (Is_Internal_File_Name
(Units
.Table
(SL
.Before
).Sfile
)
1487 Is_Internal_File_Name
(Units
.Table
(SL
.After
).Sfile
))
1492 -- Here we want to generate output
1494 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1496 if SL
.Elab_Body
then
1497 Error_Msg_Unit_2
:= Units
.Table
(Corresponding_Body
(SL
.After
)).Uname
;
1499 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1502 Error_Msg_Output
(" $ must be elaborated before $", Info
=> True);
1504 Error_Msg_Unit_1
:= Units
.Table
(SL
.Reason_Unit
).Uname
;
1509 (" reason: with clause",
1514 (" reason: forced by -f switch",
1519 (" reason: pragma Elaborate in unit $",
1524 (" reason: pragma Elaborate_All in unit $",
1527 when Elab_All_Desirable
=>
1529 (" reason: implicit Elaborate_All in unit $",
1533 (" recompile $ with -gnatel for full details",
1536 when Elab_Desirable
=>
1538 (" reason: implicit Elaborate in unit $",
1542 (" recompile $ with -gnatel for full details",
1547 (" reason: spec always elaborated before body",
1551 Write_Elab_All_Chain
(S
);
1553 if SL
.Elab_Body
then
1554 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1555 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1557 (" $ must therefore be elaborated before $", True);
1559 Error_Msg_Unit_1
:= Units
.Table
(SL
.After
).Uname
;
1561 (" (because $ has a pragma Elaborate_Body)", True);
1564 if not Zero_Formatting
then
1569 ---------------------
1570 -- Find_Elab_Order --
1571 ---------------------
1573 procedure Find_Elab_Order
1574 (Elab_Order
: out Unit_Id_Table
;
1575 First_Main_Lib_File
: File_Name_Type
)
1577 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
;
1578 -- Number of cases where the body of a unit immediately follows the
1579 -- corresponding spec. Such cases are good, because calls to that unit
1580 -- from outside can't get ABE.
1582 -------------------------
1583 -- Num_Spec_Body_Pairs --
1584 -------------------------
1586 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
is
1590 for J
in Order
'First + 1 .. Order
'Last loop
1591 if Units
.Table
(Order
(J
- 1)).Utype
= Is_Spec
1592 and then Units
.Table
(Order
(J
)).Utype
= Is_Body
1593 and then Corresponding_Spec
(Order
(J
)) = Order
(J
- 1)
1595 Result
:= Result
+ 1;
1600 end Num_Spec_Body_Pairs
;
1604 Old_Elab_Order
: Unit_Id_Table
;
1606 -- Start of processing for Find_Elab_Order
1609 -- Output warning if -p used with no -gnatE units
1611 if Pessimistic_Elab_Order
1612 and not Dynamic_Elaboration_Checks_Specified
1614 Error_Msg
("?use of -p switch questionable");
1615 Error_Msg
("?since all units compiled with static elaboration model");
1618 if Do_New
and not Debug_Flag_Old
and not Debug_Flag_Older
then
1619 if Debug_Flag_V
then
1620 Write_Line
("Doing new...");
1625 Elab_New
.Find_Elab_Order
(Elab_Order
);
1628 -- Elab_New does not support the pessimistic order, so if that was
1629 -- requested, use the old results. Use Elab_Old if -dp or -do was
1630 -- selected. Elab_New does not yet give proper error messages for
1631 -- illegal Elaborate_Alls, so if there is one, run Elab_Old.
1634 or Pessimistic_Elab_Order
1639 if Debug_Flag_V
then
1640 Write_Line
("Doing old...");
1645 Elab_Old
.Find_Elab_Order
(Old_Elab_Order
);
1648 pragma Assert
(Elab_Cycle_Found
<= -- implies
1649 Diagnose_Elaboration_Problem_Called
);
1652 Old_Order
: Unit_Id_Array
renames
1653 Old_Elab_Order
.Table
(1 .. Last
(Old_Elab_Order
));
1655 if Do_Old
and Do_New
then
1657 New_Order
: Unit_Id_Array
renames
1658 Elab_Order
.Table
(1 .. Last
(Elab_Order
));
1659 Old_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(Old_Order
);
1660 New_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(New_Order
);
1663 Write_Line
(Get_Name_String
(First_Main_Lib_File
));
1665 pragma Assert
(Old_Order
'Length = New_Order
'Length);
1666 pragma Debug
(Validate
(Old_Order
, Doing_New
=> False));
1667 pragma Debug
(Validate
(New_Order
, Doing_New
=> True));
1669 -- Misc debug printouts that can be used for experimentation by
1670 -- changing the 'if's below.
1673 if New_Order
= Old_Order
then
1674 Write_Line
("Elab_New: same order.");
1676 Write_Line
("Elab_New: diff order.");
1680 if New_Order
/= Old_Order
and then False then
1681 Write_Line
("Elaboration orders differ:");
1683 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1685 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1689 Write_Str
("Pairs: ");
1690 Write_Int
(Old_Pairs
);
1692 if Old_Pairs
= New_Pairs
then
1694 elsif Old_Pairs
< New_Pairs
then
1700 Write_Int
(New_Pairs
);
1704 if Old_Pairs
/= New_Pairs
and then False then
1705 Write_Str
("Pairs: ");
1706 Write_Int
(Old_Pairs
);
1708 if Old_Pairs
< New_Pairs
then
1714 Write_Int
(New_Pairs
);
1717 if Old_Pairs
/= New_Pairs
and then Debug_Flag_V
then
1719 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1721 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1722 pragma Assert
(New_Pairs
>= Old_Pairs
);
1728 -- The Elab_New algorithm doesn't implement the -p switch, so if that
1729 -- was used, use the results from the old algorithm. Likewise if the
1730 -- user has requested the old algorithm.
1732 if Pessimistic_Elab_Order
or Debug_Flag_Old
or Debug_Flag_Older
then
1734 (Last
(Elab_Order
) = 0
1735 or else Last
(Elab_Order
) = Old_Order
'Last);
1738 Append_All
(Elab_Order
, Old_Order
);
1741 -- Now set the Elab_Positions in the Units table. It is important to
1742 -- do this late, in case we're running both Elab_New and Elab_Old.
1745 New_Order
: Unit_Id_Array
renames
1746 Elab_Order
.Table
(1 .. Last
(Elab_Order
));
1747 Units_Array
: Units
.Table_Type
renames
1748 Units
.Table
(Units
.First
.. Units
.Last
);
1750 for J
in New_Order
'Range loop
1752 (UNR
.Table
(New_Order
(J
)).Elab_Position
= J
);
1753 Units_Array
(New_Order
(J
)).Elab_Position
:= J
;
1756 if Errors_Detected
= 0 then
1758 -- Display elaboration order if -l was specified
1760 if Elab_Order_Output
then
1761 if Zero_Formatting
then
1762 Write_Elab_Order
(New_Order
, Title
=> "");
1765 (New_Order
, Title
=> "ELABORATION ORDER");
1769 -- Display list of sources in the closure (except predefined
1770 -- sources) if -R was used. Include predefined sources if -Ra
1773 if List_Closure
then
1774 Write_Closure
(New_Order
);
1779 end Find_Elab_Order
;
1781 ----------------------
1782 -- Force_Elab_Order --
1783 ----------------------
1785 procedure Force_Elab_Order
is
1787 -- There is a lot of fiddly string manipulation below, because we don't
1788 -- want to depend on misc utility packages like Ada.Characters.Handling.
1790 function Get_Line
return String;
1791 -- Read the next line from the file content read by Read_File. Strip
1792 -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
1793 -- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
1795 function Read_File
(Name
: String) return String_Ptr
;
1796 -- Read the entire contents of the named file
1802 function Read_File
(Name
: String) return String_Ptr
is
1804 -- All of the following calls should succeed, because we checked the
1805 -- file in Switch.B, but we double check and raise Program_Error on
1806 -- failure, just in case.
1808 F
: constant File_Descriptor
:= Open_Read
(Name
, Binary
);
1811 if F
= Invalid_FD
then
1812 raise Program_Error
;
1816 Len
: constant Natural := Natural (File_Length
(F
));
1817 Result
: constant String_Ptr
:= new String (1 .. Len
);
1818 Len_Read
: constant Natural :=
1819 Read
(F
, Result
(1)'Address, Len
);
1824 if Len_Read
/= Len
then
1825 raise Program_Error
;
1831 raise Program_Error
;
1838 Cur
: Positive := 1;
1839 S
: String_Ptr
:= Read_File
(Force_Elab_Order_File
.all);
1845 function Get_Line
return String is
1846 First
: Positive := Cur
;
1850 -- Skip to end of line
1853 and then S
(Cur
) /= ASCII
.LF
1854 and then S
(Cur
) /= ASCII
.CR
1859 -- Strip leading blanks
1861 while First
<= S
'Last and then S
(First
) = ' ' loop
1865 -- Strip trailing blanks and comment
1869 for J
in First
.. Last
- 1 loop
1870 if S
(J
.. J
+ 1) = "--" then
1876 while Last
>= First
and then S
(Last
) = ' ' loop
1880 -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks
1884 Body_String
: constant String := "(body)";
1885 BL
: constant Positive := Body_String
'Length;
1886 Spec_String
: constant String := "(spec)";
1887 SL
: constant Positive := Spec_String
'Length;
1889 Line
: String renames S
(First
.. Last
);
1891 Is_Body
: Boolean := False;
1892 Is_Spec
: Boolean := False;
1895 if Line
'Length >= SL
1896 and then Line
(Last
- SL
+ 1 .. Last
) = Spec_String
1900 elsif Line
'Length >= BL
1901 and then Line
(Last
- BL
+ 1 .. Last
) = Body_String
1907 while Last
>= First
and then S
(Last
) = ' ' loop
1911 -- Skip past LF or CR/LF
1913 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.CR
then
1917 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.LF
then
1922 return Line
(First
.. Last
) & "%s";
1924 return Line
(First
.. Last
) & "%b";
1933 Empty_Name
: constant Unit_Name_Type
:= Name_Find
("");
1934 Prev_Unit
: Unit_Id
:= No_Unit_Id
;
1936 -- Start of processing for Force_Elab_Order
1939 -- Loop through the file content, and build a dependency link for each
1940 -- pair of lines. Ignore lines that should be ignored.
1942 while Cur
<= S
'Last loop
1944 Uname
: constant Unit_Name_Type
:= Name_Find
(Get_Line
);
1947 if Uname
= Empty_Name
then
1948 null; -- silently skip blank lines
1950 elsif Get_Name_Table_Int
(Uname
) = 0
1951 or else Unit_Id
(Get_Name_Table_Int
(Uname
)) = No_Unit_Id
1955 ("""" & Get_Name_String
(Uname
)
1956 & """: not present; ignored");
1961 Cur_Unit
: constant Unit_Id
:= Unit_Id_Of
(Uname
);
1964 if Is_Internal_File_Name
(Units
.Table
(Cur_Unit
).Sfile
) then
1967 ("""" & Get_Name_String
(Uname
) &
1968 """: predefined unit ignored");
1972 if Prev_Unit
/= No_Unit_Id
then
1974 Write_Unit_Name
(Units
.Table
(Prev_Unit
).Uname
);
1975 Write_Str
(" <-- ");
1976 Write_Unit_Name
(Units
.Table
(Cur_Unit
).Uname
);
1981 (Before
=> Prev_Unit
,
1986 Prev_Unit
:= Cur_Unit
;
1994 end Force_Elab_Order
;
1996 -------------------------
1997 -- Gather_Dependencies --
1998 -------------------------
2000 procedure Gather_Dependencies
is
2001 Withed_Unit
: Unit_Id
;
2004 -- Loop through all units
2006 for U
in Units
.First
.. Units
.Last
loop
2009 -- If this is not an interface to a stand-alone library and there is
2010 -- a body and a spec, then spec must be elaborated first. Note that
2011 -- the corresponding spec immediately follows the body.
2013 if not Units
.Table
(U
).SAL_Interface
2014 and then Units
.Table
(U
).Utype
= Is_Body
2016 Build_Link
(Corresponding_Spec
(U
), U
, Spec_First
);
2019 -- If this unit is not an interface to a stand-alone library, process
2020 -- WITH references for this unit ignoring interfaces to stand-alone
2023 if not Units
.Table
(U
).SAL_Interface
then
2024 for W
in Units
.Table
(U
).First_With
..
2025 Units
.Table
(U
).Last_With
2027 if Withs
.Table
(W
).Sfile
/= No_File
2028 and then (not Withs
.Table
(W
).SAL_Interface
)
2030 -- Check for special case of withing a unit that does not
2031 -- exist any more. If the unit was completely missing we
2032 -- would already have detected this, but a nasty case arises
2033 -- when we have a subprogram body with no spec, and some
2034 -- obsolete unit with's a previous (now disappeared) spec.
2036 if Get_Name_Table_Int
(Withs
.Table
(W
).Uname
) = 0 then
2038 Error_Msg_File_1
:= Units
.Table
(U
).Sfile
;
2039 Error_Msg_Unit_1
:= Withs
.Table
(W
).Uname
;
2040 Error_Msg
("{ depends on $ which no longer exists");
2046 Withed_Unit
:= Unit_Id_Of
(Withs
.Table
(W
).Uname
);
2048 -- Pragma Elaborate_All case, for this we use the recursive
2049 -- Elab_All_Links procedure to establish the links.
2051 -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
2052 -- except for error messages.
2054 if Withs
.Table
(W
).Elaborate_All
and then not Doing_New
then
2056 -- Reset flags used to stop multiple visits to a given
2059 for Uref
in UNR
.First
.. UNR
.Last
loop
2060 UNR
.Table
(Uref
).Visited
:= False;
2063 -- Now establish all the links we need
2066 (Withed_Unit
, U
, Elab_All
,
2068 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2070 -- Elaborate_All_Desirable case, for this we establish the
2071 -- same links as above, but with a different reason.
2073 elsif Withs
.Table
(W
).Elab_All_Desirable
2074 and then not Doing_New
2076 -- Reset flags used to stop multiple visits to a given
2079 for Uref
in UNR
.First
.. UNR
.Last
loop
2080 UNR
.Table
(Uref
).Visited
:= False;
2083 -- Now establish all the links we need
2086 (Withed_Unit
, U
, Elab_All_Desirable
,
2088 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2090 -- Pragma Elaborate case. We must build a link for the
2091 -- withed unit itself, and also the corresponding body if
2094 -- However, skip this processing if there is no ALI file for
2095 -- the WITH entry, because this means it is a generic (even
2096 -- when we fix the generics so that an ALI file is present,
2097 -- we probably still will have no ALI file for unchecked and
2098 -- other special cases).
2100 elsif Withs
.Table
(W
).Elaborate
2101 and then Withs
.Table
(W
).Afile
/= No_File
2103 Build_Link
(Withed_Unit
, U
, Withed
);
2105 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2107 (Corresponding_Body
(Withed_Unit
), U
, Elab
);
2110 -- Elaborate_Desirable case, for this we establish the same
2111 -- links as above, but with a different reason.
2113 elsif Withs
.Table
(W
).Elab_Desirable
then
2114 Build_Link
(Withed_Unit
, U
, Withed
);
2116 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2118 (Corresponding_Body
(Withed_Unit
),
2122 -- A limited_with does not establish an elaboration
2123 -- dependence (that's the whole point).
2125 elsif Withs
.Table
(W
).Limited_With
then
2128 -- Case of normal WITH with no elaboration pragmas, just
2129 -- build the single link to the directly referenced unit
2132 Build_Link
(Withed_Unit
, U
, Withed
);
2142 -- If -f<elab_order> switch was given, take into account dependences
2143 -- specified in the file <elab_order>.
2145 if Force_Elab_Order_File
/= null then
2149 -- Output elaboration dependencies if option is set
2151 if Elab_Dependency_Output
or Debug_Flag_E
then
2156 end Gather_Dependencies
;
2165 Num_Left
:= Int
(Units
.Last
- Units
.First
+ 1);
2167 Elab_All_Entries
.Init
;
2170 -- Initialize unit table for elaboration control
2172 for U
in Units
.First
.. Units
.Last
loop
2174 ((Successors
=> No_Successor
,
2176 Nextnp
=> No_Unit_Id
,
2179 SCC_Root
=> No_Unit_Id
,
2182 Validate_Seen
=> False));
2190 function Is_Body_Unit
(U
: Unit_Id
) return Boolean is
2193 Units
.Table
(U
).Utype
= Is_Body
2194 or else Units
.Table
(U
).Utype
= Is_Body_Only
;
2197 -----------------------------
2198 -- Is_Pure_Or_Preelab_Unit --
2199 -----------------------------
2201 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean is
2203 -- If we have a body with separate spec, test flags on the spec
2205 if Units
.Table
(U
).Utype
= Is_Body
then
2207 Units
.Table
(Corresponding_Spec
(U
)).Preelab
2208 or else Units
.Table
(Corresponding_Spec
(U
)).Pure
;
2210 -- Otherwise we have a spec or body acting as spec, test flags on unit
2213 return Units
.Table
(U
).Preelab
or else Units
.Table
(U
).Pure
;
2215 end Is_Pure_Or_Preelab_Unit
;
2217 ---------------------
2218 -- Is_Waiting_Body --
2219 ---------------------
2221 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean is
2224 Units
.Table
(U
).Utype
= Is_Body
2225 and then UNR
.Table
(Corresponding_Spec
(U
)).Elab_Position
/= 0;
2226 end Is_Waiting_Body
;
2228 -------------------------
2229 -- Make_Elab_All_Entry --
2230 -------------------------
2232 function Make_Elab_All_Entry
2233 (Unam
: Unit_Name_Type
;
2234 Link
: Elab_All_Id
) return Elab_All_Id
2237 Elab_All_Entries
.Append
((Needed_By
=> Unam
, Next_Elab
=> Link
));
2238 return Elab_All_Entries
.Last
;
2239 end Make_Elab_All_Entry
;
2245 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
is
2246 Info
: constant Int
:= Get_Name_Table_Int
(Uname
);
2249 pragma Assert
(Info
/= 0 and then Unit_Id
(Info
) /= No_Unit_Id
);
2250 return Unit_Id
(Info
);
2257 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean) is
2258 Cur_SCC
: Unit_Id
:= No_Unit_Id
;
2259 OK
: Boolean := True;
2260 Msg
: String := "Old: ";
2267 -- For each unit, assert that its successors are elaborated after it
2269 for J
in Order
'Range loop
2271 U
: constant Unit_Id
:= Order
(J
);
2272 S
: Successor_Id
:= UNR
.Table
(U
).Successors
;
2275 while S
/= No_Successor
loop
2276 if UNR
.Table
(Succ
.Table
(S
).After
).Elab_Position
<=
2277 UNR
.Table
(U
).Elab_Position
2280 Write_Line
(Msg
& " elab order failed");
2283 S
:= Succ
.Table
(S
).Next
;
2288 -- An SCC of size 2 units necessarily consists of a spec and the
2289 -- corresponding body. Assert that the body is elaborated immediately
2290 -- after the spec, with nothing in between. (We only have SCCs in the
2294 for J
in Order
'Range loop
2296 U
: constant Unit_Id
:= Order
(J
);
2299 if Nodes
(U
)'Length = 2 then
2300 if Units
.Table
(U
).Utype
= Is_Spec
then
2301 if Order
(J
+ 1) /= Corresponding_Body
(U
) then
2303 Write_Line
(Msg
& "Bad spec with SCC of size 2:");
2304 Write_SCC
(SCC
(U
));
2308 if Units
.Table
(U
).Utype
= Is_Body
then
2309 if Order
(J
- 1) /= Corresponding_Spec
(U
) then
2311 Write_Line
(Msg
& "Bad body with SCC of size 2:");
2312 Write_SCC
(SCC
(U
));
2319 -- Assert that all units of an SCC are elaborated together, with no
2320 -- units from other SCCs in between. The above spec/body case is a
2321 -- special case of this general rule.
2323 for J
in Order
'Range loop
2325 U
: constant Unit_Id
:= Order
(J
);
2328 if SCC
(U
) /= Cur_SCC
then
2330 if UNR
.Table
(Cur_SCC
).Validate_Seen
then
2332 Write_Line
(Msg
& "SCC not elaborated together:");
2333 Write_SCC
(Cur_SCC
);
2336 UNR
.Table
(Cur_SCC
).Validate_Seen
:= True;
2349 procedure Write_Closure
(Order
: Unit_Id_Array
) is
2350 package Closure_Sources
is new Table
.Table
2351 (Table_Component_Type
=> File_Name_Type
,
2352 Table_Index_Type
=> Natural,
2353 Table_Low_Bound
=> 1,
2354 Table_Initial
=> 10,
2355 Table_Increment
=> 100,
2356 Table_Name
=> "Gnatbind.Closure_Sources");
2357 -- Table to record the sources in the closure, to avoid duplications
2359 function Put_In_Sources
(S
: File_Name_Type
) return Boolean;
2360 -- Check if S is already in table Sources and put in Sources if it is
2361 -- not. Return False if the source is already in Sources, and True if
2364 --------------------
2365 -- Put_In_Sources --
2366 --------------------
2368 function Put_In_Sources
(S
: File_Name_Type
) return Boolean is
2370 for J
in 1 .. Closure_Sources
.Last
loop
2371 if Closure_Sources
.Table
(J
) = S
then
2376 Closure_Sources
.Append
(S
);
2382 Source
: File_Name_Type
;
2384 -- Start of processing for Write_Closure
2387 Closure_Sources
.Init
;
2389 if not Zero_Formatting
then
2391 Write_Line
("REFERENCED SOURCES");
2394 for J
in reverse Order
'Range loop
2395 Source
:= Units
.Table
(Order
(J
)).Sfile
;
2397 -- Do not include same source more than once
2399 if Put_In_Sources
(Source
)
2401 -- Do not include run-time units unless -Ra switch set
2403 and then (List_Closure_All
2404 or else not Is_Internal_File_Name
(Source
))
2406 if not Zero_Formatting
then
2410 Write_Line
(Get_Name_String
(Source
));
2414 -- Subunits do not appear in the elaboration table because they are
2415 -- subsumed by their parent units, but we need to list them for other
2416 -- tools. For now they are listed after other files, rather than right
2417 -- after their parent, since there is no easy link between the
2418 -- elaboration table and the ALIs table ??? As subunits may appear
2419 -- repeatedly in the list, if the parent unit appears in the context of
2420 -- several units in the closure, duplicates are suppressed.
2422 for J
in Sdep
.First
.. Sdep
.Last
loop
2423 Source
:= Sdep
.Table
(J
).Sfile
;
2425 if Sdep
.Table
(J
).Subunit_Name
/= No_Name
2426 and then Put_In_Sources
(Source
)
2427 and then not Is_Internal_File_Name
(Source
)
2429 if not Zero_Formatting
then
2433 Write_Line
(Get_Name_String
(Source
));
2437 if not Zero_Formatting
then
2442 ------------------------
2443 -- Write_Dependencies --
2444 ------------------------
2446 procedure Write_Dependencies
is
2448 if not Zero_Formatting
then
2450 Write_Line
(" ELABORATION ORDER DEPENDENCIES");
2454 Info_Prefix_Suppress
:= True;
2456 for S
in Succ_First
.. Succ
.Last
loop
2460 Info_Prefix_Suppress
:= False;
2462 if not Zero_Formatting
then
2465 end Write_Dependencies
;
2467 --------------------------
2468 -- Write_Elab_All_Chain --
2469 --------------------------
2471 procedure Write_Elab_All_Chain
(S
: Successor_Id
) is
2472 ST
: constant Successor_Link
:= Succ
.Table
(S
);
2473 After
: constant Unit_Name_Type
:= Units
.Table
(ST
.After
).Uname
;
2476 Nam
: Unit_Name_Type
;
2478 First_Name
: Boolean := True;
2481 if ST
.Reason
in Elab_All
.. Elab_All_Desirable
then
2482 L
:= ST
.Elab_All_Link
;
2483 while L
/= No_Elab_All_Link
loop
2484 Nam
:= Elab_All_Entries
.Table
(L
).Needed_By
;
2485 Error_Msg_Unit_1
:= Nam
;
2486 Error_Msg_Output
(" $", Info
=> True);
2488 Get_Name_String
(Nam
);
2490 if Name_Buffer
(Name_Len
) = 'b' then
2493 (" must be elaborated along with its spec:",
2498 (" which must be elaborated along with its "
2511 (" which is withed by:",
2516 First_Name
:= False;
2518 L
:= Elab_All_Entries
.Table
(L
).Next_Elab
;
2521 Error_Msg_Unit_1
:= After
;
2522 Error_Msg_Output
(" $", Info
=> True);
2524 end Write_Elab_All_Chain
;
2526 ----------------------
2527 -- Write_Elab_Order --
2528 ----------------------
2530 procedure Write_Elab_Order
2531 (Order
: Unit_Id_Array
; Title
: String)
2539 for J
in Order
'Range loop
2540 if not Units
.Table
(Order
(J
)).SAL_Interface
then
2541 if not Zero_Formatting
then
2545 Write_Unit_Name
(Units
.Table
(Order
(J
)).Uname
);
2553 end Write_Elab_Order
;
2559 package body Elab_New
is
2565 type Node_Array
is array (Pos
range <>) of Node
;
2566 with function Successors
(N
: Node
) return Node_Array
;
2567 with procedure Create_SCC
(Root
: Node
; Nodes
: Node_Array
);
2569 procedure Compute_Strongly_Connected_Components
;
2570 -- Compute SCCs for a directed graph. The nodes in the graph are all
2571 -- values of type Node in the range First_Node .. Last_Node.
2572 -- Successors(N) returns the nodes pointed to by the edges emanating
2573 -- from N. Create_SCC is a callback that is called once for each SCC,
2574 -- passing in the Root node for that SCC (which is an arbitrary node in
2575 -- the SCC used as a representative of that SCC), and the set of Nodes
2578 -- This is generic, in case we want to use it elsewhere; then we could
2579 -- move this into a separate library unit. Unfortunately, it's not as
2580 -- generic as one might like. Ideally, we would have "type Node is
2581 -- private;", and pass in iterators to iterate over all nodes, and over
2582 -- the successors of a given node. However, that leads to using advanced
2583 -- features of Ada that are not allowed in the compiler and binder for
2584 -- bootstrapping reasons. It also leads to trampolines, which are not
2585 -- allowed in the compiler and binder. Restricting Node to be discrete
2586 -- allows us to iterate over all nodes with a 'for' loop, and allows us
2587 -- to attach temporary information to nodes by having an array indexed
2590 procedure Compute_Unit_SCCs
;
2591 -- Use the above generic procedure to compute the SCCs for the graph of
2592 -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
2593 -- components. Also initialize the SCC_Num_Pred components.
2595 procedure Find_Elab_All_Errors
;
2596 -- Generate an error for illegal Elaborate_All pragmas (explicit or
2597 -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
2598 -- if X and Y are in different SCCs.
2600 -------------------------------------------
2601 -- Compute_Strongly_Connected_Components --
2602 -------------------------------------------
2604 procedure Compute_Strongly_Connected_Components
is
2606 -- This uses Tarjan's algorithm for finding SCCs. Comments here are
2607 -- intended to tell what it does, but if you want to know how it
2608 -- works, you have to look it up. Please do not modify this code
2609 -- without reading up on Tarjan's algorithm.
2611 subtype Node_Index
is Nat
;
2612 No_Index
: constant Node_Index
:= 0;
2614 Num_Nodes
: constant Nat
:=
2615 Node
'Pos (Last_Node
) - Node
'Pos (First_Node
) + 1;
2616 Stack
: Node_Array
(1 .. Num_Nodes
);
2617 Top
: Node_Index
:= 0;
2618 -- Stack of nodes, pushed when first visited. All nodes of an SCC are
2619 -- popped at once when the SCC is found.
2621 subtype Valid_Node
is Node
range First_Node
.. Last_Node
;
2622 Node_Indices
: array (Valid_Node
) of Node_Index
:=
2623 (others => No_Index
);
2624 -- Each node has an "index", which is the sequential number in the
2625 -- order in which they are visited in the recursive walk. No_Index
2626 -- means "not yet visited"; we want to avoid walking any node more
2629 Index
: Node_Index
:= 1;
2630 -- Next value to be assigned to a node index
2632 Low_Links
: array (Valid_Node
) of Node_Index
;
2633 -- Low_Links (N) is the smallest index of nodes reachable from N
2635 On_Stack
: array (Valid_Node
) of Boolean := (others => False);
2636 -- True if the node is currently on the stack
2638 procedure Walk
(N
: Valid_Node
);
2639 -- Recursive depth-first graph walk, with the node index used to
2640 -- avoid visiting a node more than once.
2646 procedure Walk
(N
: Valid_Node
) is
2647 Stack_Position_Of_N
: constant Pos
:= Top
+ 1;
2648 S
: constant Node_Array
:= Successors
(N
);
2651 -- Assign the index and low link, increment Index for next call to
2654 Node_Indices
(N
) := Index
;
2655 Low_Links
(N
) := Index
;
2658 -- Push it on the stack:
2660 Top
:= Stack_Position_Of_N
;
2662 On_Stack
(N
) := True;
2664 -- Walk not-yet-visited subnodes, and update low link for visited
2665 -- ones as appropriate.
2667 for J
in S
'Range loop
2668 if Node_Indices
(S
(J
)) = No_Index
then
2671 Node_Index
'Min (Low_Links
(N
), Low_Links
(S
(J
)));
2672 elsif On_Stack
(S
(J
)) then
2674 Node_Index
'Min (Low_Links
(N
), Node_Indices
(S
(J
)));
2678 -- If the index is (still) equal to the low link, we've found an
2679 -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
2681 if Low_Links
(N
) = Node_Indices
(N
) then
2683 SCC
: Node_Array
renames
2684 Stack
(Stack_Position_Of_N
.. Top
);
2685 pragma Assert
(SCC
'Length >= 1);
2686 pragma Assert
(SCC
(SCC
'First) = N
);
2689 for J
in SCC
'Range loop
2690 On_Stack
(SCC
(J
)) := False;
2693 Create_SCC
(Root
=> N
, Nodes
=> SCC
);
2694 pragma Assert
(Top
- SCC
'Length = Stack_Position_Of_N
- 1);
2695 Top
:= Stack_Position_Of_N
- 1; -- pop all
2700 -- Start of processing for Compute_Strongly_Connected_Components
2703 -- Walk all the nodes that have not yet been walked
2705 for N
in Valid_Node
loop
2706 if Node_Indices
(N
) = No_Index
then
2710 end Compute_Strongly_Connected_Components
;
2712 -----------------------
2713 -- Compute_Unit_SCCs --
2714 -----------------------
2716 procedure Compute_Unit_SCCs
is
2717 function Successors
(U
: Unit_Id
) return Unit_Id_Array
;
2718 -- Return all the units that must be elaborated after U. In addition,
2719 -- if U is a body, include the corresponding spec; this ensures that
2720 -- a spec/body pair are always in the same SCC.
2722 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
);
2723 -- Set Nodes of the Root, and set SCC_Root of all the Nodes
2725 procedure Init_SCC_Num_Pred
(U
: Unit_Id
);
2726 -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
2727 -- has a count of the number of successors of all the units in the
2728 -- SCC, but only for successors outside the SCC.
2730 procedure Compute_SCCs
is new Compute_Strongly_Connected_Components
2732 First_Node
=> Units
.First
,
2733 Last_Node
=> Units
.Last
,
2734 Node_Array
=> Unit_Id_Array
,
2735 Successors
=> Successors
,
2736 Create_SCC
=> Create_SCC
);
2742 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
) is
2744 if Debug_Flag_V
then
2745 Write_Str
("Root = ");
2746 Write_Int
(Int
(Root
));
2748 Write_Unit_Name
(Units
.Table
(Root
).Uname
);
2750 Write_Int
(Nodes
'Length);
2751 Write_Line
(" units:");
2753 for J
in Nodes
'Range loop
2755 Write_Int
(Int
(Nodes
(J
)));
2757 Write_Unit_Name
(Units
.Table
(Nodes
(J
)).Uname
);
2762 pragma Assert
(Nodes
(Nodes
'First) = Root
);
2763 pragma Assert
(UNR
.Table
(Root
).Nodes
= null);
2764 UNR
.Table
(Root
).Nodes
:= new Unit_Id_Array
'(Nodes);
2766 for J in Nodes'Range loop
2767 pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
2768 UNR.Table (Nodes (J)).SCC_Root := Root;
2776 function Successors (U : Unit_Id) return Unit_Id_Array is
2777 S : Successor_Id := UNR.Table (U).Successors;
2778 Tab : Unit_Id_Table;
2781 -- Pretend that a spec is a successor of its body (even though it
2782 -- isn't), just so both get included.
2784 if Units.Table (U).Utype = Is_Body then
2785 Append (Tab, Corresponding_Spec (U));
2788 -- Now include the real successors
2790 while S /= No_Successor loop
2791 pragma Assert (Succ.Table (S).Before = U);
2792 Append (Tab, Succ.Table (S).After);
2793 S := Succ.Table (S).Next;
2797 Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
2805 -----------------------
2806 -- Init_SCC_Num_Pred --
2807 -----------------------
2809 procedure Init_SCC_Num_Pred (U : Unit_Id) is
2811 if UNR.Table (U).Visited then
2815 UNR.Table (U).Visited := True;
2818 S : Successor_Id := UNR.Table (U).Successors;
2821 while S /= No_Successor loop
2822 pragma Assert (Succ.Table (S).Before = U);
2823 Init_SCC_Num_Pred (Succ.Table (S).After);
2825 if SCC (U) /= SCC (Succ.Table (S).After) then
2826 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
2827 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
2830 S := Succ.Table (S).Next;
2833 end Init_SCC_Num_Pred;
2835 -- Start of processing for Compute_Unit_SCCs
2840 for Uref in UNR.First .. UNR.Last loop
2841 pragma Assert (not UNR.Table (Uref).Visited);
2845 for Uref in UNR.First .. UNR.Last loop
2846 Init_SCC_Num_Pred (Uref);
2849 -- Assert that SCC_Root of all units has been set to a valid unit,
2850 -- and that SCC_Num_Pred has not been modified in non-root units.
2852 for Uref in UNR.First .. UNR.Last loop
2853 pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
2854 pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
2856 if SCC (Uref) /= Uref then
2857 pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
2861 end Compute_Unit_SCCs;
2863 --------------------------
2864 -- Find_Elab_All_Errors --
2865 --------------------------
2867 procedure Find_Elab_All_Errors is
2868 Withed_Unit : Unit_Id;
2871 for U in Units.First .. Units.Last loop
2873 -- If this unit is not an interface to a stand-alone library,
2874 -- process WITH references for this unit ignoring interfaces to
2875 -- stand-alone libraries.
2877 if not Units.Table (U).SAL_Interface then
2878 for W in Units.Table (U).First_With ..
2879 Units.Table (U).Last_With
2881 if Withs.Table (W).Sfile /= No_File
2882 and then (not Withs.Table (W).SAL_Interface)
2884 -- Check for special case of withing a unit that does not
2887 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
2891 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
2893 -- If it's Elaborate_All or Elab_All_Desirable, check
2894 -- that the withER and withEE are not in the same SCC.
2896 if Withs.Table (W).Elaborate_All
2897 or else Withs.Table (W).Elab_All_Desirable
2899 if SCC (U) = SCC (Withed_Unit) then
2900 Elab_Cycle_Found := True; -- ???
2902 -- We could probably give better error messages
2903 -- than Elab_Old here, but for now, to avoid
2904 -- disruption, we don't give any error here.
2905 -- Instead, we set the Elab_Cycle_Found flag above,
2906 -- and then run the Elab_Old algorithm to issue the
2907 -- error message. Ideally, we would like to print
2908 -- multiple errors rather than stopping after the
2913 ("illegal pragma Elaborate_All",
2925 end Find_Elab_All_Errors;
2927 ---------------------
2928 -- Find_Elab_Order --
2929 ---------------------
2931 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
2932 Best_So_Far : Unit_Id;
2936 -- Gather dependencies and output them if option set
2938 Gather_Dependencies;
2942 -- Initialize the no-predecessor list
2944 No_Pred := No_Unit_Id;
2945 for U in UNR.First .. UNR.Last loop
2946 if UNR.Table (U).Num_Pred = 0 then
2947 UNR.Table (U).Nextnp := No_Pred;
2952 -- OK, now we determine the elaboration order proper. All we do is to
2953 -- select the best choice from the no-predecessor list until all the
2954 -- nodes have been chosen.
2957 if Debug_Flag_N then
2958 Write_Line ("Outer loop");
2961 -- If there are no nodes with predecessors, then either we are
2962 -- done, as indicated by Num_Left being set to zero, or we have
2963 -- a circularity. In the latter case, diagnose the circularity,
2964 -- removing it from the graph and continue.
2965 -- ????But Diagnose_Elaboration_Problem always raises an
2966 -- exception, so the loop never goes around more than once.
2968 Get_No_Pred : while No_Pred = No_Unit_Id loop
2969 exit Outer when Num_Left < 1;
2970 Diagnose_Elaboration_Problem (Elab_Order);
2971 end loop Get_No_Pred;
2974 Best_So_Far := No_Unit_Id;
2976 -- Loop to choose best entry in No_Pred list
2978 No_Pred_Search : loop
2979 if Debug_Flag_N then
2980 Write_Str (" considering choice of ");
2981 Write_Unit_Name (Units.Table (U).Uname);
2984 if Units.Table (U).Elaborate_Body then
2986 (" Elaborate_Body = True, Num_Pred for body = ");
2988 (UNR.Table (Corresponding_Body (U)).Num_Pred);
2991 (" Elaborate_Body = False");
2997 -- Don't even consider units whose SCC is not ready. This
2998 -- ensures that all units of an SCC will be elaborated
2999 -- together, with no other units in between.
3001 if SCC_Num_Pred (U) = 0
3002 and then Better_Choice (U, Best_So_Far)
3004 if Debug_Flag_N then
3005 Write_Line (" tentatively chosen (best so far)");
3010 if Debug_Flag_N then
3011 Write_Line (" SCC not ready");
3015 U := UNR.Table (U).Nextnp;
3016 exit No_Pred_Search when U = No_Unit_Id;
3017 end loop No_Pred_Search;
3019 -- If there are no units on the No_Pred list whose SCC is ready,
3020 -- there must be a cycle. Defer to Elab_Old to print an error
3023 if Best_So_Far = No_Unit_Id then
3024 Elab_Cycle_Found := True;
3028 -- Choose the best candidate found
3030 Choose (Elab_Order, Best_So_Far, " [Best_So_Far]");
3032 -- If it's a spec with a body, and the body is not yet chosen,
3033 -- choose the body if possible. The case where the body is
3034 -- already chosen is Elaborate_Body; the above call to Choose
3035 -- the spec will also Choose the body.
3037 if Units.Table (Best_So_Far).Utype = Is_Spec
3039 (Corresponding_Body (Best_So_Far)).Elab_Position = 0
3042 Choose_The_Body : constant Boolean :=
3043 UNR.Table (Corresponding_Body
3044 (Best_So_Far)).Num_Pred = 0;
3047 if Debug_Flag_B then
3048 Write_Str ("Can we choose the body?... ");
3050 if Choose_The_Body then
3051 Write_Line ("Yes!");
3057 if Choose_The_Body then
3059 (Elab_Order => Elab_Order,
3060 Chosen => Corresponding_Body (Best_So_Far),
3066 -- Finally, choose all the rest of the units in the same SCC as
3067 -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
3068 -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
3072 Chose_One_Or_More : Boolean := False;
3073 SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
3076 for J in SCC'Range loop
3077 if UNR.Table (SCC (J)).Elab_Position = 0
3078 and then UNR.Table (SCC (J)).Num_Pred = 0
3080 Chose_One_Or_More := True;
3081 Choose (Elab_Order, SCC (J), " [same SCC]");
3085 exit when not Chose_One_Or_More;
3090 Find_Elab_All_Errors;
3091 end Find_Elab_Order;
3097 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
3099 return UNR.Table (SCC (U)).Nodes;
3106 function SCC (U : Unit_Id) return Unit_Id is
3108 return UNR.Table (U).SCC_Root;
3115 function SCC_Num_Pred (U : Unit_Id) return Int is
3117 return UNR.Table (SCC (U)).SCC_Num_Pred;
3124 procedure Write_SCC (U : Unit_Id) is
3125 pragma Assert (SCC (U) = U);
3127 for J in Nodes (U)'Range loop
3128 Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position);
3130 Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
3143 package body Elab_Old is
3145 ---------------------
3146 -- Find_Elab_Order --
3147 ---------------------
3149 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
3150 Best_So_Far : Unit_Id;
3154 -- Gather dependencies and output them if option set
3156 Gather_Dependencies;
3158 -- Initialize the no-predecessor list
3160 No_Pred := No_Unit_Id;
3161 for U in UNR.First .. UNR.Last loop
3162 if UNR.Table (U).Num_Pred = 0 then
3163 UNR.Table (U).Nextnp := No_Pred;
3168 -- OK, now we determine the elaboration order proper. All we do is to
3169 -- select the best choice from the no-predecessor list until all the
3170 -- nodes have been chosen.
3174 -- If there are no nodes with predecessors, then either we are
3175 -- done, as indicated by Num_Left being set to zero, or we have
3176 -- a circularity. In the latter case, diagnose the circularity,
3177 -- removing it from the graph and continue.
3178 -- ????But Diagnose_Elaboration_Problem always raises an
3179 -- exception, so the loop never goes around more than once.
3181 Get_No_Pred : while No_Pred = No_Unit_Id loop
3182 exit Outer when Num_Left < 1;
3183 Diagnose_Elaboration_Problem (Elab_Order);
3184 end loop Get_No_Pred;
3187 Best_So_Far := No_Unit_Id;
3189 -- Loop to choose best entry in No_Pred list
3191 No_Pred_Search : loop
3192 if Debug_Flag_N then
3193 Write_Str (" considering choice of ");
3194 Write_Unit_Name (Units.Table (U).Uname);
3197 if Units.Table (U).Elaborate_Body then
3199 (" Elaborate_Body = True, Num_Pred for body = ");
3201 (UNR.Table (Corresponding_Body (U)).Num_Pred);
3204 (" Elaborate_Body = False");
3210 -- This is a candididate to be considered for choice
3212 if Better_Choice (U, Best_So_Far) then
3213 if Debug_Flag_N then
3214 Write_Line (" tentatively chosen (best so far)");
3220 U := UNR.Table (U).Nextnp;
3221 exit No_Pred_Search when U = No_Unit_Id;
3222 end loop No_Pred_Search;
3224 -- Choose the best candidate found
3226 Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]");
3228 end Find_Elab_Order;