Index: binde.adb =================================================================== --- binde.adb (revision 161073) +++ binde.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -224,25 +224,25 @@ package body Binde is After : Unit_Id; R : Succ_Reason; Ea_Id : Elab_All_Id := No_Elab_All_Link); - -- Establish a successor link, Before must be elaborated before After, - -- and the reason for the link is R. Ea_Id is the contents to be placed - -- in the Elab_All_Link of the entry. + -- Establish a successor link, Before must be elaborated before After, and + -- the reason for the link is R. Ea_Id is the contents to be placed in the + -- Elab_All_Link of the entry. procedure Choose (Chosen : Unit_Id); - -- Chosen is the next entry chosen in the elaboration order. This - -- procedure updates all data structures appropriately. + -- Chosen is the next entry chosen in the elaboration order. This procedure + -- updates all data structures appropriately. function Corresponding_Body (U : Unit_Id) return Unit_Id; pragma Inline (Corresponding_Body); - -- Given a unit which is a spec for which there is a separate body, - -- return the unit id of the body. It is an error to call this routine - -- with a unit that is not a spec, or which does not have a separate body. + -- Given a unit which is a spec for which there is a separate body, return + -- the unit id of the body. It is an error to call this routine with a unit + -- that is not a spec, or which does not have a separate body. function Corresponding_Spec (U : Unit_Id) return Unit_Id; pragma Inline (Corresponding_Spec); - -- Given a unit which is a body for which there is a separate spec, - -- return the unit id of the spec. It is an error to call this routine - -- with a unit that is not a body, or which does not have a separate spec. + -- Given a unit which is a body for which there is a separate spec, return + -- the unit id of the spec. It is an error to call this routine with a unit + -- that is not a body, or which does not have a separate spec. procedure Diagnose_Elaboration_Problem; -- Called when no elaboration order can be found. Outputs an appropriate @@ -276,6 +276,10 @@ package body Binde is pragma Inline (Is_Body_Unit); -- Determines if given unit is a body + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean; + -- Returns True if corresponding unit is Pure or Preelaborate. Includes + -- dealing with testing flags on spec if it is given a body. + function Is_Waiting_Body (U : Unit_Id) return Boolean; pragma Inline (Is_Waiting_Body); -- Determines if U is a waiting body, defined as a body which has @@ -286,16 +290,16 @@ package body Binde is Link : Elab_All_Id) return Elab_All_Id; -- Make an Elab_All_Entries table entry with the given Unam and Link - function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; - -- This function uses the Info field set in the names table to obtain - -- the unit Id of a unit, given its name id value. - - function Worse_Choice (U1, U2 : Unit_Id) return Boolean; + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean; -- This is like Better_Choice, and has the same interface, but returns - -- true if U1 is a worse choice than U2 in the sense of the -h (horrible + -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic -- elaboration order) switch. We still have to obey Ada rules, so it is -- not quite the direct inverse of Better_Choice. + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; + -- This function uses the Info field set in the names table to obtain + -- the unit Id of a unit, given its name id value. + procedure Write_Dependencies; -- Write out dependencies (called only if appropriate option is set) @@ -323,7 +327,7 @@ package body Binde is -- Note: the checks here are applied in sequence, and the ordering is -- significant (i.e. the more important criteria are applied first). - -- Prefer a waiting body to any other case + -- Prefer a waiting body to one that is not a waiting body if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then if Debug_Flag_B then @@ -370,6 +374,28 @@ package body Binde is return False; + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + -- Prefer a body to a spec elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then @@ -1141,7 +1167,7 @@ package body Binde is or else ((not Pessimistic_Elab_Order) and then Better_Choice (U, Best_So_Far)) or else (Pessimistic_Elab_Order - and then Worse_Choice (U, Best_So_Far)) + and then Pessimistic_Better_Choice (U, Best_So_Far)) then if Debug_Flag_N then Write_Str (" tentatively chosen (best so far)"); @@ -1321,6 +1347,28 @@ package body Binde is or else Units.Table (U).Utype = Is_Body_Only; end Is_Body_Unit; + ----------------------------- + -- Is_Pure_Or_Preelab_Unit -- + ----------------------------- + + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is + begin + -- If we have a body with separate spec, test flags on the spec + + if Units.Table (U).Utype = Is_Body then + return Units.Table (U + 1).Preelab + or else + Units.Table (U + 1).Pure; + + -- Otherwise we have a spec or body acting as spec, test flags on unit + + else + return Units.Table (U).Preelab + or else + Units.Table (U).Pure; + end if; + end Is_Pure_Or_Preelab_Unit; + --------------------- -- Is_Waiting_Body -- --------------------- @@ -1346,51 +1394,115 @@ package body Binde is return Elab_All_Entries.Last; end Make_Elab_Entry; - ---------------- - -- Unit_Id_Of -- - ---------------- - - function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is - Info : constant Int := Get_Name_Table_Info (Uname); - begin - pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); - return Unit_Id (Info); - end Unit_Id_Of; - - ------------------ - -- Worse_Choice -- - ------------------ + ------------------------------- + -- Pessimistic_Better_Choice -- + ------------------------------- - function Worse_Choice (U1, U2 : Unit_Id) return Boolean is + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is UT1 : Unit_Record renames Units.Table (U1); UT2 : Unit_Record renames Units.Table (U2); begin + if Debug_Flag_B then + Write_Str ("Pessimistic_Better_Choice ("); + Write_Unit_Name (UT1.Uname); + Write_Str (", "); + Write_Unit_Name (UT2.Uname); + Write_Line (")"); + end if; + -- Note: the checks here are applied in sequence, and the ordering is -- significant (i.e. the more important criteria are applied first). - -- If either unit is internal, then use Better_Choice, since the - -- language requires that predefined units not mess up in the choice - -- of elaboration order, and for internal units, any problems are - -- ours and not the programmers. + -- If either unit is predefined or internal, then we use the normal + -- Better_Choice rule, since we don't want to disturb the elaboration + -- rules of the language with -p, same treatment for Pure/Preelab. + + -- Prefer a predefined unit to a non-predefined unit - if UT1.Internal or else UT2.Internal then - return Better_Choice (U1, U2); + if UT1.Predefined and then not UT2.Predefined then + if Debug_Flag_B then + Write_Line (" True: u1 is predefined, u2 is not"); + end if; - -- Prefer anything else to a waiting body (!) + return True; + + elsif UT2.Predefined and then not UT1.Predefined then + if Debug_Flag_B then + Write_Line (" False: u2 is predefined, u1 is not"); + end if; + + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif UT1.Internal and then not UT2.Internal then + if Debug_Flag_B then + Write_Line (" True: u1 is internal, u2 is not"); + end if; + + return True; + + elsif UT2.Internal and then not UT1.Internal then + if Debug_Flag_B then + Write_Line (" False: u2 is internal, u1 is not"); + end if; + + return False; + + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + + -- Prefer anything else to a waiting body. We want to make bodies wait + -- as long as possible, till we are forced to choose them! elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is waiting body, u2 is not"); + end if; + return False; elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is waiting body, u1 is not"); + end if; + return True; -- Prefer a spec to a body (!) elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is body, u2 is not"); + end if; + return False; elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is body, u1 is not"); + end if; + return True; -- If both are waiting bodies, then prefer the one whose spec is @@ -1404,12 +1516,24 @@ package body Binde is -- A before the spec of B if it could. Since it could not, there it -- must be the case that A depends on B. It is therefore a good idea -- to put the body of B last so that if there is an elaboration order - -- problem, we will find it (that's what horrible order is about) + -- problem, we will find it (that's what pssimistic order is about) elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then - return - UNR.Table (Corresponding_Spec (U1)).Elab_Position < - UNR.Table (Corresponding_Spec (U2)).Elab_Position; + declare + Result : constant Boolean := + UNR.Table (Corresponding_Spec (U1)).Elab_Position < + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True: based on waiting body elab positions"); + else + Write_Line (" False: based on waiting body elab positions"); + end if; + end if; + + return Result; + end; end if; -- Remaining choice rules are disabled by Debug flag -do @@ -1420,44 +1544,81 @@ package body Binde is -- as Elaborate_Body_Desirable. In the normal case, we generally want -- to delay the elaboration of these specs as long as possible, so -- that bodies have better chance of being elaborated closer to the - -- specs. Worse_Choice as usual wants to do the opposite and - -- elaborate such specs as early as possible. + -- specs. Pessimistic_Better_Choice as usual wants to do the opposite + -- and elaborate such specs as early as possible. -- If we have two units, one of which is a spec for which this flag -- is set, and the other is not, we normally prefer to delay the spec - -- for which the flag is set, and so Worse_Choice does the opposite. + -- for which the flag is set, so again Pessimistic_Better_Choice does + -- the opposite. if not UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then + if Debug_Flag_B then + Write_Line (" False: u1 is elab body desirable, u2 is not"); + end if; + return False; elsif not UT2.Elaborate_Body_Desirable and then UT1.Elaborate_Body_Desirable then + if Debug_Flag_B then + Write_Line (" True: u1 is elab body desirable, u2 is not"); + end if; + return True; -- If we have two specs that are both marked as Elaborate_Body -- desirable, we normally prefer the one whose body is nearer to -- being able to be elaborated, based on the Num_Pred count. This -- helps to ensure bodies are as close to specs as possible. As - -- usual, Worse_Choice does the opposite. + -- usual, Pessimistic_Better_Choice does the opposite. elsif UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then - return UNR.Table (Corresponding_Body (U1)).Num_Pred >= - UNR.Table (Corresponding_Body (U2)).Num_Pred; + declare + Result : constant Boolean := + UNR.Table (Corresponding_Body (U1)).Num_Pred >= + UNR.Table (Corresponding_Body (U2)).Num_Pred; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True based on Num_Pred compare"); + else + Write_Line (" False based on Num_Pred compare"); + end if; + end if; + + return Result; + end; end if; end if; -- If we fall through, it means that no preference rule applies, so we -- use alphabetical order to at least give a deterministic result. Since - -- Worse_Choice is in the business of stirring up the order, we will - -- use reverse alphabetical ordering. + -- Pessimistic_Better_Choice is in the business of stirring up the + -- order, we will use reverse alphabetical ordering. + + if Debug_Flag_B then + Write_Line (" choose on reverse alpha order"); + end if; return Uname_Less (UT2.Uname, UT1.Uname); - end Worse_Choice; + end Pessimistic_Better_Choice; + + ---------------- + -- Unit_Id_Of -- + ---------------- + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is + Info : constant Int := Get_Name_Table_Info (Uname); + begin + pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); + return Unit_Id (Info); + end Unit_Id_Of; ------------------------ -- Write_Dependencies --