Skip to content

R
riscv-gcc-1
Commit 36504e5f by Arnaud Charlet
Options

[multiple changes] 

2012-04-02  Yannick Moy  <moy@adacore.com>

	* osint.adb, osint.ads (Add_Default_Search_Dirs): Add library
	search dirs in file specified with option -gnateO.

2012-04-02  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor
	reformatting.

2012-04-02  Olivier Hainque  <hainque@adacore.com>

	* g-sse.ads: Add x86-solaris and x86_64-darwin to the set of
	platforms where the use of this spec is supported. Add current
	year to the copyright notice.
	* gcc-interfaces/Makefile.in: Add g-sse.o and g-ssvety.o to
	EXTRA_GNATRTL_NONTASKING_OBJS on x86 32/64 targets that support
	it and where they were missing (x86-solaris, x86-freebsd,
	x86_64-freebsd, and x86-darwin).

2012-04-02  Gary Dismukes  <dismukes@adacore.com>

	* bindgen.adb (Gen_Ada_Init): When compiling for the AAMP small
	library, where we no longer suppress the Standard_Library,
	generate an empty body rather than the usual generation of
	assignments to imported globals, since those aren't present in
	the small library.

2012-04-02  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads: Minor documentation fix.

2012-04-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_res.adb (Resolve_Conditional_Expression): Add local variables
	Else_Typ and Then_Typ. Add missing type conversions to the "then" and
	"else" expressions when their respective types are scalar.

2012-04-02  Vincent Pucci  <pucci@adacore.com>

	* exp_ch9.adb: Reordering of the local subprograms. New Table
	for the lock free implementation that maps each protected
	subprograms with the protected component it references.
	(Allow_Lock_Free_Implementation): New routine. Check if
	the protected body enables the lock free implementation.
	(Build_Lock_Free_Protected_Subprogram_Body): New routine.
	(Build_Lock_Free_Unprotected_Subprogram_Body): New routine.
	(Comp_Of): New routine.
	* Makefile.rtl: Add s-atopri.o
	* debug.adb: New compiler debug flag -gnatd9 for lock free
	implementation.
	* rtsfind.ads: RE_Atomic_Compare_Exchange_8,
	RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32,
	RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8,
	RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, RE_Uint8,
	RE_Uint16, RE_Uint32, RE_Uint64 added.
	* s-atropi.ads: New file. Defines atomic primitives used
	by the lock free implementation.

