diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c9994b98109a..6edf424d77ac 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2009-07-15 Ed Schonberg + + * sem_warn.adb (Warn_On_Constant_Condition): Handle properly constant + conditions of a derived boolean type. + Minor reformatting + +2009-07-15 Robert Dewar + + * gnat1drv.adb: Initialize SCO tables + + * par-load.adb: Call SCO_Record for main unit spec + + * par.adb: Make call to SCO_Record for main unit + + * par_sco.adb (Unit_Table): Change format to facilitate sort + (Process_Decisions): New procedure with list argument + (Traverse_Generic_Package_Declaration): New procedure + (Initialize): New procedure, replaces Init + (SCO_Output): Sort unit table before output + (SCO_Record): Avoid duplications + (SCO_Record): Handle remaining cases of units + (Traverse_Declarations_Or_Statements): Handle generics + + * par_sco.ads (Initialize): New peocedure (replaces Init) + + * sem_ch10.adb (Analyze_Proper_Body): Make call to SCO_Record for + subunit. + +2009-07-15 Arnaud Charlet + + * debug.adb: Add -gnatd.J switch for now to support scil generation in + parallel. Add missing doc for -gnatd.I and -gnatd.O + 2009-07-15 Robert Dewar * lib-load.adb: Minor reformatting diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index fc251f2238ad..baa04293cd18 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -127,12 +127,12 @@ package body Debug is -- d.G -- d.H -- d.I SCIL generation mode - -- d.J + -- d.J Parallel SCIL generation mode -- d.K -- d.L -- d.M -- d.N - -- d.O + -- d.O Dump internal SCO tables -- d.P -- d.Q -- d.R @@ -555,9 +555,17 @@ package body Debug is -- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases -- where we would normally generate inline concatenation code. - -- d.I Inspector mode. Relevant for VM_Target /= None. Try to generate - -- byte code, even in case of unsupported construct, for the sake - -- of static analysis tools. + -- d.I Generate SCIL mode. Generate intermediate code for the sake of + -- of static analysis tools, and ensure additional tree consistency + -- between different compilations of specs. + + -- d.J Ensure the SCIL generated is compatible with parallel builds. + -- This means in particular not writing the same files under the + -- same directory. + + -- d.O Dump internal SCO tables. Before outputting the SCO information to + -- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table) + -- are dumped for debugging purposes. -- d.S Force Optimize_Alignment (Space) mode as the default diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index c8d9cb35b732..79065e26addc 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -45,6 +45,7 @@ with Nlists; with Opt; use Opt; with Osint; use Osint; with Output; use Output; +with Par_SCO; with Prepcomp; with Repinfo; use Repinfo; with Restrict; @@ -506,6 +507,9 @@ begin -- nested blocks, so that the outer one handles unrecoverable error. begin + -- Initialize all packages. For the most part, these initialization + -- calls can be made in any order. Exceptions are as follows: + -- Lib.Initialize need to be called before Scan_Compiler_Arguments, -- because it initializes a table filled by Scan_Compiler_Arguments. @@ -527,6 +531,7 @@ begin Snames.Initialize; Stringt.Initialize; Inline.Initialize; + Par_SCO.Initialize; Sem_Ch8.Initialize; Sem_Ch12.Initialize; Sem_Ch13.Initialize; diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index e21fb0434c6b..9aa084238054 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.adb @@ -278,9 +278,14 @@ begin -- If this is a separate spec for the main unit, then we reset -- Main_Unit_Entity to point to the entity for this separate spec + -- and this is also where we generate the SCO's for this spec. if Cur_Unum = Main_Unit then Main_Unit_Entity := Cunit_Entity (Unum); + + if Generate_SCO then + SCO_Record (Unum); + end if; end if; -- If we don't find the spec, then if we have a subprogram body, we diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 6041c63b08be..78ffd604ebd1 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -1328,10 +1328,9 @@ begin if Ucount < Multiple_Unit_Index then - -- We skip in syntax check only mode, since we don't want - -- to do anything more than skip past the unit and ignore it. - -- This causes processing like setting up a unit table entry - -- to be skipped. + -- We skip in syntax check only mode, since we don't want to do + -- anything more than skip past the unit and ignore it. This means + -- we skip processing like setting up a unit table entry. declare Save_Operating_Mode : constant Operating_Mode_Type := @@ -1456,12 +1455,10 @@ begin pragma Assert (Scope.Last = 0); - -- This is where we generate SCO output if required + -- Here we make the SCO table entries for the main unit - if Generate_SCO - and then Operating_Mode = Generate_Code - then - SCO_Record (Current_Source_Unit); + if Generate_SCO then + SCO_Record (Main_Unit); end if; -- Remaining steps are to create implicit label declarations and to load diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index e0b5db3421e2..897b35981ca5 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -28,12 +28,14 @@ with Debug; use Debug; with Lib; use Lib; with Lib.Util; use Lib.Util; with Nlists; use Nlists; +with Opt; use Opt; with Output; use Output; with Sinfo; use Sinfo; with Sinput; use Sinput; with Table; -with GNAT.HTable; use GNAT.HTable; +with GNAT.HTable; use GNAT.HTable; +with GNAT.Heap_Sort_G; package body Par_SCO is @@ -120,20 +122,20 @@ package body Par_SCO is -- Unit Table -- ---------------- - -- This table keeps track of the units and the corresponding starting index - -- in the SCO table. The ending index is either one less than the starting - -- index of the next table entry, or, for the last table entry, it is - -- SCO_Table.Last. + -- This table keeps track of the units and the corresponding starting and + -- ending indexes (From, To) in the SCO table. Note that entry zero is + -- unused, it is for convenience in calling the sort routine. type SCO_Unit_Table_Entry is record - Unit : Unit_Number_Type; - Index : Int; + Unit : Unit_Number_Type; + From : Nat; + To : Nat; end record; package SCO_Unit_Table is new Table.Table ( Table_Component_Type => SCO_Unit_Table_Entry, Table_Index_Type => Int, - Table_Low_Bound => 1, + Table_Low_Bound => 0, Table_Initial => 20, Table_Increment => 200, Table_Name => "SCO_Unit_Table_Entry"); @@ -181,6 +183,9 @@ package body Par_SCO is -- the node is always a decision a decision is always present (at the very -- least a simple decision is present at the top level). + procedure Process_Decisions (L : List_Id; T : Character); + -- Calls above procedure for each element of the list L + procedure Set_Table_Entry (C1 : Character; C2 : Character; @@ -189,11 +194,12 @@ package body Par_SCO is Last : Boolean); -- Append an entry to SCO_Table with fields set as per arguments - procedure Traverse_Declarations_Or_Statements (L : List_Id); - procedure Traverse_Handled_Statement_Sequence (N : Node_Id); - procedure Traverse_Package_Body (N : Node_Id); - procedure Traverse_Package_Declaration (N : Node_Id); - procedure Traverse_Subprogram_Body (N : Node_Id); + procedure Traverse_Declarations_Or_Statements (L : List_Id); + procedure Traverse_Generic_Package_Declaration (N : Node_Id); + procedure Traverse_Handled_Statement_Sequence (N : Node_Id); + procedure Traverse_Package_Body (N : Node_Id); + procedure Traverse_Package_Declaration (N : Node_Id); + procedure Traverse_Subprogram_Body (N : Node_Id); -- Traverse the corresponding construct, generating SCO table entries procedure dsco; @@ -213,8 +219,10 @@ package body Par_SCO is Write_Int (Index); Write_Str (". Unit = "); Write_Int (Int (SCO_Unit_Table.Table (Index).Unit)); - Write_Str (" Index = "); - Write_Int (Int (SCO_Unit_Table.Table (Index).Index)); + Write_Str (" From = "); + Write_Int (Int (SCO_Unit_Table.Table (Index).From)); + Write_Str (" To = "); + Write_Int (Int (SCO_Unit_Table.Table (Index).To)); Write_Eol; end loop; @@ -297,14 +305,16 @@ package body Par_SCO is return Header_Num (Nat (F) mod 997); end Hash; - ---------- - -- Init -- - ---------- + ---------------- + -- Initialize -- + ---------------- - procedure Init is + procedure Initialize is begin - null; - end Init; + SCO_Unit_Table.Init; + SCO_Unit_Table.Increment_Last; + SCO_Table.Init; + end Initialize; ------------------------- -- Is_Logical_Operator -- @@ -324,10 +334,24 @@ package body Par_SCO is -- Process_Decisions -- ----------------------- - procedure Process_Decisions - (N : Node_Id; - T : Character) - is + -- Version taking a list + + procedure Process_Decisions (L : List_Id; T : Character) is + N : Node_Id; + begin + if L /= No_List then + N := First (L); + while Present (N) loop + Process_Decisions (N, T); + Next (N); + end loop; + end if; + end Process_Decisions; + + -- Version taking a node + + procedure Process_Decisions (N : Node_Id; T : Character) is + function Process_Node (N : Node_Id) return Traverse_Result; -- Processes one node in the traversal, looking for logical operators, -- and if one is found, outputs the appropriate table entries. @@ -567,40 +591,75 @@ package body Par_SCO is dsco; end if; + -- Sort the unit table + + Unit_Table_Sort : declare + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Comparison routine for sort call + + procedure Move (From : Natural; To : Natural); + -- Move routine for sort call + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Dependency_Num (SCO_Unit_Table.Table (Nat (Op1)).Unit) < + Dependency_Num (SCO_Unit_Table.Table (Nat (Op2)).Unit); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + SCO_Unit_Table.Table (Nat (To)) := + SCO_Unit_Table.Table (Nat (From)); + end Move; + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Unit_Table_Sort + + begin + Sorting.Sort (Integer (SCO_Unit_Table.Last)); + end Unit_Table_Sort; + -- Loop through entries in the unit table - for J in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop + for J in 1 .. SCO_Unit_Table.Last loop U := SCO_Unit_Table.Table (J).Unit; - if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then - Write_Info_Initiate ('C'); - Write_Info_Char (' '); - Write_Info_Nat (Dependency_Num (U)); - Write_Info_Char (' '); - Write_Info_Name (Reference_Name (Source_Index (U))); - Write_Info_Terminate; + -- Output header line preceded by blank line - Start := SCO_Unit_Table.Table (J).Index; + Write_Info_Terminate; + Write_Info_Initiate ('C'); + Write_Info_Char (' '); + Write_Info_Nat (Dependency_Num (U)); + Write_Info_Char (' '); + Write_Info_Name (Reference_Name (Source_Index (U))); + Write_Info_Terminate; - if J = SCO_Unit_Table.Last then - Stop := SCO_Table.Last; - else - Stop := SCO_Unit_Table.Table (J + 1).Index - 1; - end if; + Start := SCO_Unit_Table.Table (J).From; + Stop := SCO_Unit_Table.Table (J).To; - -- Loop through relevant entries in SCO table, outputting C lines + -- Loop through relevant entries in SCO table, outputting C lines - while Start <= Stop loop - declare - T : SCO_Table_Entry renames SCO_Table.Table (Start); + while Start <= Stop loop + declare + T : SCO_Table_Entry renames SCO_Table.Table (Start); - begin - Write_Info_Initiate ('C'); - Write_Info_Char (T.C1); + begin + Write_Info_Initiate ('C'); + Write_Info_Char (T.C1); - case T.C1 is + case T.C1 is - -- Statements, entry, exit + -- Statements, entry, exit when 'S' | 'Y' | 'T' => Write_Info_Char (' '); @@ -641,17 +700,16 @@ package body Par_SCO is when others => raise Program_Error; - end case; + end case; - Write_Info_Terminate; - end; + Write_Info_Terminate; + end; - exit when Start = Stop; - Start := Start + 1; + exit when Start = Stop; + Start := Start + 1; - pragma Assert (Start <= Stop); - end loop; - end if; + pragma Assert (Start <= Stop); + end loop; end loop; end SCO_Output; @@ -660,11 +718,35 @@ package body Par_SCO is ---------------- procedure SCO_Record (U : Unit_Number_Type) is - Cu : constant Node_Id := Cunit (U); - Lu : constant Node_Id := Unit (Cu); + Lu : Node_Id; + From : Nat; begin - SCO_Unit_Table.Append ((Unit => U, Index => SCO_Table.Last + 1)); + -- Ignore call if not generating code and generating SCO's + + if not (Generate_SCO and then Operating_Mode = Generate_Code) then + return; + end if; + + -- Ignore call if this unit already recorded + + for J in 1 .. SCO_Unit_Table.Last loop + if SCO_Unit_Table.Table (J).Unit = U then + return; + end if; + end loop; + + -- Otherwise record starting entry + + From := SCO_Table.Last + 1; + + -- Get Unit (checking case of subunit) + + Lu := Unit (Cunit (U)); + + if Nkind (Lu) = N_Subunit then + Lu := Proper_Body (Lu); + end if; -- Traverse the unit @@ -677,13 +759,20 @@ package body Par_SCO is elsif Nkind (Lu) = N_Package_Body then Traverse_Package_Body (Lu); - -- Ignore subprogram specifications, since nothing to cover. - -- Also ignore instantiations, since again, nothing to cover. - -- Also for now, ignore generic declarations ??? + elsif Nkind (Lu) = N_Generic_Package_Declaration then + Traverse_Generic_Package_Declaration (Lu); + + -- For anything else, the only issue is default expressions for + -- parameters, where we have to worry about possible embedded decisions + -- but nothing else. else - null; + Process_Decisions (Lu, 'X'); end if; + + -- Make entry for new unit in unit table + + SCO_Unit_Table.Append ((Unit => U, From => From, To => SCO_Table.Last)); end SCO_Record; ----------------------- @@ -774,12 +863,33 @@ package body Par_SCO is Set_Statement_Entry; Traverse_Package_Declaration (N); + -- Generic package declaration + + when N_Generic_Package_Declaration => + Set_Statement_Entry; + Traverse_Generic_Package_Declaration (N); + -- Package body when N_Package_Body => Set_Statement_Entry; Traverse_Package_Body (N); + -- Subprogram declaration + + when N_Subprogram_Declaration => + Set_Statement_Entry; + Process_Decisions + (Parameter_Specifications (Specification (N)), 'X'); + + -- Generic subprogram declaration + + when N_Generic_Subprogram_Declaration => + Set_Statement_Entry; + Process_Decisions (Generic_Formal_Declarations (N), 'X'); + Process_Decisions + (Parameter_Specifications (Specification (N)), 'X'); + -- Subprogram_Body when N_Subprogram_Body => @@ -906,6 +1016,16 @@ package body Par_SCO is end if; end Traverse_Declarations_Or_Statements; + ------------------------------------------ + -- Traverse_Generic_Package_Declaration -- + ------------------------------------------ + + procedure Traverse_Generic_Package_Declaration (N : Node_Id) is + begin + Process_Decisions (Generic_Formal_Declarations (N), 'X'); + Traverse_Package_Declaration (N); + end Traverse_Generic_Package_Declaration; + ----------------------------------------- -- Traverse_Handled_Statement_Sequence -- ----------------------------------------- diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads index 41c353327e2f..5adee95af156 100644 --- a/gcc/ada/par_sco.ads +++ b/gcc/ada/par_sco.ads @@ -201,7 +201,7 @@ package Par_SCO is -- Subprograms -- ----------------- - procedure Init; + procedure Initialize; -- Initialize internal tables for a new compilation procedure SCO_Record (U : Unit_Number_Type); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index a21cd5be34f9..a443e4100529 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -42,6 +42,7 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; +with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -1695,6 +1696,8 @@ package body Sem_Ch10 is Subunit => True, Error_Node => N); + -- Give message if we did not get the unit + if Original_Operating_Mode = Generate_Code and then Unum = No_Unit then @@ -1736,6 +1739,17 @@ package body Sem_Ch10 is Set_Corresponding_Stub (Unit (Comp_Unit), N); + -- Collect SCO information for loaded subunit if we are + -- in the main unit). + + if Generate_SCO + and then + In_Extended_Main_Source_Unit + (Cunit_Entity (Current_Sem_Unit)) + then + SCO_Record (Unum); + end if; + -- Analyze the unit if semantics active if not Fatal_Error (Unum) or else Try_Semantics then diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index e66369831fd7..1551acf092af 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3308,8 +3308,18 @@ package body Sem_Warn is ----------------------------- procedure Warn_On_Known_Condition (C : Node_Id) is - P : Node_Id; - Orig : constant Node_Id := Original_Node (C); + P : Node_Id; + Orig : constant Node_Id := Original_Node (C); + Test_Result : Boolean; + + function Is_Known_Branch return Boolean; + -- If the type of the condition is Boolean, the constant value of the + -- condition is a boolean literal. If the type is a derived boolean + -- type, the constant is wrapped in a type conversion of the derived + -- literal. If the value of the condition is not a literal, no warnings + -- can be produced. This function returns True if the result can be + -- determined, and Test_Result is set True/False accordingly. Otherwise + -- False is returned, and Test_Result is unchanged. procedure Track (N : Node_Id; Loc : Node_Id); -- Adds continuation warning(s) pointing to reason (assignment or test) @@ -3317,6 +3327,34 @@ package body Sem_Warn is -- enough is known about the value to issue the warning). N is the node -- which is judged to have a known value. Loc is the warning location. + --------------------- + -- Is_Known_Branch -- + --------------------- + + function Is_Known_Branch return Boolean is + begin + if Etype (C) = Standard_Boolean + and then Is_Entity_Name (C) + and then + (Entity (C) = Standard_False or else Entity (C) = Standard_True) + then + Test_Result := Entity (C) = Standard_True; + return True; + + elsif Is_Boolean_Type (Etype (C)) + and then Nkind (C) = N_Unchecked_Type_Conversion + and then Is_Entity_Name (Expression (C)) + and then Ekind (Entity (Expression (C))) = E_Enumeration_Literal + then + Test_Result := + Chars (Entity (Expression (C))) = Chars (Standard_True); + return True; + + else + return False; + end if; + end Is_Known_Branch; + ----------- -- Track -- ----------- @@ -3362,7 +3400,7 @@ package body Sem_Warn is if Generate_SCO and then Comes_From_Source (Orig) - and then Is_Entity_Name (C) + and then Is_Known_Branch then declare Start : Source_Ptr; @@ -3372,8 +3410,7 @@ package body Sem_Warn is begin Sloc_Range (Orig, Start, Dummy); - - Atrue := Entity (C) = Standard_True; + Atrue := Test_Result; if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not @@ -3399,9 +3436,7 @@ package body Sem_Warn is end if; if Constant_Condition_Warnings - and then Nkind (C) = N_Identifier - and then - (Entity (C) = Standard_False or else Entity (C) = Standard_True) + and then Is_Known_Branch and then Comes_From_Source (Original_Node (C)) and then not In_Instance then @@ -3456,7 +3491,7 @@ package body Sem_Warn is if not Operand_Has_Warnings_Suppressed (C) then declare - True_Branch : Boolean := Entity (C) = Standard_True; + True_Branch : Boolean := Test_Result; Cond : Node_Id := C; begin