Commit 1e4b91fc by Arnaud Charlet

[multiple changes]

2012-07-12  Thomas Quinot  <quinot@adacore.com>

	* s-bytswa.adb (Swapped2.Bswap16): Remove local function,
	no longer needed.

2012-07-12  Javier Miranda  <miranda@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): For
	attributes 'access, 'unchecked_access and 'unrestricted_access,
	iff the current instance reference is located in a protected
	subprogram or entry then rewrite the access attribute to be the
	name of the "_object" parameter.

2012-07-12  Tristan Gingold  <gingold@adacore.com>

	* raise.h: Revert previous patch: structure is used in init.c
	by vms.

2012-07-12  Vincent Celier  <celier@adacore.com>

	* make.adb (Binding_Phase): If --subdirs was used, but not
	-P, change the working directory to the specified subdirectory
	before invoking gnatbind.
	(Linking_Phase): If --subdirs was used, but not -P, change the working
	directory to the specified subdirectory before invoking gnatlink.

2012-07-12  Vincent Pucci  <pucci@adacore.com>

	* exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body):
	For a procedure, instead of replacing each Comp reference by a
	reference to Current_Comp, make a renaming Comp of Current_Comp
	that rewrites the original renaming generated by the compiler
	during the analysis. Move the declarations of the procedure
	inside the generated block.
	(Process_Stmts): Moved in the body
	of Build_Lock_Free_Unprotected_Subprogram_Body.
	(Process_Node):
	Moved in the body of Build_Lock_Free_Unprotected_Subprogram_Body.
	* sem_ch9.adb (Allows_Lock_Free_Implementation): Restrict any
	non-elementary out parameters in protected procedures.

2012-07-12  Thomas Quinot  <quinot@adacore.com>

	* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case
	Scalar_Storage_Order): Attribute applies to base type only.

From-SVN: r189435
parent d9819bbd
2012-07-12 Thomas Quinot <quinot@adacore.com>
* s-bytswa.adb (Swapped2.Bswap16): Remove local function,
no longer needed.
2012-07-12 Javier Miranda <miranda@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): For
attributes 'access, 'unchecked_access and 'unrestricted_access,
iff the current instance reference is located in a protected
subprogram or entry then rewrite the access attribute to be the
name of the "_object" parameter.
2012-07-12 Tristan Gingold <gingold@adacore.com>
* raise.h: Revert previous patch: structure is used in init.c
by vms.
2012-07-12 Vincent Celier <celier@adacore.com>
* make.adb (Binding_Phase): If --subdirs was used, but not
-P, change the working directory to the specified subdirectory
before invoking gnatbind.
(Linking_Phase): If --subdirs was used, but not -P, change the working
directory to the specified subdirectory before invoking gnatlink.
2012-07-12 Vincent Pucci <pucci@adacore.com>
* exp_ch9.adb (Build_Lock_Free_Unprotected_Subprogram_Body):
For a procedure, instead of replacing each Comp reference by a
reference to Current_Comp, make a renaming Comp of Current_Comp
that rewrites the original renaming generated by the compiler
during the analysis. Move the declarations of the procedure
inside the generated block.
(Process_Stmts): Moved in the body
of Build_Lock_Free_Unprotected_Subprogram_Body.
(Process_Node):
Moved in the body of Build_Lock_Free_Unprotected_Subprogram_Body.
* sem_ch9.adb (Allows_Lock_Free_Implementation): Restrict any
non-elementary out parameters in protected procedures.
2012-07-12 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case
Scalar_Storage_Order): Attribute applies to base type only.
2012-07-12 Ed Schonberg <schonberg@adacore.com>
* exp_aggr.adb (Convert_To_Positional): Increase acceptable size
......
......@@ -815,11 +815,19 @@ package body Exp_Attr is
-- rewrite into reference to current instance.
if Is_Protected_Self_Reference (Pref)
and then not
and then not
(Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
N_Discriminant_Association)
and then Nkind (Parent (Parent (Parent (Parent (N))))) =
N_Component_Definition)
-- No action needed for these attributes since the current instance
-- will be rewritten to be the name of the _object parameter
-- associated with the enclosing protected subprogram (see below).
and then Id /= Attribute_Access
and then Id /= Attribute_Unchecked_Access
and then Id /= Attribute_Unrestricted_Access
then
Rewrite (Pref, Concurrent_Ref (Pref));
Analyze (Pref);
......@@ -1028,10 +1036,36 @@ package body Exp_Attr is
New_Occurrence_Of (Formal, Loc)));
Set_Etype (N, Typ);
-- The expression must appear in a default expression,
-- (which in the initialization procedure is the
-- right-hand side of an assignment), and not in a
-- discriminant constraint.
elsif Is_Protected_Type (Entity (Pref)) then
-- No action needed for current instance located in a
-- component definition (expansion will occur in the
-- init proc)
if Is_Protected_Type (Current_Scope) then
null;
-- If the current instance reference is located in a
-- protected subprogram or entry then rewrite the access
-- attribute to be the name of the "_object" parameter.
-- An unchecked conversion is applied to ensure a type
-- match in cases of expander-generated calls (e.g. init
-- procs).
else
Formal :=
First_Entity
(Protected_Body_Subprogram (Current_Scope));
Rewrite (N,
Unchecked_Convert_To (Typ,
New_Occurrence_Of (Formal, Loc)));
Set_Etype (N, Typ);
end if;
-- The expression must appear in a default expression,
-- (which in the initialization procedure is the right-hand
-- side of an assignment), and not in a discriminant
-- constraint.
else
Par := Parent (N);
......
......@@ -2955,26 +2955,30 @@ package body Exp_Ch9 is
-- manner:
-- procedure P (...) is
-- <original declarations>
-- begin
-- loop
-- declare
-- <original declarations before the object renaming declaration
-- of Comp>
-- Saved_Comp : constant ... :=
-- Atomic_Load (Comp'Address, Relaxed);
-- Atomic_Load (_Object.Comp'Address, Relaxed);
-- Current_Comp : ... := Saved_Comp;
-- Comp : Comp_Type renames Current_Comp;
-- <original delarations after the object renaming declaration
-- of Comp>
-- begin
-- <original statements>
-- exit when Atomic_Compare (Comp, Saved_Comp, Current_Comp);
-- exit when Atomic_Compare
-- (_Object.Comp, Saved_Comp, Current_Comp);
-- end;
-- <<L0>>
-- end loop;
-- end P;
-- References to Comp which appear in the original statements are replaced
-- with references to Current_Comp. Each return and raise statement of P is
-- transformed into an atomic status check:
-- Each return and raise statement of P is transformed into an atomic
-- status check:
-- if Atomic_Compare (Comp, Saved_Comp, Current_Comp) then
-- if Atomic_Compare (_Object.Comp, Saved_Comp, Current_Comp) then
-- <original statement>
-- else
-- goto L0;
......@@ -2985,15 +2989,16 @@ package body Exp_Ch9 is
-- manner:
-- function F (...) return ... is
-- <original declarations>
-- Saved_Comp : constant ... := Atomic_Load (Comp'Address);
-- <original declarations before the object renaming declaration
-- of Comp>
-- Saved_Comp : constant ... := Atomic_Load (_Object.Comp'Address);
-- Comp : Comp_Type renames Saved_Comp;
-- <original delarations after the object renaming declaration of
-- Comp>
-- begin
-- <original statements>
-- end F;
-- References to Comp which appear in the original statements are replaced
-- with references to Saved_Comp.
function Build_Lock_Free_Unprotected_Subprogram_Body
(N : Node_Id;
Prot_Typ : Node_Id) return Node_Id
......@@ -3003,162 +3008,11 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (N);
Label_Id : Entity_Id := Empty;
procedure Process_Stmts
(Stmts : List_Id;
Compare : Entity_Id;
Unsigned : Entity_Id;
Comp : Entity_Id;
Saved_Comp : Entity_Id;
Current_Comp : Entity_Id);
-- Given a statement sequence Stmts, wrap any return or raise statements
-- in the following manner:
--
-- if System.Atomic_Primitives.Atomic_Compare_Exchange
-- (Comp'Address,
-- Interfaces.Unsigned (Saved_Comp),
-- Interfaces.Unsigned (Current_Comp))
-- then
-- <Stmt>;
-- else
-- goto L0;
-- end if;
--
-- Replace all references to Comp with a reference to Current_Comp.
function Referenced_Component (N : Node_Id) return Entity_Id;
-- Subprograms which meet the lock-free implementation criteria are
-- allowed to reference only one unique component. Return the prival
-- of the said component.
-------------------
-- Process_Stmts --
-------------------
procedure Process_Stmts
(Stmts : List_Id;
Compare : Entity_Id;
Unsigned : Entity_Id;
Comp : Entity_Id;
Saved_Comp : Entity_Id;
Current_Comp : Entity_Id)
is
function Process_Node (N : Node_Id) return Traverse_Result;
-- Transform a single node if it is a return statement, a raise
-- statement or a reference to Comp.
------------------
-- Process_Node --
------------------
function Process_Node (N : Node_Id) return Traverse_Result is
procedure Wrap_Statement (Stmt : Node_Id);
-- Wrap an arbitrary statement inside an if statement where the
-- condition does an atomic check on the state of the object.
--------------------
-- Wrap_Statement --
--------------------
procedure Wrap_Statement (Stmt : Node_Id) is
begin
-- The first time through, create the declaration of a label
-- which is used to skip the remainder of source statements if
-- the state of the object has changed.
if No (Label_Id) then
Label_Id :=
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id)));
end if;
-- Generate:
-- if System.Atomic_Primitives.Atomic_Compare_Exchange
-- (Comp'Address,
-- Interfaces.Unsigned (Saved_Comp),
-- Interfaces.Unsigned (Current_Comp))
-- then
-- <Stmt>;
-- else
-- goto L0;
-- end if;
Rewrite (Stmt,
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (Compare, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Comp, Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned,
New_Reference_To (Saved_Comp, Loc)),
Unchecked_Convert_To (Unsigned,
New_Reference_To (Current_Comp, Loc)))),
Then_Statements => New_List (Relocate_Node (Stmt)),
Else_Statements => New_List (
Make_Goto_Statement (Loc,
Name => New_Reference_To (Entity (Label_Id), Loc)))));
end Wrap_Statement;
-- Start of processing for Process_Node
begin
-- Wrap each return and raise statement that appear inside a
-- procedure. Skip the last return statement which is added by
-- default since it is transformed into an exit statement.
if Is_Procedure
and then Nkind_In (N, N_Simple_Return_Statement,
N_Extended_Return_Statement,
N_Raise_Statement)
and then Nkind (Last (Stmts)) /= N_Simple_Return_Statement
then
Wrap_Statement (N);
return Skip;
-- Replace all references to the original component by a reference
-- to the current state of the component.
elsif Nkind (N) = N_Identifier
and then Present (Entity (N))
and then Entity (N) = Comp
then
Rewrite (N, Make_Identifier (Loc, Chars (Current_Comp)));
return Skip;
end if;
-- Force reanalysis
Set_Analyzed (N, False);
return OK;
end Process_Node;
procedure Process_Nodes is new Traverse_Proc (Process_Node);
-- Local variables
Stmt : Node_Id;
-- Start of processing for Process_Stmts
begin
Stmt := First (Stmts);
while Present (Stmt) loop
Process_Nodes (Stmt);
Next (Stmt);
end loop;
end Process_Stmts;
--------------------------
-- Referenced_Component --
--------------------------
......@@ -3214,20 +3068,25 @@ package body Exp_Ch9 is
-- Local variables
Comp : constant Entity_Id := Referenced_Component (N);
Decls : constant List_Id := Declarations (N);
Stmts : List_Id;
Comp : constant Entity_Id := Referenced_Component (N);
Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N);
Decls : List_Id := Declarations (N);
-- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
begin
Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N)));
-- Add renamings for the protection object, discriminals, privals and
-- the entry index constant for use by debugger.
Debug_Private_Data_Declarations (Decls);
-- Perform the lock-free expansion when the subprogram references a
-- protected component.
if Present (Comp) then
declare
Comp_Decl : constant Node_Id := Parent (Comp);
Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl);
Comp_Type : constant Entity_Id := Etype (Comp);
Block_Decls : List_Id;
Compare : Entity_Id;
......@@ -3238,9 +3097,138 @@ package body Exp_Ch9 is
Load_Params : List_Id;
Saved_Comp : Entity_Id;
Stmt : Node_Id;
Stmts : List_Id :=
New_Copy_List (Statements (Hand_Stmt_Seq));
Typ_Size : Int;
Unsigned : Entity_Id;
function Process_Node (N : Node_Id) return Traverse_Result;
-- Transform a single node if it is a return statement, a raise
-- statement or a reference to Comp.
procedure Process_Stmts (Stmts : List_Id);
-- Given a statement sequence Stmts, wrap any return or raise
-- statements in the following manner:
--
-- if System.Atomic_Primitives.Atomic_Compare_Exchange
-- (Comp'Address,
-- Interfaces.Unsigned (Saved_Comp),
-- Interfaces.Unsigned (Current_Comp))
-- then
-- <Stmt>;
-- else
-- goto L0;
-- end if;
------------------
-- Process_Node --
------------------
function Process_Node (N : Node_Id) return Traverse_Result is
procedure Wrap_Statement (Stmt : Node_Id);
-- Wrap an arbitrary statement inside an if statement where the
-- condition does an atomic check on the state of the object.
--------------------
-- Wrap_Statement --
--------------------
procedure Wrap_Statement (Stmt : Node_Id) is
begin
-- The first time through, create the declaration of a label
-- which is used to skip the remainder of source statements
-- if the state of the object has changed.
if No (Label_Id) then
Label_Id :=
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id)));
end if;
-- Generate:
-- if System.Atomic_Primitives.Atomic_Compare_Exchange
-- (Comp'Address,
-- Interfaces.Unsigned (Saved_Comp),
-- Interfaces.Unsigned (Current_Comp))
-- then
-- <Stmt>;
-- else
-- goto L0;
-- end if;
Rewrite (Stmt,
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (Compare, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Comp_Sel_Nam),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned,
New_Reference_To (Saved_Comp, Loc)),
Unchecked_Convert_To (Unsigned,
New_Reference_To (Current_Comp, Loc)))),
Then_Statements => New_List (Relocate_Node (Stmt)),
Else_Statements => New_List (
Make_Goto_Statement (Loc,
Name =>
New_Reference_To (Entity (Label_Id), Loc)))));
end Wrap_Statement;
-- Start of processing for Process_Node
begin
-- Wrap each return and raise statement that appear inside a
-- procedure. Skip the last return statement which is added by
-- default since it is transformed into an exit statement.
if Is_Procedure
and then ((Nkind (N) = N_Simple_Return_Statement
and then N /= Last (Stmts))
or else Nkind (N) = N_Extended_Return_Statement
or else (Nkind_In (N, N_Raise_Constraint_Error,
N_Raise_Program_Error,
N_Raise_Statement,
N_Raise_Storage_Error)
and then Comes_From_Source (N)))
then
Wrap_Statement (N);
return Skip;
end if;
-- Force reanalysis
Set_Analyzed (N, False);
return OK;
end Process_Node;
procedure Process_Nodes is new Traverse_Proc (Process_Node);
-------------------
-- Process_Stmts --
-------------------
procedure Process_Stmts (Stmts : List_Id) is
Stmt : Node_Id;
begin
Stmt := First (Stmts);
while Present (Stmt) loop
Process_Nodes (Stmt);
Next (Stmt);
end loop;
end Process_Stmts;
begin
-- Get the type size
......@@ -3305,7 +3293,7 @@ package body Exp_Ch9 is
Load_Params := New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Comp, Loc),
Prefix => Relocate_Node (Comp_Sel_Nam),
Attribute_Name => Name_Address));
-- For protected procedures, set the memory model to be relaxed
......@@ -3329,7 +3317,14 @@ package body Exp_Ch9 is
-- Protected procedures
if Is_Procedure then
Block_Decls := New_List (Decl);
-- Move the original declarations inside the generated block
Block_Decls := Decls;
-- Reset the declarations list of the protected procedure to be
-- an empty list.
Decls := Empty_List;
-- Generate:
-- Current_Comp : Comp_Type := Saved_Comp;
......@@ -3338,21 +3333,50 @@ package body Exp_Ch9 is
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Comp), Suffix => "_current"));
Append_To (Block_Decls,
-- Insert the declarations of Saved_Comp and Current_Comp in
-- the block declarations right before the renaming of the
-- protected component.
Insert_Before (Comp_Decl, Decl);
Insert_Before (Comp_Decl,
Make_Object_Declaration (Loc,
Defining_Identifier => Current_Comp,
Object_Definition => New_Reference_To (Comp_Type, Loc),
Expression => New_Reference_To (Saved_Comp, Loc)));
Expression =>
New_Reference_To (Saved_Comp, Loc)));
-- Protected function
else
Append_To (Decls, Decl);
Current_Comp := Saved_Comp;
-- Insert the declaration of Saved_Comp in the function
-- declarations right before the renaming of the protected
-- component.
Insert_Before (Comp_Decl, Decl);
end if;
Process_Stmts
(Stmts, Compare, Unsigned, Comp, Saved_Comp, Current_Comp);
-- Rewrite the protected component renaming declaration to be a
-- renaming of Current_Comp.
-- Generate:
-- Comp : Comp_Type renames Current_Comp;
Rewrite (Comp_Decl,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier =>
Defining_Identifier (Comp_Decl),
Subtype_Mark =>
New_Occurrence_Of (Comp_Type, Loc),
Name =>
New_Reference_To (Current_Comp, Loc)));
-- Wrap any return or raise statements in Stmts in same the manner
-- described in Process_Stmts.
Process_Stmts (Stmts);
-- Generate:
......@@ -3370,7 +3394,7 @@ package body Exp_Ch9 is
New_Reference_To (Compare, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Comp, Loc),
Prefix => Relocate_Node (Comp_Sel_Nam),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned,
......@@ -3413,7 +3437,7 @@ package body Exp_Ch9 is
if Is_Procedure then
Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)),
Make_Loop_Statement (Loc,
......@@ -3425,14 +3449,12 @@ package body Exp_Ch9 is
Statements => Stmts))),
End_Label => Empty));
end if;
Hand_Stmt_Seq :=
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts);
end;
end if;
-- Add renamings for the protection object, discriminals, privals and
-- the entry index constant for use by debugger.
Debug_Private_Data_Declarations (Decls);
-- Make an unprotected version of the subprogram for use within the same
-- object, with new name and extra parameter representing the object.
......@@ -3441,8 +3463,7 @@ package body Exp_Ch9 is
Specification =>
Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
Handled_Statement_Sequence => Hand_Stmt_Seq);
end Build_Lock_Free_Unprotected_Subprogram_Body;
-------------------------
......
......@@ -4435,6 +4435,13 @@ package body Make is
declare
Success : Boolean := False;
begin
-- If gnatmake was invoked with --subdirs and no project file,
-- put the executable in the subdirectory specified.
if Prj.Subdirs /= null and then Main_Project = No_Project then
Change_Dir (Object_Directory_Path.all);
end if;
Link (Main_ALI_File,
Link_With_Shared_Libgcc.all &
Args (Args'First .. Last_Arg),
......@@ -4571,6 +4578,13 @@ package body Make is
end if;
end if;
-- If gnatmake was invoked with --subdirs and no project file, put the
-- binder generated files in the subdirectory specified.
if Main_Project = No_Project and then Prj.Subdirs /= null then
Change_Dir (Object_Directory_Path.all);
end if;
begin
Bind (Main_ALI_File,
Bind_Shared.all & Args (Args'First .. Last_Arg));
......
......@@ -37,7 +37,16 @@ extern "C" {
typedef unsigned Exception_Code;
struct Exception_Data;
struct Exception_Data
{
char Not_Handled_By_Others;
char Lang;
int Name_Length;
char *Full_Name, *Htable_Ptr;
Exception_Code Import_Code;
void (*Raise_Hook)(void);
};
typedef struct Exception_Data *Exception_Id;
extern void _gnat_builtin_longjmp (void *, int);
......
......@@ -56,9 +56,6 @@ package body System.Byte_Swapping is
function Swapped2 (Input : Item) return Item is
function As_U16 is new Unchecked_Conversion (Item, U16);
function As_Item is new Unchecked_Conversion (U16, Item);
function Bswap_16 (X : U16) return U16 is (X / 256 or X * 256);
-- ??? Need to have function local here to allow inlining
pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 2,
"storage size must be 2 bytes");
begin
......
......@@ -3332,7 +3332,7 @@ package body Sem_Ch13 is
else
if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
Set_Reverse_Storage_Order (U_Ent, True);
Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
end if;
end if;
end if;
......
......@@ -170,24 +170,30 @@ package body Sem_Ch9 is
Par_Specs : constant List_Id :=
Parameter_Specifications
(Specification (Decl));
Par : constant Node_Id := First (Par_Specs);
Par_Typ : constant Entity_Id :=
Etype (Parameter_Type (Par));
Par : Node_Id;
begin
if Out_Present (Par)
and then not Is_Elementary_Type (Par_Typ)
then
if Complain then
Error_Msg_NE
("non-elementary out parameter& not allowed " &
"when Lock_Free given",
Par,
Defining_Identifier (Par));
Par := First (Par_Specs);
while Present (Par) loop
if Out_Present (Par)
and then not Is_Elementary_Type
(Etype (Parameter_Type (Par)))
then
if Complain then
Error_Msg_NE
("non-elementary out parameter& not allowed " &
"when Lock_Free given",
Par,
Defining_Identifier (Par));
end if;
return False;
end if;
return False;
end if;
Next (Par);
end loop;
end;
end if;
......@@ -451,9 +457,9 @@ package body Sem_Ch9 is
-- already been accessed by the subprogram body.
if No (Comp) then
Comp := Id;
Comp := Comp_Id;
elsif Comp /= Id then
elsif Comp /= Comp_Id then
if Complain then
Error_Msg_N
("only one protected component allowed",
......
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