From-SVN: r186076
parent 804670f1
Showing with 1456 additions and 334 deletions
gcc/ada/ChangeLog
2012-04-02 Yannick Moy <moy@adacore.com>
* osint.adb, osint.ads (Add_Default_Search_Dirs): Add library
search dirs in file specified with option -gnateO.
2012-04-02 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor
reformatting.
2012-04-02 Olivier Hainque <hainque@adacore.com>
* g-sse.ads: Add x86-solaris and x86_64-darwin to the set of
platforms where the use of this spec is supported. Add current
year to the copyright notice.
* gcc-interfaces/Makefile.in: Add g-sse.o and g-ssvety.o to
EXTRA_GNATRTL_NONTASKING_OBJS on x86 32/64 targets that support
it and where they were missing (x86-solaris, x86-freebsd,
x86_64-freebsd, and x86-darwin).
2012-04-02 Gary Dismukes <dismukes@adacore.com>
* bindgen.adb (Gen_Ada_Init): When compiling for the AAMP small
library, where we no longer suppress the Standard_Library,
generate an empty body rather than the usual generation of
assignments to imported globals, since those aren't present in
the small library.
2012-04-02 Ed Schonberg <schonberg@adacore.com>
* sinfo.ads: Minor documentation fix.
2012-04-02 Hristian Kirtchev <kirtchev@adacore.com>
* sem_res.adb (Resolve_Conditional_Expression): Add local variables
Else_Typ and Then_Typ. Add missing type conversions to the "then" and
"else" expressions when their respective types are scalar.
2012-04-02 Vincent Pucci <pucci@adacore.com>
* exp_ch9.adb: Reordering of the local subprograms. New Table
for the lock free implementation that maps each protected
subprograms with the protected component it references.
(Allow_Lock_Free_Implementation): New routine. Check if
the protected body enables the lock free implementation.
(Build_Lock_Free_Protected_Subprogram_Body): New routine.
(Build_Lock_Free_Unprotected_Subprogram_Body): New routine.
(Comp_Of): New routine.
* Makefile.rtl: Add s-atopri.o
* debug.adb: New compiler debug flag -gnatd9 for lock free
implementation.
* rtsfind.ads: RE_Atomic_Compare_Exchange_8,
RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32,
RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8,
RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, RE_Uint8,
RE_Uint16, RE_Uint32, RE_Uint64 added.
* s-atropi.ads: New file. Defines atomic primitives used
by the lock free implementation.
2012-04-02 Emmanuel Briot <briot@adacore.com> 2012-04-02 Emmanuel Briot <briot@adacore.com>
* g-expect.adb (Expect_Internal): Fix leak of the input file descriptor. * g-expect.adb (Expect_Internal): Fix leak of the input file descriptor.
......
gcc/ada/Makefile.rtl
...@@ -479,6 +479,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -479,6 +479,7 @@ GNATRTL_NONTASKING_OBJS= \
s-assert$(objext) \ s-assert$(objext) \
s-atacco$(objext) \ s-atacco$(objext) \
s-atocou$(objext) \ s-atocou$(objext) \
s-atopri$(objext) \
s-auxdec$(objext) \ s-auxdec$(objext) \
s-bitops$(objext) \ s-bitops$(objext) \
s-boarop$(objext) \ s-boarop$(objext) \
......
gcc/ada/bindgen.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -511,6 +511,14 @@ package body Bindgen is ...@@ -511,6 +511,14 @@ package body Bindgen is
if CodePeer_Mode then if CodePeer_Mode then
WBI (" begin"); WBI (" begin");
-- When compiling for the AAMP small library, where the standard library
-- is no longer suppressed, we still want to exclude the setting of the
-- various imported globals, which aren't present for that library.
elsif AAMP_On_Target and then Configurable_Run_Time_On_Target then
WBI (" begin");
WBI (" null;");
-- If the standard library is suppressed, then the only global variables -- If the standard library is suppressed, then the only global variables
-- that might be needed (by the Ravenscar profile) are the priority and -- that might be needed (by the Ravenscar profile) are the priority and
-- the processor for the environment task. -- the processor for the environment task.
......
gcc/ada/debug.adb
...@@ -153,7 +153,7 @@ package body Debug is ...@@ -153,7 +153,7 @@ package body Debug is
-- d6 Default access unconstrained to thin pointers -- d6 Default access unconstrained to thin pointers
-- d7 Do not output version & file time stamp in -gnatv or -gnatl mode -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode
-- d8 Force opposite endianness in packed stuff -- d8 Force opposite endianness in packed stuff
-- d9 -- d9 Allow lock free implementation
-- Debug flags for binder (GNATBIND) -- Debug flags for binder (GNATBIND)
...@@ -710,6 +710,9 @@ package body Debug is ...@@ -710,6 +710,9 @@ package body Debug is
-- opposite endianness from the actual correct value. Useful in -- opposite endianness from the actual correct value. Useful in
-- testing out code generation from the packed routines. -- testing out code generation from the packed routines.
-- d9 This allows lock free implementation for protected objects
-- (see Exp_Ch9).
------------------------------------------ ------------------------------------------
-- Documentation for Binder Debug Flags -- -- Documentation for Binder Debug Flags --
------------------------------------------ ------------------------------------------
......
gcc/ada/exp_ch4.adb
...@@ -7832,9 +7832,7 @@ package body Exp_Ch4 is ...@@ -7832,9 +7832,7 @@ package body Exp_Ch4 is
begin begin
-- Do validity check if validity checking operands -- Do validity check if validity checking operands
if Validity_Checks_On if Validity_Checks_On and then Validity_Check_Operands then
and then Validity_Check_Operands
then
Ensure_Valid (Operand); Ensure_Valid (Operand);
end if; end if;
...@@ -7866,7 +7864,7 @@ package body Exp_Ch4 is ...@@ -7866,7 +7864,7 @@ package body Exp_Ch4 is
-- end if; -- end if;
-- end loop; -- end loop;
-- Conversely, an existentially quantified expression: -- Similarly, an existentially quantified expression:
-- for some X in range => Cond -- for some X in range => Cond
...@@ -7957,7 +7955,6 @@ package body Exp_Ch4 is ...@@ -7957,7 +7955,6 @@ package body Exp_Ch4 is
Make_Expression_With_Actions (Loc, Make_Expression_With_Actions (Loc,
Expression => New_Occurrence_Of (Flag, Loc), Expression => New_Occurrence_Of (Flag, Loc),
Actions => Actions)); Actions => Actions));
Analyze_And_Resolve (N, Standard_Boolean); Analyze_And_Resolve (N, Standard_Boolean);
end Expand_N_Quantified_Expression; end Expand_N_Quantified_Expression;
......
gcc/ada/exp_ch9.adb
...@@ -25,6 +25,7 @@ ...@@ -25,6 +25,7 @@
with Atree; use Atree; with Atree; use Atree;
with Checks; use Checks; with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
...@@ -60,6 +61,7 @@ with Sinfo; use Sinfo; ...@@ -60,6 +61,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt; with Stringt; use Stringt;
with Table;
with Targparm; use Targparm; with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp; with Uintp; use Uintp;
...@@ -75,6 +77,34 @@ package body Exp_Ch9 is ...@@ -75,6 +77,34 @@ package body Exp_Ch9 is
Entry_Family_Bound : constant Int := 2**16; Entry_Family_Bound : constant Int := 2**16;
------------------------------
-- Lock Free Data Structure --
------------------------------
-- A data structure used for the Lock Free (LF) implementation of protected
-- objects. Since a protected subprogram can only access a single protected
-- component in the LF implementation, this structure stores each protected
-- subprogram and its accessed protected component when the protected
-- object allows the LF implementation.
type Lock_Free_Sub_Type is record
Sub_Body : Node_Id;
Comp_Id : Entity_Id;
end record;
subtype Subprogram_Id is Nat;
-- The following table used for the Lock Free implementation of protected
-- objects maps Lock_Free_Sub_Type to Subprogram_Id.
package LF_Sub_Table is new Table.Table (
Table_Component_Type => Lock_Free_Sub_Type,
Table_Index_Type => Subprogram_Id,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 5,
Table_Name => "LF_Sub_Table");
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
...@@ -109,6 +139,10 @@ package body Exp_Ch9 is ...@@ -109,6 +139,10 @@ package body Exp_Ch9 is
-- Decls is the list of declarations to be enhanced. -- Decls is the list of declarations to be enhanced.
-- Ent is the entity for the original entry body. -- Ent is the entity for the original entry body.
function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean;
-- Given a protected body N, return True if N permits a lock free
-- implementation.
function Build_Accept_Body (Astat : Node_Id) return Node_Id; function Build_Accept_Body (Astat : Node_Id) return Node_Id;
-- Transform accept statement into a block with added exception handler. -- Transform accept statement into a block with added exception handler.
-- Used both for simple accept statements and for accept alternatives in -- Used both for simple accept statements and for accept alternatives in
...@@ -144,6 +178,32 @@ package body Exp_Ch9 is ...@@ -144,6 +178,32 @@ package body Exp_Ch9 is
-- of the range of each entry family. A single array with that size is -- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type. -- allocated for each concurrent object of the type.
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
-- Entry_Bodies_Array, to determine the body and barrier function used
-- in a protected entry call. A pointer to this function appears in every
-- protected object.
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
-- Build subprogram declaration for previous one
function Build_Lock_Free_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the lock free version of a protected
-- subprogram when the protected type denoted by Pid allows the lock free
-- implementation. It only contains a call to the unprotected version of
-- the subprogram body.
function Build_Lock_Free_Unprotected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id) return Node_Id;
-- This function is used to construct the lock free version of an
-- unprotected subprogram when the protected type denoted by Pid allows the
-- lock free implementation.
function Build_Parameter_Block function Build_Parameter_Block
(Loc : Source_Ptr; (Loc : Source_Ptr;
Actuals : List_Id; Actuals : List_Id;
...@@ -169,49 +229,6 @@ package body Exp_Ch9 is ...@@ -169,49 +229,6 @@ package body Exp_Ch9 is
-- and Decl is the enclosing synchronized type declaration at whose -- and Decl is the enclosing synchronized type declaration at whose
-- freeze point the generated body is analyzed. -- freeze point the generated body is analyzed.
function Build_Renamed_Formal_Declaration
(New_F : Entity_Id;
Formal : Entity_Id;
Comp : Entity_Id;
Renamed_Formal : Node_Id) return Node_Id;
-- Create a renaming declaration for a formal, within a protected entry
-- body or an accept body. The renamed object is a component of the
-- parameter block that is a parameter in the entry call.
-- In Ada 2012, if the formal is an incomplete tagged type, the renaming
-- does not dereference the corresponding component to prevent an illegal
-- use of the incomplete type (AI05-0151).
procedure Build_Wrapper_Bodies
(Loc : Source_Ptr;
Typ : Entity_Id;
N : Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all bodies
-- will be placed. This routine builds the bodies of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new body is analyzed.
procedure Build_Wrapper_Specs
(Loc : Source_Ptr;
Typ : Entity_Id;
N : in out Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all specs
-- will be placed. This routine builds the specs of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new spec is analyzed.
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
-- Entry_Bodies_Array, to determine the body and barrier function used
-- in a protected entry call. A pointer to this function appears in every
-- protected object.
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
-- Build subprogram declaration for previous one
function Build_Protected_Entry function Build_Protected_Entry
(N : Node_Id; (N : Node_Id;
Ent : Entity_Id; Ent : Entity_Id;
...@@ -252,6 +269,19 @@ package body Exp_Ch9 is ...@@ -252,6 +269,19 @@ package body Exp_Ch9 is
-- a cleanup handler that unlocks the object in all cases. -- a cleanup handler that unlocks the object in all cases.
-- (see Exp_Ch7.Expand_Cleanup_Actions). -- (see Exp_Ch7.Expand_Cleanup_Actions).
function Build_Renamed_Formal_Declaration
(New_F : Entity_Id;
Formal : Entity_Id;
Comp : Entity_Id;
Renamed_Formal : Node_Id) return Node_Id;
-- Create a renaming declaration for a formal, within a protected entry
-- body or an accept body. The renamed object is a component of the
-- parameter block that is a parameter in the entry call.
--
-- In Ada 2012, if the formal is an incomplete tagged type, the renaming
-- does not dereference the corresponding component to prevent an illegal
-- use of the incomplete type (AI05-0151).
function Build_Selected_Name function Build_Selected_Name
(Prefix : Entity_Id; (Prefix : Entity_Id;
Selector : Entity_Id; Selector : Entity_Id;
...@@ -291,6 +321,26 @@ package body Exp_Ch9 is ...@@ -291,6 +321,26 @@ package body Exp_Ch9 is
-- subprogram that is called from all protected operations on the same -- subprogram that is called from all protected operations on the same
-- object, including the protected version of the same subprogram. -- object, including the protected version of the same subprogram.
procedure Build_Wrapper_Bodies
(Loc : Source_Ptr;
Typ : Entity_Id;
N : Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all bodies
-- will be placed. This routine builds the bodies of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new body is analyzed.
procedure Build_Wrapper_Specs
(Loc : Source_Ptr;
Typ : Entity_Id;
N : in out Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all specs
-- will be placed. This routine builds the specs of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new spec is analyzed.
procedure Collect_Entry_Families procedure Collect_Entry_Families
(Loc : Source_Ptr; (Loc : Source_Ptr;
Cdecls : List_Id; Cdecls : List_Id;
...@@ -299,6 +349,10 @@ package body Exp_Ch9 is ...@@ -299,6 +349,10 @@ package body Exp_Ch9 is
-- For each entry family in a concurrent type, create an anonymous array -- For each entry family in a concurrent type, create an anonymous array
-- type of the right size, and add a component to the corresponding_record. -- type of the right size, and add a component to the corresponding_record.
function Comp_Of (Sub_Body : Node_Id) return Entity_Id;
-- For the lock free implementation, return the protected component entity
-- referenced in Sub_Body using LF_Sub_Table.
function Concurrent_Object function Concurrent_Object
(Spec_Id : Entity_Id; (Spec_Id : Entity_Id;
Conc_Typ : Entity_Id) return Entity_Id; Conc_Typ : Entity_Id) return Entity_Id;
...@@ -322,6 +376,26 @@ package body Exp_Ch9 is ...@@ -322,6 +376,26 @@ package body Exp_Ch9 is
-- step of the expansion must to be done after private data has been moved -- step of the expansion must to be done after private data has been moved
-- to its final resting scope to ensure proper visibility of debug objects. -- to its final resting scope to ensure proper visibility of debug objects.
procedure Extract_Dispatching_Call
(N : Node_Id;
Call_Ent : out Entity_Id;
Object : out Entity_Id;
Actuals : out List_Id;
Formals : out List_Id);
-- Given a dispatching call, extract the entity of the name of the call,
-- its actual dispatching object, its actual parameters and the formal
-- parameters of the overridden interface-level version. If the type of
-- the dispatching object is an access type then an explicit dereference
-- is returned in Object.
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
Ename : out Node_Id;
Index : out Node_Id);
-- Given an entry call, returns the associated concurrent object,
-- the entry name, and the entry family index.
function Family_Offset function Family_Offset
(Loc : Source_Ptr; (Loc : Source_Ptr;
Hi : Node_Id; Hi : Node_Id;
...@@ -358,26 +432,6 @@ package body Exp_Ch9 is ...@@ -358,26 +432,6 @@ package body Exp_Ch9 is
-- the scope of Context_Id and Context_Decls is the declarative list of -- the scope of Context_Id and Context_Decls is the declarative list of
-- Context. -- Context.
procedure Extract_Dispatching_Call
(N : Node_Id;
Call_Ent : out Entity_Id;
Object : out Entity_Id;
Actuals : out List_Id;
Formals : out List_Id);
-- Given a dispatching call, extract the entity of the name of the call,
-- its actual dispatching object, its actual parameters and the formal
-- parameters of the overridden interface-level version. If the type of
-- the dispatching object is an access type then an explicit dereference
-- is returned in Object.
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
Ename : out Node_Id;
Index : out Node_Id);
-- Given an entry call, returns the associated concurrent object,
-- the entry name, and the entry family index.
function Find_Task_Or_Protected_Pragma function Find_Task_Or_Protected_Pragma
(T : Node_Id; (T : Node_Id;
P : Name_Id) return Node_Id; P : Name_Id) return Node_Id;
...@@ -393,6 +447,9 @@ package body Exp_Ch9 is ...@@ -393,6 +447,9 @@ package body Exp_Ch9 is
-- Task_Body_Procedure of Spec_Id. The returned entity denotes formal -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal
-- parameter _E. -- parameter _E.
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
-- Tell whether a given subprogram cannot raise an exception
function Is_Potentially_Large_Family function Is_Potentially_Large_Family
(Base_Index : Entity_Id; (Base_Index : Entity_Id;
Conctyp : Entity_Id; Conctyp : Entity_Id;
...@@ -762,125 +819,382 @@ package body Exp_Ch9 is ...@@ -762,125 +819,382 @@ package body Exp_Ch9 is
Prepend_To (Decls, Decl); Prepend_To (Decls, Decl);
end Add_Object_Pointer; end Add_Object_Pointer;
----------------------- ------------------------------------
-- Build_Accept_Body -- -- Allow_Lock_Free_Implementation --
----------------------- ------------------------------------
function Build_Accept_Body (Astat : Node_Id) return Node_Id is -- Here are the restrictions for the Lock Free implementation
Loc : constant Source_Ptr := Sloc (Astat);
Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
New_S : Node_Id;
Hand : Node_Id;
Call : Node_Id;
Ohandle : Node_Id;
begin -- Implementation Restrictions on protected declaration
-- At the end of the statement sequence, Complete_Rendezvous is called.
-- A label skipping the Complete_Rendezvous, and all other accept
-- processing, has already been added for the expansion of requeue
-- statements. The Sloc is copied from the last statement since it
-- is really part of this last statement.
Call := -- There must be only protected scalar components (at least one)
Build_Runtime_Call
(Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
Insert_Before (Last (Statements (Stats)), Call);
Analyze (Call);
-- If exception handlers are present, then append Complete_Rendezvous -- Component types must support an atomic compare_exchange primitive
-- calls to the handlers, and construct the required outer block. As -- (size equals to 1, 2, 4 or 8 bytes).
-- above, the Sloc is copied from the last statement in the sequence.
if Present (Exception_Handlers (Stats)) then -- No entries
Hand := First (Exception_Handlers (Stats));
while Present (Hand) loop
Call :=
Build_Runtime_Call
(Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
Append (Call, Statements (Hand));
Analyze (Call);
Next (Hand);
end loop;
New_S := -- Implementation Restrictions on protected operations
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence => Stats)));
else -- Cannot refer to non-constant outside of the scope of the protected
New_S := Stats; -- operation.
end if;
-- At this stage we know that the new statement sequence does not -- Can only access a single protected component: all protected
-- have an exception handler part, so we supply one to call -- component names appearing in a scope (including nested scopes)
-- Exceptional_Complete_Rendezvous. This handler is -- must statically denote the same protected component.
-- when all others => -- Fundamental Restrictions on protected operations
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
-- We handle Abort_Signal to make sure that we properly catch the abort -- No loop and procedure call statements
-- case and wake up the caller.
Ohandle := Make_Others_Choice (Loc); -- Any function call and attribute reference must be static
Set_All_Others (Ohandle);
Set_Exception_Handlers (New_S, function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean is
New_List ( Decls : constant List_Id := Declarations (N);
Make_Implicit_Exception_Handler (Loc, Spec : constant Entity_Id := Corresponding_Spec (N);
Exception_Choices => New_List (Ohandle), Pro_Def : constant Node_Id := Protected_Definition (Parent (Spec));
Pri_Decls : constant List_Id := Private_Declarations (Pro_Def);
Vis_Decls : constant List_Id := Visible_Declarations (Pro_Def);
Statements => New_List ( Comp_Id : Entity_Id;
Make_Procedure_Call_Statement (Sloc (Stats), Comp_Size : Int;
Name => New_Reference_To ( Comp_Type : Entity_Id;
RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), No_Component : Boolean := True;
Parameter_Associations => New_List ( N_Decl : Node_Id;
Make_Function_Call (Sloc (Stats),
Name => New_Reference_To ( function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean;
RTE (RE_Get_GNAT_Exception), Sloc (Stats))))))))); -- Return True if the protected subprogram body Sub_Body doesn't
-- prevent the lock free code expansion, i.e. Sub_Body meets all the
-- restrictions listed below that allow the lock free implementation.
--
-- Can only access a single protected component
--
-- No loop and procedure call statements
Set_Parent (New_S, Astat); -- temp parent for Analyze call -- Any function call and attribute reference must be static
Analyze_Exception_Handlers (Exception_Handlers (New_S));
Expand_Exception_Handlers (New_S);
-- Exceptional_Complete_Rendezvous must be called with abort -- Cannot refer to non-constant outside of the scope of the protected
-- still deferred, which is the case for a "when all others" handler. -- subprogram.
return New_S; ----------------------
end Build_Accept_Body; -- Permit_Lock_Free --
----------------------
----------------------------------- function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean is
-- Build_Activation_Chain_Entity -- Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body);
----------------------------------- Comp_Id : Entity_Id := Empty;
LF_Sub : Lock_Free_Sub_Type;
procedure Build_Activation_Chain_Entity (N : Node_Id) is function Check_Node (N : Node_Id) return Traverse_Result;
function Has_Activation_Chain (Stmt : Node_Id) return Boolean; -- Check the node N meet the lock free restrictions
-- Determine whether an extended return statement has an activation
-- chain.
-------------------------- function Check_All_Nodes is new Traverse_Func (Check_Node);
-- Has_Activation_Chain --
--------------------------
function Has_Activation_Chain (Stmt : Node_Id) return Boolean is ----------------
Decl : Node_Id; -- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
Comp_Decl : Node_Id;
Id : Entity_Id;
begin begin
Decl := First (Return_Object_Declarations (Stmt)); case Nkind (N) is
while Present (Decl) loop
if Nkind (Decl) = N_Object_Declaration -- Function call or attribute reference case
and then Chars (Defining_Identifier (Decl)) = Name_uChain
then when N_Function_Call | N_Attribute_Reference =>
return True;
-- Any function call and attribute reference must be static
if not Is_Static_Expression (N) then
return Abandon;
end if; end if;
Next (Decl); -- Loop and procedure call statement case
end loop;
return False; when N_Procedure_Call_Statement | N_Loop_Statement =>
end Has_Activation_Chain; -- No loop and procedure call statements
return Abandon;
-- Local variables -- Identifier case
when N_Identifier =>
if Present (Entity (N)) then
Id := Entity (N);
-- Cannot refer to non-constant entities outside of the
-- scope of the protected subprogram.
if Ekind (Id) in Assignable_Kind
and then Sloc (Scope (Id)) > No_Location
and then not Scope_Within_Or_Same (Scope (Id), Sub_Id)
and then not Scope_Within_Or_Same (Scope (Id),
Protected_Body_Subprogram (Sub_Id))
then
return Abandon;
end if;
-- Can only access a single protected component
if Ekind_In (Id, E_Constant, E_Variable)
and then Present (Prival_Link (Id))
then
Comp_Decl := Parent (Prival_Link (Id));
if Nkind (Comp_Decl) = N_Component_Declaration
and then Is_List_Member (Comp_Decl)
and then List_Containing (Comp_Decl) = Pri_Decls
then
-- Check if another protected component has already
-- been accessed by the subprogram body.
if Present (Comp_Id)
and then Comp_Id /= Prival_Link (Id)
then
return Abandon;
elsif not Present (Comp_Id) then
Comp_Id := Prival_Link (Id);
end if;
end if;
end if;
end if;
-- Ok for all other nodes
when others => return OK;
end case;
return OK;
end Check_Node;
-- Start of processing for Permit_Lock_Free
begin
if Check_All_Nodes (Sub_Body) = OK then
-- Fill LF_Sub with Sub_Body and its corresponding protected
-- component entity and then store LF_Sub in the lock free
-- subprogram table LF_Sub_Table.
LF_Sub.Sub_Body := Sub_Body;
LF_Sub.Comp_Id := Comp_Id;
LF_Sub_Table.Append (LF_Sub);
return True;
else
return False;
end if;
end Permit_Lock_Free;
-- Start of processing for Allow_Lock_Free_Implementation
begin
-- Debug switch -gnatd9 enables Lock Free implementation
if not Debug_Flag_9 then
return False;
end if;
-- Look for any entries declared in the visible part of the protected
-- declaration.
N_Decl := First (Vis_Decls);
while Present (N_Decl) loop
if Nkind (N_Decl) = N_Entry_Declaration then
return False;
end if;
N_Decl := Next (N_Decl);
end loop;
-- Look for any entry, plus look for any scalar component declared in
-- the private part of the protected declaration.
N_Decl := First (Pri_Decls);
while Present (N_Decl) loop
-- Check at least one scalar component is declared
if Nkind (N_Decl) = N_Component_Declaration then
if No_Component then
No_Component := False;
end if;
Comp_Id := Defining_Identifier (N_Decl);
Comp_Type := Etype (Comp_Id);
-- Verify the component is a scalar
if not Is_Scalar_Type (Comp_Type) then
return False;
end if;
Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type)));
-- Check the size of the component is 8, 16, 32 or 64 bits
case Comp_Size is
when 8 | 16 | 32 | 64 =>
null;
when others =>
return False;
end case;
-- Check there is no entry declared in the private part.
else
if Nkind (N_Decl) = N_Entry_Declaration then
return False;
end if;
end if;
N_Decl := Next (N_Decl);
end loop;
-- One scalar component must be present
if No_Component then
return False;
end if;
-- Ensure all protected subprograms meet the restrictions that allow the
-- lock free implementation.
N_Decl := First (Decls);
while Present (N_Decl) loop
if Nkind (N_Decl) = N_Subprogram_Body
and then not Permit_Lock_Free (N_Decl)
then
return False;
end if;
Next (N_Decl);
end loop;
return True;
end Allow_Lock_Free_Implementation;
-----------------------
-- Build_Accept_Body --
-----------------------
function Build_Accept_Body (Astat : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Astat);
Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
New_S : Node_Id;
Hand : Node_Id;
Call : Node_Id;
Ohandle : Node_Id;
begin
-- At the end of the statement sequence, Complete_Rendezvous is called.
-- A label skipping the Complete_Rendezvous, and all other accept
-- processing, has already been added for the expansion of requeue
-- statements. The Sloc is copied from the last statement since it
-- is really part of this last statement.
Call :=
Build_Runtime_Call
(Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
Insert_Before (Last (Statements (Stats)), Call);
Analyze (Call);
-- If exception handlers are present, then append Complete_Rendezvous
-- calls to the handlers, and construct the required outer block. As
-- above, the Sloc is copied from the last statement in the sequence.
if Present (Exception_Handlers (Stats)) then
Hand := First (Exception_Handlers (Stats));
while Present (Hand) loop
Call :=
Build_Runtime_Call
(Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
Append (Call, Statements (Hand));
Analyze (Call);
Next (Hand);
end loop;
New_S :=
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence => Stats)));
else
New_S := Stats;
end if;
-- At this stage we know that the new statement sequence does not
-- have an exception handler part, so we supply one to call
-- Exceptional_Complete_Rendezvous. This handler is
-- when all others =>
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
-- We handle Abort_Signal to make sure that we properly catch the abort
-- case and wake up the caller.
Ohandle := Make_Others_Choice (Loc);
Set_All_Others (Ohandle);
Set_Exception_Handlers (New_S,
New_List (
Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Ohandle),
Statements => New_List (
Make_Procedure_Call_Statement (Sloc (Stats),
Name => New_Reference_To (
RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
Parameter_Associations => New_List (
Make_Function_Call (Sloc (Stats),
Name => New_Reference_To (
RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
Set_Parent (New_S, Astat); -- temp parent for Analyze call
Analyze_Exception_Handlers (Exception_Handlers (New_S));
Expand_Exception_Handlers (New_S);
-- Exceptional_Complete_Rendezvous must be called with abort
-- still deferred, which is the case for a "when all others" handler.
return New_S;
end Build_Accept_Body;
-----------------------------------
-- Build_Activation_Chain_Entity --
-----------------------------------
procedure Build_Activation_Chain_Entity (N : Node_Id) is
function Has_Activation_Chain (Stmt : Node_Id) return Boolean;
-- Determine whether an extended return statement has an activation
-- chain.
--------------------------
-- Has_Activation_Chain --
--------------------------
function Has_Activation_Chain (Stmt : Node_Id) return Boolean is
Decl : Node_Id;
begin
Decl := First (Return_Object_Declarations (Stmt));
while Present (Decl) loop
if Nkind (Decl) = N_Object_Declaration
and then Chars (Defining_Identifier (Decl)) = Name_uChain
then
return True;
end if;
Next (Decl);
end loop;
return False;
end Has_Activation_Chain;
-- Local variables
Context : Node_Id; Context : Node_Id;
Context_Id : Entity_Id; Context_Id : Entity_Id;
...@@ -2723,15 +3037,13 @@ package body Exp_Ch9 is ...@@ -2723,15 +3037,13 @@ package body Exp_Ch9 is
Condition => Cond, Condition => Cond,
Then_Statements => Stats, Then_Statements => Stats,
Elsif_Parts => New_List); Elsif_Parts => New_List);
Ret := If_St; Ret := If_St;
else else
Append ( Append_To (Elsif_Parts (If_St),
Make_Elsif_Part (Loc, Make_Elsif_Part (Loc,
Condition => Cond, Condition => Cond,
Then_Statements => Stats), Then_Statements => Stats));
Elsif_Parts (If_St));
end if; end if;
end Add_If_Clause; end Add_If_Clause;
...@@ -2788,7 +3100,7 @@ package body Exp_Ch9 is ...@@ -2788,7 +3100,7 @@ package body Exp_Ch9 is
else else
-- Suppose entries e1, e2, ... have size l1, l2, ... we generate -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
-- the following: -- the following:
--
-- if E <= l1 then return 1; -- if E <= l1 then return 1;
-- elsif E <= l1 + l2 then return 2; -- elsif E <= l1 + l2 then return 2;
-- ... -- ...
...@@ -2813,63 +3125,585 @@ package body Exp_Ch9 is ...@@ -2813,63 +3125,585 @@ package body Exp_Ch9 is
Next_Entity (Ent); Next_Entity (Ent);
end loop; end loop;
if Index = 1 then if Index = 1 then
Decls := New_List; Decls := New_List;
Ret := Ret :=
Make_Simple_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, 1)); Expression => Make_Integer_Literal (Loc, 1));
elsif Nkind (Ret) = N_If_Statement then
-- Ranges are in increasing order, so last one doesn't need guard
declare
Nod : constant Node_Id := Last (Elsif_Parts (Ret));
begin
Remove (Nod);
Set_Else_Statements (Ret, Then_Statements (Nod));
end;
end if;
end if;
return
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ret)));
end Build_Find_Body_Index;
--------------------------------
-- Build_Find_Body_Index_Spec --
--------------------------------
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'F'));
Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
begin
return
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm1,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm2,
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Result_Definition => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc));
end Build_Find_Body_Index_Spec;
-----------------------------------------------
-- Build_Lock_Free_Protected_Subprogram_Body --
-----------------------------------------------
function Build_Lock_Free_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : Node_Id;
P_Op_Spec : Node_Id;
Uactuals : List_Id;
Pformal : Node_Id;
Unprot_Call : Node_Id;
R : Node_Id;
Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
Exc_Safe : Boolean;
begin
Op_Spec := Specification (N);
Exc_Safe := Is_Exception_Safe (N);
P_Op_Spec :=
Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
-- Build a list of the formal parameters of the protected version of
-- the subprogram to use as the actual parameters of the unprotected
-- version.
Uactuals := New_List;
Pformal := First (Parameter_Specifications (P_Op_Spec));
while Present (Pformal) loop
Append_To (Uactuals,
Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
Next (Pformal);
end loop;
-- Make a call to the unprotected version of the subprogram built above
-- for use by the protected version built below.
if Nkind (Op_Spec) = N_Function_Specification then
if Exc_Safe then
R := Make_Temporary (Loc, 'R');
Unprot_Call :=
Make_Object_Declaration (Loc,
Defining_Identifier => R,
Constant_Present => True,
Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
Return_Stmt :=
Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (R, Loc));
else
Unprot_Call := Make_Simple_Return_Statement (Loc,
Expression => Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
end if;
else
Unprot_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals);
end if;
if Nkind (Op_Spec) = N_Function_Specification
and then Exc_Safe
then
Unprot_Call :=
Make_Block_Statement (Loc,
Declarations => New_List (Unprot_Call),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Return_Stmt)));
end if;
return
Make_Subprogram_Body (Loc,
Declarations => Empty_List,
Specification => P_Op_Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call)));
end Build_Lock_Free_Protected_Subprogram_Body;
-------------------------------------------------
-- Build_Lock_Free_Unprotected_Subprogram_Body --
-------------------------------------------------
function Build_Lock_Free_Unprotected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id) return Node_Id
is
Decls : constant List_Id := Declarations (N);
Is_Procedure : constant Boolean :=
Ekind (Corresponding_Spec (N)) = E_Procedure;
Loc : constant Source_Ptr := Sloc (N);
function Ren_Comp_Id (Decls : List_Id) return Entity_Id;
-- Given the list of delaration Decls, return the renamed entity
-- of the protected component accessed by the subprogram body.
-----------------
-- Ren_Comp_Id --
-----------------
function Ren_Comp_Id (Decls : List_Id) return Entity_Id is
N_Decl : Node_Id;
Pri_Link : Node_Id;
begin
N_Decl := First (Decls);
while Present (N_Decl) loop
-- Look for a renaming declaration
if Nkind (N_Decl) = N_Object_Renaming_Declaration then
Pri_Link := Prival_Link (Defining_Identifier (N_Decl));
-- Compare the renamed entity and the accessed component entity
-- in the LF_Sub_Table.
if Present (Pri_Link) and then Pri_Link = Comp_Of (N) then
return Defining_Identifier (N_Decl);
end if;
end if;
Next (N_Decl);
end loop;
return Empty;
end Ren_Comp_Id;
Obj_Id : constant Entity_Id := Ren_Comp_Id (Decls);
At_Comp_Id : Entity_Id;
At_Load_Id : Entity_Id;
Copy_Id : Entity_Id;
Exit_Stmt : Node_Id;
Label : Node_Id := Empty;
Label_Id : Entity_Id;
New_Body : Node_Id;
New_Decls : List_Id;
New_Stmts : List_Id;
Obj_Typ : Entity_Id;
Old_Id : Entity_Id;
Typ_Size : Int;
Unsigned_Id : Entity_Id;
function Make_If (Stmt : Node_Id) return Node_Id;
-- Given the statement Stmt, return an if statement with Stmt at the end
-- of the list of statements.
procedure Process_Stmts (Stmts : List_Id);
-- Wrap each return and raise statements in Stmts into an if statement
-- generated by Make_If. Replace all references to the protected object
-- Obj by a reference to its copy Obj_Copy.
-------------
-- Make_If --
-------------
function Make_If (Stmt : Node_Id) return Node_Id is
begin
-- Generate (for Typ_Size = 32):
-- if System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
-- then
-- < Stmt >
-- else
-- goto L0;
-- end if;
-- Check whether a label has already been created
if not Present (Label) then
-- Create a label which will point just after the last
-- statement of the loop statement generated in step 3.
-- Generate:
-- L0 : Label;
Label_Id :=
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id);
Append_To (Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Label_Id),
Label_Construct => Label));
end if;
return
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name => New_Reference_To (At_Comp_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Old_Id, Loc)),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Copy_Id, 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 Make_If;
-------------------
-- Process_Stmts --
-------------------
procedure Process_Stmts (Stmts : List_Id) is
Stmt : Node_Id;
function Check_Node (N : Node_Id) return Traverse_Result;
-- Recognize a return and raise statement and wrap it into an if
-- statement. Replace all references to the protected object by
-- a reference to its copy. Reset all Analyzed flags in order to
-- reanalyze statments inside the new unprotected subprogram body.
procedure Process_Nodes is
new Traverse_Proc (Check_Node);
----------------
-- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
begin
-- In case of a procedure, wrap each return and raise statements
-- inside an if statement created by Make_If.
if Is_Procedure
and then Nkind_In (N, N_Simple_Return_Statement,
N_Extended_Return_Statement,
N_Raise_Statement)
and then
(Nkind (N) /= N_Simple_Return_Statement
or else N /= Last (Stmts))
then
Rewrite (N, Make_If (N));
return Skip;
-- Replace all references to the protected object by a reference
-- to the new copy.
elsif Nkind (N) = N_Identifier
and then Present (Entity (N))
and then Entity (N) = Obj_Id
then
Rewrite (N, Make_Identifier (Loc, Chars (Copy_Id)));
return Skip;
end if;
-- We mark the node as unanalyzed in order to reanalyze it inside
-- the unprotected subprogram body.
Set_Analyzed (N, False);
return OK;
end Check_Node;
-- Start of processing for Process_Stmts
begin
-- Process_Nodes for each statement in Stmts
Stmt := First (Stmts);
while Present (Stmt) loop
Process_Nodes (Stmt);
Next (Stmt);
end loop;
end Process_Stmts;
-- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
begin
New_Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N)));
-- Do the transformation only if the subprogram accesses a protected
-- component.
if not Present (Obj_Id) then
goto Continue;
end if;
Copy_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Obj_Id), Suffix => "_copy"));
Obj_Typ := Etype (Obj_Id);
Typ_Size := UI_To_Int (Esize (Base_Type (Obj_Typ)));
Process_Stmts (New_Stmts);
-- Procedure case
if Is_Procedure then
case Typ_Size is
when 8 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_8);
At_Load_Id := RTE (RE_Atomic_Load_8);
Unsigned_Id := RTE (RE_Uint8);
when 16 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_16);
At_Load_Id := RTE (RE_Atomic_Load_16);
Unsigned_Id := RTE (RE_Uint16);
when 32 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_32);
At_Load_Id := RTE (RE_Atomic_Load_32);
Unsigned_Id := RTE (RE_Uint32);
when 64 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_64);
At_Load_Id := RTE (RE_Atomic_Load_64);
Unsigned_Id := RTE (RE_Uint64);
when others => null;
end case;
-- Generate (e.g. for Typ_Size = 32):
-- begin
-- loop
-- declare
-- Obj_Old : constant Obj_Typ :=
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
-- Obj_Copy : Obj_Typ := Obj_Old;
-- begin
-- < New_Stmts >
-- exit when
-- System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
-- end;
-- end loop;
-- end;
-- Step 1: Define a copy and save the old value of the protected
-- object. The copy replaces all the references to the object present
-- in the body of the procedure.
-- Generate:
-- Obj_Old : constant Obj_Typ :=
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
-- Obj_Copy : Obj_Typ := Obj_Old;
Old_Id := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Obj_Id), Suffix => "_old"));
New_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Old_Id,
Constant_Present => True,
Object_Definition => New_Reference_To (Obj_Typ, Loc),
Expression => Unchecked_Convert_To (Obj_Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (At_Load_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address))))),
Make_Object_Declaration (Loc,
Defining_Identifier => Copy_Id,
Object_Definition => New_Reference_To (Obj_Typ, Loc),
Expression => New_Reference_To (Old_Id, Loc)));
-- Step 2: Create an exit statement of the loop statement generated
-- in step 3.
-- Generate (for Typ_Size = 32):
-- exit when System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
Exit_Stmt :=
Make_Exit_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name => New_Reference_To (At_Comp_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Old_Id, Loc)),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Copy_Id, Loc)))));
-- Check the last statement is a return statement
if Nkind (Last (New_Stmts)) = N_Simple_Return_Statement then
Rewrite (Last (New_Stmts), Exit_Stmt);
else
Append_To (New_Stmts, Exit_Stmt);
end if;
-- Step 3: Create the loop statement which encloses a block
-- declaration that contains all the statements of the original
-- procedure body.
-- Generate:
-- loop
-- declare
-- < New_Decls >
-- begin
-- < New_Stmts >
-- end;
-- end loop;
New_Stmts := New_List (
Make_Loop_Statement (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => New_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_Stmts))),
End_Label => Empty));
-- Append the label to the statements of the loop when needed
if Present (Label) then
Append_To (Statements (First (New_Stmts)), Label);
end if;
-- Function case
else
case Typ_Size is
when 8 =>
At_Load_Id := RTE (RE_Atomic_Load_8);
when 16 =>
At_Load_Id := RTE (RE_Atomic_Load_16);
when 32 =>
At_Load_Id := RTE (RE_Atomic_Load_32);
when 64 =>
At_Load_Id := RTE (RE_Atomic_Load_64);
when others => null;
end case;
-- Define a copy of the protected object which replaces all the
-- references to the object present in the body of the function.
elsif Nkind (Ret) = N_If_Statement then -- Generate:
-- Ranges are in increasing order, so last one doesn't need guard -- Obj_Copy : constant Obj_Typ :=
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
declare Append_To (Decls,
Nod : constant Node_Id := Last (Elsif_Parts (Ret)); Make_Object_Declaration (Loc,
begin Defining_Identifier => Copy_Id,
Remove (Nod); Constant_Present => True,
Set_Else_Statements (Ret, Then_Statements (Nod)); Object_Definition => New_Reference_To (Obj_Typ, Loc),
end; Expression => Unchecked_Convert_To (Obj_Typ,
end if; Make_Function_Call (Loc,
Name => New_Reference_To (At_Load_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address))))));
end if; end if;
return << Continue >>
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ret)));
end Build_Find_Body_Index;
-------------------------------- -- Add renamings for the Protection object, discriminals, privals and
-- Build_Find_Body_Index_Spec -- -- the entry index constant for use by debugger.
--------------------------------
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is Debug_Private_Data_Declarations (Decls);
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'F'));
Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
begin -- Make an unprotected version of the subprogram for use within the same
return -- object, with new name and extra parameter representing the object.
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm1,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc, New_Body :=
Defining_Identifier => Parm2, Make_Subprogram_Body (Loc,
Parameter_Type => Specification =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
Result_Definition => New_Occurrence_Of ( Declarations => Decls,
RTE (RE_Protected_Entry_Index), Loc)); Handled_Statement_Sequence =>
end Build_Find_Body_Index_Spec; Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_Stmts));
return New_Body;
end Build_Lock_Free_Unprotected_Subprogram_Body;
------------------------- -------------------------
-- Build_Master_Entity -- -- Build_Master_Entity --
...@@ -3442,102 +4276,6 @@ package body Exp_Ch9 is ...@@ -3442,102 +4276,6 @@ package body Exp_Ch9 is
Exc_Safe : Boolean; Exc_Safe : Boolean;
Lock_Kind : RE_Id; Lock_Kind : RE_Id;
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
-- Tell whether a given subprogram cannot raise an exception
-----------------------
-- Is_Exception_Safe --
-----------------------
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
function Has_Side_Effect (N : Node_Id) return Boolean;
-- Return True whenever encountering a subprogram call or raise
-- statement of any kind in the sequence of statements
---------------------
-- Has_Side_Effect --
---------------------
-- What is this doing buried two levels down in exp_ch9. It seems
-- like a generally useful function, and indeed there may be code
-- duplication going on here ???
function Has_Side_Effect (N : Node_Id) return Boolean is
Stmt : Node_Id;
Expr : Node_Id;
function Is_Call_Or_Raise (N : Node_Id) return Boolean;
-- Indicate whether N is a subprogram call or a raise statement
----------------------
-- Is_Call_Or_Raise --
----------------------
function Is_Call_Or_Raise (N : Node_Id) return Boolean is
begin
return Nkind_In (N, N_Procedure_Call_Statement,
N_Function_Call,
N_Raise_Statement,
N_Raise_Constraint_Error,
N_Raise_Program_Error,
N_Raise_Storage_Error);
end Is_Call_Or_Raise;
-- Start of processing for Has_Side_Effect
begin
Stmt := N;
while Present (Stmt) loop
if Is_Call_Or_Raise (Stmt) then
return True;
end if;
-- An object declaration can also contain a function call
-- or a raise statement
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
if Present (Expr) and then Is_Call_Or_Raise (Expr) then
return True;
end if;
end if;
Next (Stmt);
end loop;
return False;
end Has_Side_Effect;
-- Start of processing for Is_Exception_Safe
begin
-- If the checks handled by the back end are not disabled, we cannot
-- ensure that no exception will be raised.
if not Access_Checks_Suppressed (Empty)
or else not Discriminant_Checks_Suppressed (Empty)
or else not Range_Checks_Suppressed (Empty)
or else not Index_Checks_Suppressed (Empty)
or else Opt.Stack_Checking_Enabled
then
return False;
end if;
if Has_Side_Effect (First (Declarations (Subprogram)))
or else
Has_Side_Effect (
First (Statements (Handled_Statement_Sequence (Subprogram))))
then
return False;
else
return True;
end if;
end Is_Exception_Safe;
-- Start of processing for Build_Protected_Subprogram_Body
begin begin
Op_Spec := Specification (N); Op_Spec := Specification (N);
Exc_Safe := Is_Exception_Safe (N); Exc_Safe := Is_Exception_Safe (N);
...@@ -4698,6 +5436,21 @@ package body Exp_Ch9 is ...@@ -4698,6 +5436,21 @@ package body Exp_Ch9 is
end loop; end loop;
end Collect_Entry_Families; end Collect_Entry_Families;
-------------
-- Comp_Of --
-------------
function Comp_Of (Sub_Body : Node_Id) return Entity_Id is
begin
for Sub_Id in 1 .. LF_Sub_Table.Last loop
if Sub_Body = LF_Sub_Table.Table (Sub_Id).Sub_Body then
return LF_Sub_Table.Table (Sub_Id).Comp_Id;
end if;
end loop;
return Empty;
end Comp_Of;
----------------------- -----------------------
-- Concurrent_Object -- -- Concurrent_Object --
----------------------- -----------------------
...@@ -7715,6 +8468,9 @@ package body Exp_Ch9 is ...@@ -7715,6 +8468,9 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N); Pid : constant Entity_Id := Corresponding_Spec (N);
Lock_Free_On : constant Boolean := Allow_Lock_Free_Implementation (N);
-- This flag indicates whether the lock free implementation is active
Current_Node : Node_Id; Current_Node : Node_Id;
Disp_Op_Body : Node_Id; Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id; New_Op_Body : Node_Id;
...@@ -7843,8 +8599,14 @@ package body Exp_Ch9 is ...@@ -7843,8 +8599,14 @@ package body Exp_Ch9 is
if not Is_Eliminated (Defining_Entity (Op_Body)) if not Is_Eliminated (Defining_Entity (Op_Body))
and then not Is_Eliminated (Corresponding_Spec (Op_Body)) and then not Is_Eliminated (Corresponding_Spec (Op_Body))
then then
if Lock_Free_On then
New_Op_Body :=
Build_Lock_Free_Unprotected_Subprogram_Body
(Op_Body, Pid);
else
New_Op_Body := New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid); Build_Unprotected_Subprogram_Body (Op_Body, Pid);
end if;
Insert_After (Current_Node, New_Op_Body); Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body; Current_Node := New_Op_Body;
...@@ -7854,6 +8616,7 @@ package body Exp_Ch9 is ...@@ -7854,6 +8616,7 @@ package body Exp_Ch9 is
-- appear that this is needed only if this is a visible -- appear that this is needed only if this is a visible
-- operation of the type, or if it is an interrupt handler, -- operation of the type, or if it is an interrupt handler,
-- and this was the strategy used previously in GNAT. -- and this was the strategy used previously in GNAT.
-- However, the operation may be exported through a 'Access -- However, the operation may be exported through a 'Access
-- to an external caller. This is the common idiom in code -- to an external caller. This is the common idiom in code
-- that uses the Ada 2005 Timing_Events package. As a result -- that uses the Ada 2005 Timing_Events package. As a result
...@@ -7863,9 +8626,15 @@ package body Exp_Ch9 is ...@@ -7863,9 +8626,15 @@ package body Exp_Ch9 is
-- declaration in the protected body itself. -- declaration in the protected body itself.
if Present (Corresponding_Spec (Op_Body)) then if Present (Corresponding_Spec (Op_Body)) then
if Lock_Free_On then
New_Op_Body :=
Build_Lock_Free_Protected_Subprogram_Body
(Op_Body, Pid, Specification (New_Op_Body));
else
New_Op_Body := New_Op_Body :=
Build_Protected_Subprogram_Body ( Build_Protected_Subprogram_Body
Op_Body, Pid, Specification (New_Op_Body)); (Op_Body, Pid, Specification (New_Op_Body));
end if;
Insert_After (Current_Node, New_Op_Body); Insert_After (Current_Node, New_Op_Body);
Analyze (New_Op_Body); Analyze (New_Op_Body);
...@@ -12688,6 +13457,97 @@ package body Exp_Ch9 is ...@@ -12688,6 +13457,97 @@ package body Exp_Ch9 is
end if; end if;
end Install_Private_Data_Declarations; end Install_Private_Data_Declarations;
-----------------------
-- Is_Exception_Safe --
-----------------------
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
function Has_Side_Effect (N : Node_Id) return Boolean;
-- Return True whenever encountering a subprogram call or raise
-- statement of any kind in the sequence of statements
---------------------
-- Has_Side_Effect --
---------------------
-- What is this doing buried two levels down in exp_ch9. It seems like a
-- generally useful function, and indeed there may be code duplication
-- going on here ???
function Has_Side_Effect (N : Node_Id) return Boolean is
Stmt : Node_Id;
Expr : Node_Id;
function Is_Call_Or_Raise (N : Node_Id) return Boolean;
-- Indicate whether N is a subprogram call or a raise statement
----------------------
-- Is_Call_Or_Raise --
----------------------
function Is_Call_Or_Raise (N : Node_Id) return Boolean is
begin
return Nkind_In (N, N_Procedure_Call_Statement,
N_Function_Call,
N_Raise_Statement,
N_Raise_Constraint_Error,
N_Raise_Program_Error,
N_Raise_Storage_Error);
end Is_Call_Or_Raise;
-- Start of processing for Has_Side_Effect
begin
Stmt := N;
while Present (Stmt) loop
if Is_Call_Or_Raise (Stmt) then
return True;
end if;
-- An object declaration can also contain a function call or a
-- raise statement.
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
if Present (Expr) and then Is_Call_Or_Raise (Expr) then
return True;
end if;
end if;
Next (Stmt);
end loop;
return False;
end Has_Side_Effect;
-- Start of processing for Is_Exception_Safe
begin
-- If the checks handled by the back end are not disabled, we cannot
-- ensure that no exception will be raised.
if not Access_Checks_Suppressed (Empty)
or else not Discriminant_Checks_Suppressed (Empty)
or else not Range_Checks_Suppressed (Empty)
or else not Index_Checks_Suppressed (Empty)
or else Opt.Stack_Checking_Enabled
then
return False;
end if;
if Has_Side_Effect (First (Declarations (Subprogram)))
or else
Has_Side_Effect
(First (Statements (Handled_Statement_Sequence (Subprogram))))
then
return False;
else
return True;
end if;
end Is_Exception_Safe;
--------------------------------- ---------------------------------
-- Is_Potentially_Large_Family -- -- Is_Potentially_Large_Family --
--------------------------------- ---------------------------------
...@@ -12702,11 +13562,12 @@ package body Exp_Ch9 is ...@@ -12702,11 +13562,12 @@ package body Exp_Ch9 is
return Scope (Base_Index) = Standard_Standard return Scope (Base_Index) = Standard_Standard
and then Base_Index = Base_Type (Standard_Integer) and then Base_Index = Base_Type (Standard_Integer)
and then Has_Discriminants (Conctyp) and then Has_Discriminants (Conctyp)
and then Present and then
(Discriminant_Default_Value (First_Discriminant (Conctyp))) Present (Discriminant_Default_Value (First_Discriminant (Conctyp)))
and then and then
(Denotes_Discriminant (Lo, True) (Denotes_Discriminant (Lo, True)
or else Denotes_Discriminant (Hi, True)); or else
Denotes_Discriminant (Hi, True));
end Is_Potentially_Large_Family; end Is_Potentially_Large_Family;
------------------------------------- -------------------------------------
......
gcc/ada/exp_util.adb
...@@ -3948,8 +3948,7 @@ package body Exp_Util is ...@@ -3948,8 +3948,7 @@ package body Exp_Util is
(Obj_Id : Entity_Id) return Boolean (Obj_Id : Entity_Id) return Boolean
is is
function Is_Controlled_Function_Call (N : Node_Id) return Boolean; function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node denotes a controlled function -- Determine if particular node denotes a controlled function call
-- call.
function Is_Displace_Call (N : Node_Id) return Boolean; function Is_Displace_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node is a call to Ada.Tags.Displace. -- Determine whether a particular node is a call to Ada.Tags.Displace.
......
gcc/ada/g-sse.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2009, Free Software Foundation, Inc. -- -- Copyright (C) 2009-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -40,6 +40,8 @@ ...@@ -40,6 +40,8 @@
-- GNU/Linux x86 and x86_64 -- GNU/Linux x86 and x86_64
-- Windows XP/Vista x86 and x86_64 -- Windows XP/Vista x86 and x86_64
-- Solaris x86
-- Darwin x86_64
-- This unit exposes vector _component_ types together with general comments -- This unit exposes vector _component_ types together with general comments
-- on the binding contents. -- on the binding contents.
......
gcc/ada/gcc-interface/Makefile.in
...@@ -1083,6 +1083,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),) ...@@ -1083,6 +1083,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),)
TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc EH_MECHANISM=-gcc
THREADSLIB = -lposix4 -lthread THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket MISCLIB = -lposix4 -lnsl -lsocket
...@@ -1175,6 +1177,8 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),) ...@@ -1175,6 +1177,8 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),)
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
indepsw.adb<indepsw-gnu.adb indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc EH_MECHANISM=-gcc
THREADSLIB = -lpthread THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
...@@ -1231,6 +1235,8 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) ...@@ -1231,6 +1235,8 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc EH_MECHANISM=-gcc
THREADSLIB= -lpthread THREADSLIB= -lpthread
GMEM_LIB = gmemlib GMEM_LIB = gmemlib
...@@ -1259,6 +1265,8 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),) ...@@ -1259,6 +1265,8 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),)
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc EH_MECHANISM=-gcc
THREADSLIB= -lpthread THREADSLIB= -lpthread
GMEM_LIB = gmemlib GMEM_LIB = gmemlib
...@@ -2160,6 +2168,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) ...@@ -2160,6 +2168,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),)
$(X86_TARGET_PAIRS) \ $(X86_TARGET_PAIRS) \
system.ads<system-darwin-x86.ads system.ads<system-darwin-x86.ads
endif endif
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
endif endif
ifeq ($(strip $(filter-out %x86_64,$(arch))),) ifeq ($(strip $(filter-out %x86_64,$(arch))),)
...@@ -2178,6 +2188,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) ...@@ -2178,6 +2188,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),)
$(X86_64_TARGET_PAIRS) \ $(X86_64_TARGET_PAIRS) \
system.ads<system-darwin-x86_64.ads system.ads<system-darwin-x86_64.ads
endif endif
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
endif endif
ifeq ($(strip $(filter-out powerpc%,$(arch))),) ifeq ($(strip $(filter-out powerpc%,$(arch))),)
......
gcc/ada/osint.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -444,6 +444,15 @@ package body Osint is ...@@ -444,6 +444,15 @@ package body Osint is
-- Start of processing for Add_Default_Search_Dirs -- Start of processing for Add_Default_Search_Dirs
begin begin
-- If there was a -gnateO switch, add all object directories from the
-- file given in argument to the library search list.
if Object_Path_File_Name /= null then
Path_File_Name := String_Access (Object_Path_File_Name);
pragma Assert (Path_File_Name'Length > 0);
Get_Dirs_From_File (Additional_Source_Dir => False);
end if;
-- After the locations specified on the command line, the next places -- After the locations specified on the command line, the next places
-- to look for files are the directories specified by the appropriate -- to look for files are the directories specified by the appropriate
-- environment variable. Get this value, extract the directory names -- environment variable. Get this value, extract the directory names
......
gcc/ada/osint.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -324,7 +324,8 @@ package Osint is ...@@ -324,7 +324,8 @@ package Osint is
procedure Add_Default_Search_Dirs; procedure Add_Default_Search_Dirs;
-- This routine adds the default search dirs indicated by the environment -- This routine adds the default search dirs indicated by the environment
-- variables and sdefault package. -- variables and sdefault package, as well as the library search dirs set
-- by option -gnateO for GNAT2WHY.
procedure Add_Lib_Search_Dir (Dir : String); procedure Add_Lib_Search_Dir (Dir : String);
-- Add Dir at the end of the library file search path -- Add Dir at the end of the library file search path
......
gcc/ada/rtsfind.ads
...@@ -211,6 +211,7 @@ package Rtsfind is ...@@ -211,6 +211,7 @@ package Rtsfind is
System_Arith_64, System_Arith_64,
System_AST_Handling, System_AST_Handling,
System_Assertions, System_Assertions,
System_Atomic_Primitives,
System_Aux_DEC, System_Aux_DEC,
System_Bit_Ops, System_Bit_Ops,
System_Boolean_Array_Operations, System_Boolean_Array_Operations,
...@@ -730,6 +731,19 @@ package Rtsfind is ...@@ -730,6 +731,19 @@ package Rtsfind is
RE_Assert_Failure, -- System.Assertions RE_Assert_Failure, -- System.Assertions
RE_Raise_Assert_Failure, -- System.Assertions RE_Raise_Assert_Failure, -- System.Assertions
RE_Atomic_Compare_Exchange_8, -- System.Atomic_Primitives
RE_Atomic_Compare_Exchange_16, -- System.Atomic_Primitives
RE_Atomic_Compare_Exchange_32, -- System.Atomic_Primitives
RE_Atomic_Compare_Exchange_64, -- System.Atomic_Primitives
RE_Atomic_Load_8, -- System.Atomic_Primitives
RE_Atomic_Load_16, -- System.Atomic_Primitives
RE_Atomic_Load_32, -- System.Atomic_Primitives
RE_Atomic_Load_64, -- System.Atomic_Primitives
RE_Uint8, -- System.Atomic_Primitives
RE_Uint16, -- System.Atomic_Primitives
RE_Uint32, -- System.Atomic_Primitives
RE_Uint64, -- System.Atomic_Primitives
RE_AST_Handler, -- System.Aux_DEC RE_AST_Handler, -- System.Aux_DEC
RE_Import_Value, -- System.Aux_DEC RE_Import_Value, -- System.Aux_DEC
RE_No_AST_Handler, -- System.Aux_DEC RE_No_AST_Handler, -- System.Aux_DEC
...@@ -1938,6 +1952,19 @@ package Rtsfind is ...@@ -1938,6 +1952,19 @@ package Rtsfind is
RE_Assert_Failure => System_Assertions, RE_Assert_Failure => System_Assertions,
RE_Raise_Assert_Failure => System_Assertions, RE_Raise_Assert_Failure => System_Assertions,
RE_Atomic_Compare_Exchange_8 => System_Atomic_Primitives,
RE_Atomic_Compare_Exchange_16 => System_Atomic_Primitives,
RE_Atomic_Compare_Exchange_32 => System_Atomic_Primitives,
RE_Atomic_Compare_Exchange_64 => System_Atomic_Primitives,
RE_Atomic_Load_8 => System_Atomic_Primitives,
RE_Atomic_Load_16 => System_Atomic_Primitives,
RE_Atomic_Load_32 => System_Atomic_Primitives,
RE_Atomic_Load_64 => System_Atomic_Primitives,
RE_Uint8 => System_Atomic_Primitives,
RE_Uint16 => System_Atomic_Primitives,
RE_Uint32 => System_Atomic_Primitives,
RE_Uint64 => System_Atomic_Primitives,
RE_AST_Handler => System_Aux_DEC, RE_AST_Handler => System_Aux_DEC,
RE_Import_Value => System_Aux_DEC, RE_Import_Value => System_Aux_DEC,
RE_No_AST_Handler => System_Aux_DEC, RE_No_AST_Handler => System_Aux_DEC,
......
gcc/ada/s-atopri.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . A T O M I C _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package System.Atomic_Primitives is
pragma Preelaborate;
type uint8 is mod 2**8
with Size => 8;
type uint16 is mod 2**16
with Size => 16;
type uint32 is mod 2**32
with Size => 32;
type uint64 is mod 2**64
with Size => 64;
Relaxed : constant := 0;
Consume : constant := 1;
Acquire : constant := 2;
Release : constant := 3;
Acq_Rel : constant := 4;
Seq_Cst : constant := 5;
Last : constant := 6;
subtype Mem_Model is Integer range Relaxed .. Last;
function Atomic_Compare_Exchange_8
(X : Address;
X_Old : uint8;
X_Copy : uint8) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_8,
"__sync_bool_compare_and_swap_1");
-- ??? Should use __atomic_compare_exchange_1 (doesn't work yet):
-- function Atomic_Compare_Exchange_8
-- (X : Address;
-- X_Old : Address;
-- X_Copy : uint8;
-- Success_Model : Mem_Model := Seq_Cst;
-- Failure_Model : Mem_Model := Seq_Cst) return Boolean;
-- pragma Import (Intrinsic,
-- Atomic_Compare_Exchange_8,
-- "__atomic_compare_exchange_1");
function Atomic_Compare_Exchange_16
(X : Address;
X_Old : uint16;
X_Copy : uint16) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_16,
"__sync_bool_compare_and_swap_2");
function Atomic_Compare_Exchange_32
(X : Address;
X_Old : uint32;
X_Copy : uint32) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_32,
"__sync_bool_compare_and_swap_4");
function Atomic_Compare_Exchange_64
(X : Address;
X_Old : uint64;
X_Copy : uint64) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_64,
"__sync_bool_compare_and_swap_8");
function Atomic_Load_8
(X : Address;
Model : Mem_Model := Seq_Cst) return uint8;
pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1");
function Atomic_Load_16
(X : Address;
Model : Mem_Model := Seq_Cst) return uint16;
pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2");
function Atomic_Load_32
(X : Address;
Model : Mem_Model := Seq_Cst) return uint32;
pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4");
function Atomic_Load_64
(X : Address;
Model : Mem_Model := Seq_Cst) return uint64;
pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8");
end System.Atomic_Primitives;
gcc/ada/sem_ch5.adb
...@@ -1666,6 +1666,9 @@ package body Sem_Ch5 is ...@@ -1666,6 +1666,9 @@ package body Sem_Ch5 is
if not Is_Entity_Name (Iter_Name) if not Is_Entity_Name (Iter_Name)
and then (Nkind (Parent (N)) /= N_Quantified_Expression and then (Nkind (Parent (N)) /= N_Quantified_Expression
-- The following two tests need comments ???
or else Operating_Mode = Check_Semantics or else Operating_Mode = Check_Semantics
or else Alfa_Mode) or else Alfa_Mode)
then then
......
gcc/ada/sem_res.adb
...@@ -2624,10 +2624,10 @@ package body Sem_Res is ...@@ -2624,10 +2624,10 @@ package body Sem_Res is
-- an error. We can't do this earlier, because it would cause legal -- an error. We can't do this earlier, because it would cause legal
-- cases to get errors (when some other type has an abstract "+"). -- cases to get errors (when some other type has an abstract "+").
if Ada_Version >= Ada_2005 and then if Ada_Version >= Ada_2005
Nkind (N) in N_Op and then and then Nkind (N) in N_Op
Is_Overloaded (N) and then and then Is_Overloaded (N)
Is_Universal_Numeric_Type (Etype (Entity (N))) and then Is_Universal_Numeric_Type (Etype (Entity (N)))
then then
Get_First_Interp (N, I, It); Get_First_Interp (N, I, It);
while Present (It.Typ) loop while Present (It.Typ) loop
...@@ -6118,15 +6118,36 @@ package body Sem_Res is ...@@ -6118,15 +6118,36 @@ package body Sem_Res is
Condition : constant Node_Id := First (Expressions (N)); Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition); Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : Node_Id := Next (Then_Expr); Else_Expr : Node_Id := Next (Then_Expr);
Else_Typ : Entity_Id;
Then_Typ : Entity_Id;
begin begin
Resolve (Condition, Any_Boolean); Resolve (Condition, Any_Boolean);
Resolve (Then_Expr, Typ); Resolve (Then_Expr, Typ);
Then_Typ := Etype (Then_Expr);
-- When the "then" and "else" expressions are of a scalar type, insert
-- a conversion to ensure the generation of a constraint check.
if Is_Scalar_Type (Then_Typ)
and then Then_Typ /= Typ
then
Rewrite (Then_Expr, Convert_To (Typ, Then_Expr));
Analyze_And_Resolve (Then_Expr, Typ);
end if;
-- If ELSE expression present, just resolve using the determined type -- If ELSE expression present, just resolve using the determined type
if Present (Else_Expr) then if Present (Else_Expr) then
Resolve (Else_Expr, Typ); Resolve (Else_Expr, Typ);
Else_Typ := Etype (Else_Expr);
if Is_Scalar_Type (Else_Typ)
and then Else_Typ /= Typ
then
Rewrite (Else_Expr, Convert_To (Typ, Else_Expr));
Analyze_And_Resolve (Else_Expr, Typ);
end if;
-- If no ELSE expression is present, root type must be Standard.Boolean -- If no ELSE expression is present, root type must be Standard.Boolean
-- and we provide a Standard.True result converted to the appropriate -- and we provide a Standard.True result converted to the appropriate
......
gcc/ada/sem_util.adb
...@@ -740,15 +740,16 @@ package body Sem_Util is ...@@ -740,15 +740,16 @@ package body Sem_Util is
N : Node_Id) return Entity_Id N : Node_Id) return Entity_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults.
Disc : Entity_Id; Disc : Entity_Id;
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults
begin begin
if not Has_Discriminants (T) or else Is_Constrained (T) then if not Has_Discriminants (T) or else Is_Constrained (T) then
return T; return T;
end if; end if;
Bas := Base_Type (T); Bas := Base_Type (T);
-- If T is non-private but its base type is private, this is -- If T is non-private but its base type is private, this is
...@@ -757,9 +758,7 @@ package body Sem_Util is ...@@ -757,9 +758,7 @@ package body Sem_Util is
-- proper discriminants are to be found in the full view of -- proper discriminants are to be found in the full view of
-- the base. -- the base.
if Is_Private_Type (Bas) if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
and then Present (Full_View (Bas))
then
Bas := Full_View (Bas); Bas := Full_View (Bas);
end if; end if;
......
gcc/ada/sinfo.ads
...@@ -1252,7 +1252,7 @@ package Sinfo is ...@@ -1252,7 +1252,7 @@ package Sinfo is
-- to the node for the spec of the instance, inserted as part of the -- to the node for the spec of the instance, inserted as part of the
-- semantic processing for instantiations in Sem_Ch12. -- semantic processing for instantiations in Sem_Ch12.
-- Is_Accessibility_Actual (Flag12-Sem) -- Is_Accessibility_Actual (Flag13-Sem)
-- Present in N_Parameter_Association nodes. True if the parameter is -- Present in N_Parameter_Association nodes. True if the parameter is
-- an extra actual that carries the accessibility level of the actual -- an extra actual that carries the accessibility level of the actual
-- for an access parameter, in a function that dispatches on result and -- for an access parameter, in a function that dispatches on result and
......
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