Skip to content

R
riscv-gcc-1
Commit 65df5b71 by Hristian Kirtchev Committed by Arnaud Charlet
Options

exp_ch9.ads, [...] (Build_Protected_Entry, [...]): Generate debug info for… 

exp_ch9.ads, [...] (Build_Protected_Entry, [...]): Generate debug info for declarations related to the handling of private data in...

2008-04-08  Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* exp_ch9.ads, exp_ch9.adb (Build_Protected_Entry,
	Build_Unprotected_Subprogram_Body): Generate debug info for
	declarations related to the handling of private data in task and
	protected types.
	(Debug_Private_Data_Declarations): New subprogram.
	(Install_Private_Data_Declarations): Remove all debug info flagging.
	This is now done by Debug_Private_Data_Declarations at the correct
	stage of expansion.
	(Build_Simple_Entry_Call): If the task name is a function call, expand
	the prefix into an object declaration, and make the surrounding block a
	task master.
	(Build_Master_Entity): An internal block is a master if it wraps a call.
	Code reformatting, update comments. Code clean up.
	(Make_Task_Create_Call): Use 'Unrestricted_Access instead of 'Address.
	(Replicate_Entry_Formals): If the formal is an access parameter or
	anonymous access to subprogram, copy the original tree to create new
	entities for the formals of the subprogram.
	(Expand_N_Task_Type_Declaration): Create a Relative_Deadline variable
	for tasks to store the value passed using pragma Relative_Deadline.
	(Make_Task_Create_Call): Add the Relative_Deadline argument to the
	run-time call to create a task.
	(Build_Wrapper_Spec): If the controlling argument of the interface
	operation is an access parameter with a non-null indicator, use the
	non-null indicator on the wrapper.

	* sem_ch9.adb (Analyze_Protected_Type): Only retrieve the full view when
	present, which it may not be in the case where the type entity is an
	incomplete view brought in by a limited with.
	(Analyze_Task_Type): Only retrieve the full view when present, which it
	may not be in the case where the type entity is an incomplete view
	brought in by a limited with.
	(Analyze_Protected_Definition): Set Is_Frozen on all itypes generated for
	private components of a protected type, to prevent the generation of
	freeze nodes for which there is no proper scope of elaboration.

	* exp_util.ads, exp_util.adb (Remove_Side_Effects): If the expression is
	a function call that returns a task, expand into a declaration to invoke
	the build_in_place machinery.
	(Find_Protection_Object): New routine.
	(Remove_Side_Effects): Also make a copy of the value
	for attributes whose result is of an elementary type.
	(Silly_Boolean_Array_Not_Test): New procedure
	(Silly_Boolean_Array_Xor_Test): New procedure
	(Is_Volatile_Reference): New function
	(Remove_Side_Effects): Use Is_Volatile_Reference
	(Possible_Bit_Aligned_Component): Handle slice case properly

	* exp_pakd.adb (Expand_Packed_Not): Move silly true/true or false/false
	case test to Exp_Util
	(Expand_Packed_Xor): Move silly true/true case test to Exp_Util

