OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2009-07-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_warn.adb (Warn_On_Constant_Condition): Handle properly constant
	conditions of a derived boolean type.
	Minor reformatting

2009-07-15  Robert Dewar  <dewar@adacore.com>

	* 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  <charlet@adacore.com>

	* debug.adb: Add -gnatd.J switch for now to support scil generation in
	parallel. Add missing doc for -gnatd.I and -gnatd.O

From-SVN: r149679
This commit is contained in:
Arnaud Charlet 2009-07-15 12:39:11 +02:00
parent 671eb58697
commit 892125cdb1
9 changed files with 304 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/ada/ChangeLog
View File

@ -1,3 +1,36 @@
2009-07-15 Ed Schonberg <schonberg@adacore.com>
* sem_warn.adb (Warn_On_Constant_Condition): Handle properly constant
conditions of a derived boolean type.
Minor reformatting
2009-07-15 Robert Dewar <dewar@adacore.com>
* 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 <charlet@adacore.com>
* 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 <dewar@adacore.com>
* lib-load.adb: Minor reformatting

18
gcc/ada/debug.adb
View File

@ -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

5
gcc/ada/gnat1drv.adb
View File

@ -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;

5
gcc/ada/par-load.adb
View File

@ -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

15
gcc/ada/par.adb
View File

@ -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

246
gcc/ada/par_sco.adb
View File

@ -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 --
-----------------------------------------

2
gcc/ada/par_sco.ads
View File

@ -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);

14
gcc/ada/sem_ch10.adb
View File

@ -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

53
gcc/ada/sem_warn.adb
View File

@ -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