From-SVN: r134030
parent dcfa065d
Showing with 200 additions and 173 deletions
gcc/ada/exp_ch9.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/exp_pakd.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
......@@ -1092,7 +1092,7 @@ package body Exp_Pakd is
-- discriminants, so we treat it as a default/per-object expression.
Set_Parent (Len_Expr, Typ);
Analyze_Per_Use_Expression (Len_Expr, Standard_Long_Long_Integer);
Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer);
-- Use a modular type if possible. We can do this if we have
-- static bounds, and the length is small enough, and the length
......@@ -1774,47 +1774,11 @@ package body Exp_Pakd is
Ltyp := Etype (L);
Rtyp := Etype (R);
-- First an odd and silly test. We explicitly check for the XOR
-- case where the component type is True .. True, since this will
-- raise constraint error. A special check is required since CE
-- will not be required other wise (cf Expand_Packed_Not).
-- No such check is required for AND and OR, since for both these
-- cases False op False = False, and True op True = True.
-- Deeal with silly case of XOR where the subcomponent has a range
-- True .. True where an exception must be raised.
if Nkind (N) = N_Op_Xor then
declare
CT : constant Entity_Id := Component_Type (Rtyp);
BT : constant Entity_Id := Base_Type (CT);
begin
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_And (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Convert_To (BT,
New_Occurrence_Of (Standard_True, Loc))),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_Last),
Right_Opnd =>
Convert_To (BT,
New_Occurrence_Of (Standard_True, Loc)))),
Reason => CE_Range_Check_Failed));
end;
Silly_Boolean_Array_Xor_Test (N, Rtyp);
end if;
-- Now that that silliness is taken care of, get packed array type
......@@ -2186,37 +2150,11 @@ package body Exp_Pakd is
Convert_To_Actual_Subtype (Opnd);
Rtyp := Etype (Opnd);
-- First an odd and silly test. We explicitly check for the case
-- where the 'First of the component type is equal to the 'Last of
-- this component type, and if this is the case, we make sure that
-- constraint error is raised. The reason is that the NOT is bound
-- to cause CE in this case, and we will not otherwise catch it.
-- Deal with silly False..False and True..True subtype case
-- Believe it or not, this was reported as a bug. Note that nearly
-- always, the test will evaluate statically to False, so the code
-- will be statically removed, and no extra overhead caused.
Silly_Boolean_Array_Not_Test (N, Rtyp);
declare
CT : constant Entity_Id := Component_Type (Rtyp);
begin
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_Last)),
Reason => CE_Range_Check_Failed));
end;
-- Now that that silliness is taken care of, get packed array type
-- Now that the silliness is taken care of, get packed array type
Convert_To_PAT_Type (Opnd);
PAT := Etype (Opnd);
......
gcc/ada/exp_util.ads
......@@ -372,6 +372,13 @@ package Exp_Util is
-- operation which is not directly visible. If T is a class wide type,
-- then the reference is to an operation of the corresponding root type.
function Find_Protection_Object (Scop : Entity_Id) return Entity_Id;
-- Traverse the scope stack starting from Scop and look for an entry,
-- entry family, or a subprogram that has a Protection_Object and return
-- it. Raises Program_Error if no such entity is found since the context
-- in which this routine is invoked should always have a protection
-- object.
procedure Force_Evaluation
(Exp : Node_Id;
Name_Req : Boolean := False);
......@@ -491,6 +498,13 @@ package Exp_Util is
-- Returns true if type T is not tagged and is a derived type,
-- or is a private type whose completion is such a type.
function Is_Volatile_Reference (N : Node_Id) return Boolean;
-- Checks if the node N represents a volatile reference, which can be
-- either a direct reference to a variable treated as volatile, or an
-- indexed/selected component where the prefix is treated as volatile,
-- or has Volatile_Components set. A slice of a volatile variable is
-- also volatile.
procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False);
-- N represents a node for a section of code that is known to be dead. Any
-- exception handler references and warning messages relating to this code
......@@ -613,6 +627,18 @@ package Exp_Util is
-- renamed subprogram. The node is rewritten to be an identifier that
-- refers directly to the renamed subprogram, given by entity E.
procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id);
-- N is the node for a boolean array NOT operation, and T is the type of
-- the array. This routine deals with the silly case where the subtype of
-- the boolean array is False..False or True..True, where it is required
-- that a Constraint_Error exception be raised (RM 4.5.6(6)).
procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id);
-- N is the node for a boolean array XOR operation, and T is the type of
-- the array. This routine deals with the silly case where the subtype of
-- the boolean array is True..True, where a raise of a Constraint_Error
-- exception is required (RM 4.5.6(6)).
function Target_Has_Fixed_Ops
(Left_Typ : Entity_Id;
Right_Typ : Entity_Id;
......
gcc/ada/sem_ch9.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
......@@ -570,9 +570,9 @@ package body Sem_Ch9 is
-- expression is only evaluated if the guard is open.
if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
Pre_Analyze_And_Resolve (Expr, Standard_Duration);
Preanalyze_And_Resolve (Expr, Standard_Duration);
else
Pre_Analyze_And_Resolve (Expr);
Preanalyze_And_Resolve (Expr);
end if;
Typ := First_Subtype (Etype (Expr));
......@@ -646,8 +646,8 @@ package body Sem_Ch9 is
Stats : constant Node_Id := Handled_Statement_Sequence (N);
Formals : constant Node_Id := Entry_Body_Formal_Part (N);
P_Type : constant Entity_Id := Current_Scope;
Entry_Name : Entity_Id;
E : Entity_Id;
Entry_Name : Entity_Id;
begin
Tasking_Used := True;
......@@ -765,7 +765,6 @@ package body Sem_Ch9 is
Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
Push_Scope (Entry_Name);
Exp_Ch9.Expand_Entry_Body_Declarations (N);
Install_Declarations (Entry_Name);
Set_Actual_Subtypes (N, Current_Scope);
......@@ -783,6 +782,17 @@ package body Sem_Ch9 is
Set_Entry_Parameters_Type
(Id, Entry_Parameters_Type (Entry_Name));
-- Add a declaration for the Protection object, renaming declarations
-- for the discriminals and privals and finally a declaration for the
-- entry family index (if applicable).
if Expander_Active
and then Is_Protected_Type (P_Type)
then
Install_Private_Data_Declarations
(Sloc (N), Entry_Name, P_Type, N, Decls);
end if;
if Present (Decls) then
Analyze_Declarations (Decls);
end if;
......@@ -926,40 +936,40 @@ package body Sem_Ch9 is
-------------------------------
procedure Analyze_Entry_Declaration (N : Node_Id) is
Formals : constant List_Id := Parameter_Specifications (N);
Id : constant Entity_Id := Defining_Identifier (N);
D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
Formals : constant List_Id := Parameter_Specifications (N);
begin
Generate_Definition (Id);
Generate_Definition (Def_Id);
Tasking_Used := True;
if No (D_Sdef) then
Set_Ekind (Id, E_Entry);
Set_Ekind (Def_Id, E_Entry);
else
Enter_Name (Id);
Set_Ekind (Id, E_Entry_Family);
Enter_Name (Def_Id);
Set_Ekind (Def_Id, E_Entry_Family);
Analyze (D_Sdef);
Make_Index (D_Sdef, N, Id);
Make_Index (D_Sdef, N, Def_Id);
end if;
Set_Etype (Id, Standard_Void_Type);
Set_Convention (Id, Convention_Entry);
Set_Accept_Address (Id, New_Elmt_List);
Set_Etype (Def_Id, Standard_Void_Type);
Set_Convention (Def_Id, Convention_Entry);
Set_Accept_Address (Def_Id, New_Elmt_List);
if Present (Formals) then
Set_Scope (Id, Current_Scope);
Push_Scope (Id);
Set_Scope (Def_Id, Current_Scope);
Push_Scope (Def_Id);
Process_Formals (Formals, N);
Create_Extra_Formals (Id);
Create_Extra_Formals (Def_Id);
End_Scope;
end if;
if Ekind (Id) = E_Entry then
New_Overloaded_Entity (Id);
if Ekind (Def_Id) = E_Entry then
New_Overloaded_Entity (Def_Id);
end if;
Generate_Reference_To_Formals (Id);
Generate_Reference_To_Formals (Def_Id);
end Analyze_Entry_Declaration;
---------------------------------------
......@@ -1061,7 +1071,7 @@ package body Sem_Ch9 is
Set_Has_Completion (Spec_Id);
Install_Declarations (Spec_Id);
Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
Expand_Protected_Body_Declarations (N, Spec_Id);
Last_E := Last_Entity (Spec_Id);
......@@ -1093,6 +1103,55 @@ package body Sem_Ch9 is
E : Entity_Id;
L : Entity_Id;
procedure Undelay_Itypes (T : Entity_Id);
-- Itypes created for the private components of a protected type
-- do not receive freeze nodes, because there is no scope in which
-- they can be elaborated, and they can depend on discriminants of
-- the enclosed protected type. Given that the components can be
-- composite types with inner components, we traverse recursively
-- the private components of the protected type, and indicate that
-- all itypes within are frozen. This ensures that no freeze nodes
-- will be generated for them.
--
-- On the other hand, components of the correesponding record are
-- frozen (or receive itype references) as for other records.
--------------------
-- Undelay_Itypes --
--------------------
procedure Undelay_Itypes (T : Entity_Id) is
Comp : Entity_Id;
begin
if Is_Protected_Type (T) then
Comp := First_Private_Entity (T);
elsif Is_Record_Type (T) then
Comp := First_Entity (T);
else
return;
end if;
while Present (Comp) loop
if Is_Type (Comp)
and then Is_Itype (Comp)
then
Set_Has_Delayed_Freeze (Comp, False);
Set_Is_Frozen (Comp);
if Is_Record_Type (Comp)
or else Is_Protected_Type (Comp)
then
Undelay_Itypes (Comp);
end if;
end if;
Next_Entity (Comp);
end loop;
end Undelay_Itypes;
-- Start of processing for Analyze_Protected_Definition
begin
Tasking_Used := True;
Analyze_Declarations (Visible_Declarations (N));
......@@ -1127,6 +1186,8 @@ package body Sem_Ch9 is
Next_Entity (E);
end loop;
Undelay_Itypes (Current_Scope);
Check_Max_Entries (N, Max_Protected_Entries);
Process_End_Label (N, 'e', Current_Scope);
end Analyze_Protected_Definition;
......@@ -1151,7 +1212,10 @@ package body Sem_Ch9 is
T := Find_Type_Name (N);
if Ekind (T) = E_Incomplete_Type then
-- In the case of an incomplete type, use the full view, unless it's not
-- present (as can occur for an incomplete view from a limited with).
if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
T := Full_View (T);
Set_Completion_Referenced (T);
end if;
......@@ -1776,6 +1840,7 @@ package body Sem_Ch9 is
procedure Analyze_Task_Body (N : Node_Id) is
Body_Id : constant Entity_Id := Defining_Identifier (N);
Decls : constant List_Id := Declarations (N);
HSS : constant Node_Id := Handled_Statement_Sequence (N);
Last_E : Entity_Id;
......@@ -1842,7 +1907,7 @@ package body Sem_Ch9 is
Install_Declarations (Spec_Id);
Last_E := Last_Entity (Spec_Id);
Analyze_Declarations (Declarations (N));
Analyze_Declarations (Decls);
-- For visibility purposes, all entities in the body are private. Set
-- First_Private_Entity accordingly, if there was no private part in the
......@@ -1946,7 +2011,10 @@ package body Sem_Ch9 is
T := Find_Type_Name (N);
Generate_Definition (T);
if Ekind (T) = E_Incomplete_Type then
-- In the case of an incomplete type, use the full view, unless it's not
-- present (as can occur for an incomplete view from a limited with).
if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
T := Full_View (T);
Set_Completion_Referenced (T);
end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment