From 36504e5f465b19d444187bcee11a26e1842d277c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 2 Apr 2012 11:47:18 +0200 Subject: [PATCH] [multiple changes] 2012-04-02 Yannick Moy * osint.adb, osint.ads (Add_Default_Search_Dirs): Add library search dirs in file specified with option -gnateO. 2012-04-02 Robert Dewar * sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor reformatting. 2012-04-02 Olivier Hainque * 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 * 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 * sinfo.ads: Minor documentation fix. 2012-04-02 Hristian Kirtchev * 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 * 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 --- gcc/ada/ChangeLog | 59 ++ gcc/ada/Makefile.rtl | 1 + gcc/ada/bindgen.adb | 10 +- gcc/ada/debug.adb | 5 +- gcc/ada/exp_ch4.adb | 7 +- gcc/ada/exp_ch9.adb | 1477 +++++++++++++++++++++++++++++-------- gcc/ada/exp_util.adb | 5 +- gcc/ada/g-sse.ads | 4 +- gcc/ada/gcc-interface/Makefile.in | 12 + gcc/ada/osint.adb | 11 +- gcc/ada/osint.ads | 5 +- gcc/ada/rtsfind.ads | 27 + gcc/ada/s-atopri.ads | 120 +++ gcc/ada/sem_ch5.adb | 3 + gcc/ada/sem_res.adb | 29 +- gcc/ada/sem_util.adb | 11 +- gcc/ada/sinfo.ads | 2 +- 17 files changed, 1455 insertions(+), 333 deletions(-) create mode 100644 gcc/ada/s-atopri.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 73da545..26f77b8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,62 @@ +2012-04-02 Yannick Moy + + * osint.adb, osint.ads (Add_Default_Search_Dirs): Add library + search dirs in file specified with option -gnateO. + +2012-04-02 Robert Dewar + + * sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor + reformatting. + +2012-04-02 Olivier Hainque + + * 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 + + * 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 + + * sinfo.ads: Minor documentation fix. + +2012-04-02 Hristian Kirtchev + + * 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 + + * 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 * g-expect.adb (Expect_Internal): Fix leak of the input file descriptor. diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 7169658..d3212b2 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -479,6 +479,7 @@ GNATRTL_NONTASKING_OBJS= \ s-assert$(objext) \ s-atacco$(objext) \ s-atocou$(objext) \ + s-atopri$(objext) \ s-auxdec$(objext) \ s-bitops$(objext) \ s-boarop$(objext) \ diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index a4b7d39..c44a648 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -511,6 +511,14 @@ package body Bindgen is if CodePeer_Mode then 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 -- that might be needed (by the Ravenscar profile) are the priority and -- the processor for the environment task. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index bb3e485..cbcdf0c 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -153,7 +153,7 @@ package body Debug is -- d6 Default access unconstrained to thin pointers -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode -- d8 Force opposite endianness in packed stuff - -- d9 + -- d9 Allow lock free implementation -- Debug flags for binder (GNATBIND) @@ -710,6 +710,9 @@ package body Debug is -- opposite endianness from the actual correct value. Useful in -- 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 -- ------------------------------------------ diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d08e375..02a733c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7832,9 +7832,7 @@ package body Exp_Ch4 is begin -- Do validity check if validity checking operands - if Validity_Checks_On - and then Validity_Check_Operands - then + if Validity_Checks_On and then Validity_Check_Operands then Ensure_Valid (Operand); end if; @@ -7866,7 +7864,7 @@ package body Exp_Ch4 is -- end if; -- end loop; - -- Conversely, an existentially quantified expression: + -- Similarly, an existentially quantified expression: -- for some X in range => Cond @@ -7957,7 +7955,6 @@ package body Exp_Ch4 is Make_Expression_With_Actions (Loc, Expression => New_Occurrence_Of (Flag, Loc), Actions => Actions)); - Analyze_And_Resolve (N, Standard_Boolean); end Expand_N_Quantified_Expression; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index a827284..212ed30 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -60,6 +61,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -75,6 +77,34 @@ package body Exp_Ch9 is 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 -- ----------------------- @@ -109,6 +139,10 @@ package body Exp_Ch9 is -- Decls is the list of declarations to be enhanced. -- 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; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in @@ -144,6 +178,32 @@ package body Exp_Ch9 is -- of the range of each entry family. A single array with that size is -- 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 (Loc : Source_Ptr; Actuals : List_Id; @@ -169,49 +229,6 @@ package body Exp_Ch9 is -- and Decl is the enclosing synchronized type declaration at whose -- 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 (N : Node_Id; Ent : Entity_Id; @@ -252,6 +269,19 @@ package body Exp_Ch9 is -- a cleanup handler that unlocks the object in all cases. -- (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 (Prefix : Entity_Id; Selector : Entity_Id; @@ -291,6 +321,26 @@ package body Exp_Ch9 is -- subprogram that is called from all protected operations on the same -- 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 (Loc : Source_Ptr; Cdecls : List_Id; @@ -299,6 +349,10 @@ package body Exp_Ch9 is -- 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. + 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 (Spec_Id : Entity_Id; Conc_Typ : Entity_Id) return Entity_Id; @@ -322,6 +376,26 @@ package body Exp_Ch9 is -- 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. + 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 (Loc : Source_Ptr; Hi : Node_Id; @@ -358,26 +432,6 @@ package body Exp_Ch9 is -- the scope of Context_Id and Context_Decls is the declarative list of -- 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 (T : Node_Id; P : Name_Id) return Node_Id; @@ -393,6 +447,9 @@ package body Exp_Ch9 is -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal -- 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 (Base_Index : Entity_Id; Conctyp : Entity_Id; @@ -762,6 +819,263 @@ package body Exp_Ch9 is Prepend_To (Decls, Decl); end Add_Object_Pointer; + ------------------------------------ + -- Allow_Lock_Free_Implementation -- + ------------------------------------ + + -- Here are the restrictions for the Lock Free implementation + + -- Implementation Restrictions on protected declaration + + -- There must be only protected scalar components (at least one) + + -- Component types must support an atomic compare_exchange primitive + -- (size equals to 1, 2, 4 or 8 bytes). + + -- No entries + + -- Implementation Restrictions on protected operations + + -- Cannot refer to non-constant outside of the scope of the protected + -- operation. + + -- Can only access a single protected component: all protected + -- component names appearing in a scope (including nested scopes) + -- must statically denote the same protected component. + + -- Fundamental Restrictions on protected operations + + -- No loop and procedure call statements + + -- Any function call and attribute reference must be static + + function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean is + Decls : constant List_Id := Declarations (N); + Spec : constant Entity_Id := Corresponding_Spec (N); + 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); + + Comp_Id : Entity_Id; + Comp_Size : Int; + Comp_Type : Entity_Id; + No_Component : Boolean := True; + N_Decl : Node_Id; + + function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean; + -- 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 + + -- Any function call and attribute reference must be static + + -- Cannot refer to non-constant outside of the scope of the protected + -- subprogram. + + ---------------------- + -- Permit_Lock_Free -- + ---------------------- + + function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean is + Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body); + Comp_Id : Entity_Id := Empty; + LF_Sub : Lock_Free_Sub_Type; + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Check the node N meet the lock free restrictions + + function Check_All_Nodes is new Traverse_Func (Check_Node); + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + Comp_Decl : Node_Id; + Id : Entity_Id; + + begin + case Nkind (N) is + + -- Function call or attribute reference case + + when N_Function_Call | N_Attribute_Reference => + + -- Any function call and attribute reference must be static + + if not Is_Static_Expression (N) then + return Abandon; + end if; + + -- Loop and procedure call statement case + + when N_Procedure_Call_Statement | N_Loop_Statement => + -- No loop and procedure call statements + return Abandon; + + -- 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 -- ----------------------- @@ -2696,180 +3010,700 @@ package body Exp_Ch9 is begin -- Index for current entry body - Index := Index + 1; + Index := Index + 1; + + -- Compute total length of entry queues so far + + if No (Siz) then + Siz := Expr; + else + Siz := + Make_Op_Add (Loc, + Left_Opnd => Siz, + Right_Opnd => Expr); + end if; + + Cond := + Make_Op_Le (Loc, + Left_Opnd => Make_Identifier (Loc, Name_uE), + Right_Opnd => Siz); + + -- Map entry queue indexes in the range of the current family + -- into the current index, that designates the entry body. + + if No (If_St) then + If_St := + Make_Implicit_If_Statement (Typ, + Condition => Cond, + Then_Statements => Stats, + Elsif_Parts => New_List); + Ret := If_St; + + else + Append_To (Elsif_Parts (If_St), + Make_Elsif_Part (Loc, + Condition => Cond, + Then_Statements => Stats)); + end if; + end Add_If_Clause; + + ------------------------------ + -- Convert_Discriminant_Ref -- + ------------------------------ + + function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is + B : Node_Id; + + begin + if Is_Entity_Name (Bound) + and then Ekind (Entity (Bound)) = E_Discriminant + then + B := + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Corresponding_Record_Type (Typ), + Make_Explicit_Dereference (Loc, + Make_Identifier (Loc, Name_uObject))), + Selector_Name => Make_Identifier (Loc, Chars (Bound))); + Set_Etype (B, Etype (Entity (Bound))); + else + B := New_Copy_Tree (Bound); + end if; + + return B; + end Convert_Discriminant_Ref; + + -- Start of processing for Build_Find_Body_Index + + begin + Spec := Build_Find_Body_Index_Spec (Typ); + + Ent := First_Entity (Typ); + while Present (Ent) loop + if Ekind (Ent) = E_Entry_Family then + Has_F := True; + exit; + end if; + + Next_Entity (Ent); + end loop; + + if not Has_F then + + -- If the protected type has no entry families, there is a one-one + -- correspondence between entry queue and entry body. + + Ret := + Make_Simple_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_uE)); + + else + -- Suppose entries e1, e2, ... have size l1, l2, ... we generate + -- the following: + + -- if E <= l1 then return 1; + -- elsif E <= l1 + l2 then return 2; + -- ... + + Index := 0; + Siz := Empty; + Ent := First_Entity (Typ); + + Add_Object_Pointer (Loc, Typ, Decls); + + while Present (Ent) loop + if Ekind (Ent) = E_Entry then + Add_If_Clause (Make_Integer_Literal (Loc, 1)); + + elsif Ekind (Ent) = E_Entry_Family then + E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); + Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); + Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); + Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); + end if; + + Next_Entity (Ent); + end loop; + + if Index = 1 then + Decls := New_List; + Ret := + Make_Simple_Return_Statement (Loc, + 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); - -- Compute total length of entry queues so far + when 32 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_32); + At_Load_Id := RTE (RE_Atomic_Load_32); + Unsigned_Id := RTE (RE_Uint32); - if No (Siz) then - Siz := Expr; - else - Siz := - Make_Op_Add (Loc, - Left_Opnd => Siz, - Right_Opnd => Expr); - end if; + 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; - Cond := - Make_Op_Le (Loc, - Left_Opnd => Make_Identifier (Loc, Name_uE), - Right_Opnd => Siz); + -- 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. - -- Map entry queue indexes in the range of the current family - -- into the current index, that designates the entry body. + -- Generate: - if No (If_St) then - If_St := - Make_Implicit_If_Statement (Typ, - Condition => Cond, - Then_Statements => Stats, - Elsif_Parts => New_List); + -- Obj_Old : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); + -- Obj_Copy : Obj_Typ := Obj_Old; - Ret := If_St; + Old_Id := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Obj_Id), Suffix => "_old")); - else - Append ( - Make_Elsif_Part (Loc, - Condition => Cond, - Then_Statements => Stats), - Elsif_Parts (If_St)); - end if; - end Add_If_Clause; + 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))); - ------------------------------ - -- Convert_Discriminant_Ref -- - ------------------------------ + -- Step 2: Create an exit statement of the loop statement generated + -- in step 3. - function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is - B : Node_Id; + -- Generate (for Typ_Size = 32): - begin - if Is_Entity_Name (Bound) - and then Ekind (Entity (Bound)) = E_Discriminant - then - B := - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (Corresponding_Record_Type (Typ), - Make_Explicit_Dereference (Loc, - Make_Identifier (Loc, Name_uObject))), - Selector_Name => Make_Identifier (Loc, Chars (Bound))); - Set_Etype (B, Etype (Entity (Bound))); + -- 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 - B := New_Copy_Tree (Bound); + Append_To (New_Stmts, Exit_Stmt); end if; - return B; - end Convert_Discriminant_Ref; - - -- Start of processing for Build_Find_Body_Index + -- Step 3: Create the loop statement which encloses a block + -- declaration that contains all the statements of the original + -- procedure body. - begin - Spec := Build_Find_Body_Index_Spec (Typ); + -- Generate: - Ent := First_Entity (Typ); - while Present (Ent) loop - if Ekind (Ent) = E_Entry_Family then - Has_F := True; - exit; - end if; + -- loop + -- declare + -- < New_Decls > + -- begin + -- < New_Stmts > + -- end; + -- end loop; - Next_Entity (Ent); - 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)); - if not Has_F then + -- Append the label to the statements of the loop when needed - -- If the protected type has no entry families, there is a one-one - -- correspondence between entry queue and entry body. + if Present (Label) then + Append_To (Statements (First (New_Stmts)), Label); + end if; - Ret := - Make_Simple_Return_Statement (Loc, - Expression => Make_Identifier (Loc, Name_uE)); + -- Function case else - -- Suppose entries e1, e2, ... have size l1, l2, ... we generate - -- the following: - -- - -- if E <= l1 then return 1; - -- elsif E <= l1 + l2 then return 2; - -- ... - - Index := 0; - Siz := Empty; - Ent := First_Entity (Typ); + 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; - Add_Object_Pointer (Loc, Typ, Decls); + -- Define a copy of the protected object which replaces all the + -- references to the object present in the body of the function. - while Present (Ent) loop - if Ekind (Ent) = E_Entry then - Add_If_Clause (Make_Integer_Literal (Loc, 1)); + -- Generate: - elsif Ekind (Ent) = E_Entry_Family then - E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); - Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); - Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); - Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); - end if; + -- Obj_Copy : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); - Next_Entity (Ent); - end loop; + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Copy_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)))))); + end if; - if Index = 1 then - Decls := New_List; - Ret := - Make_Simple_Return_Statement (Loc, - Expression => Make_Integer_Literal (Loc, 1)); + << Continue >> - elsif Nkind (Ret) = N_If_Statement then + -- Add renamings for the Protection object, discriminals, privals and + -- the entry index constant for use by debugger. - -- Ranges are in increasing order, so last one doesn't need guard + Debug_Private_Data_Declarations (Decls); - declare - Nod : constant Node_Id := Last (Elsif_Parts (Ret)); - begin - Remove (Nod); - Set_Else_Statements (Ret, Then_Statements (Nod)); - end; - end if; - end if; + -- Make an unprotected version of the subprogram for use within the same + -- object, with new name and extra parameter representing the object. - return + New_Body := Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => + Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), + 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; + Statements => New_Stmts)); + return New_Body; + end Build_Lock_Free_Unprotected_Subprogram_Body; ------------------------- -- Build_Master_Entity -- @@ -3442,102 +4276,6 @@ package body Exp_Ch9 is Exc_Safe : Boolean; 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 Op_Spec := Specification (N); Exc_Safe := Is_Exception_Safe (N); @@ -4698,6 +5436,21 @@ package body Exp_Ch9 is end loop; 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 -- ----------------------- @@ -7715,6 +8468,9 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (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; Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; @@ -7843,8 +8599,14 @@ package body Exp_Ch9 is if not Is_Eliminated (Defining_Entity (Op_Body)) and then not Is_Eliminated (Corresponding_Spec (Op_Body)) then - New_Op_Body := - Build_Unprotected_Subprogram_Body (Op_Body, Pid); + if Lock_Free_On then + New_Op_Body := + Build_Lock_Free_Unprotected_Subprogram_Body + (Op_Body, Pid); + else + New_Op_Body := + Build_Unprotected_Subprogram_Body (Op_Body, Pid); + end if; Insert_After (Current_Node, New_Op_Body); Current_Node := New_Op_Body; @@ -7854,6 +8616,7 @@ package body Exp_Ch9 is -- appear that this is needed only if this is a visible -- operation of the type, or if it is an interrupt handler, -- and this was the strategy used previously in GNAT. + -- However, the operation may be exported through a 'Access -- to an external caller. This is the common idiom in code -- that uses the Ada 2005 Timing_Events package. As a result @@ -7863,9 +8626,15 @@ package body Exp_Ch9 is -- declaration in the protected body itself. if Present (Corresponding_Spec (Op_Body)) then - New_Op_Body := - Build_Protected_Subprogram_Body ( - Op_Body, Pid, Specification (New_Op_Body)); + 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 := + Build_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + end if; Insert_After (Current_Node, New_Op_Body); Analyze (New_Op_Body); @@ -12688,6 +13457,97 @@ package body Exp_Ch9 is end if; 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 -- --------------------------------- @@ -12702,11 +13562,12 @@ package body Exp_Ch9 is return Scope (Base_Index) = Standard_Standard and then Base_Index = Base_Type (Standard_Integer) and then Has_Discriminants (Conctyp) - and then Present - (Discriminant_Default_Value (First_Discriminant (Conctyp))) + and then + Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) and then (Denotes_Discriminant (Lo, True) - or else Denotes_Discriminant (Hi, True)); + or else + Denotes_Discriminant (Hi, True)); end Is_Potentially_Large_Family; ------------------------------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b43bd16..ae5470f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3948,8 +3948,7 @@ package body Exp_Util is (Obj_Id : Entity_Id) return Boolean is function Is_Controlled_Function_Call (N : Node_Id) return Boolean; - -- Determine whether a particular node denotes a controlled function - -- call. + -- Determine if particular node denotes a controlled function call function Is_Displace_Call (N : Node_Id) return Boolean; -- Determine whether a particular node is a call to Ada.Tags.Displace. @@ -4065,7 +4064,7 @@ package body Exp_Util is and then Is_Displace_Call (Renamed_Object (Obj_Id)) and then (Is_Controlled_Function_Call (Expression (Orig_Decl)) - or else Is_Source_Object (Expression (Orig_Decl))); + or else Is_Source_Object (Expression (Orig_Decl))); end Is_Displacement_Of_Object_Or_Function_Result; ------------------------------ diff --git a/gcc/ada/g-sse.ads b/gcc/ada/g-sse.ads index 706516b..60d3577 100644 --- a/gcc/ada/g-sse.ads +++ b/gcc/ada/g-sse.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,6 +40,8 @@ -- GNU/Linux 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 -- on the binding contents. diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 9991405..5c4acda 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1083,6 +1083,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),) TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb 0); + Get_Dirs_From_File (Additional_Source_Dir => False); + end if; + -- After the locations specified on the command line, the next places -- to look for files are the directories specified by the appropriate -- environment variable. Get this value, extract the directory names diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index a4fc334..48663f5 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -324,7 +324,8 @@ package Osint is procedure Add_Default_Search_Dirs; -- 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); -- Add Dir at the end of the library file search path diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 88e61dc..e02f575 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -211,6 +211,7 @@ package Rtsfind is System_Arith_64, System_AST_Handling, System_Assertions, + System_Atomic_Primitives, System_Aux_DEC, System_Bit_Ops, System_Boolean_Array_Operations, @@ -730,6 +731,19 @@ package Rtsfind is RE_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_Import_Value, -- System.Aux_DEC RE_No_AST_Handler, -- System.Aux_DEC @@ -1938,6 +1952,19 @@ package Rtsfind is RE_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_Import_Value => System_Aux_DEC, RE_No_AST_Handler => System_Aux_DEC, diff --git a/gcc/ada/s-atopri.ads b/gcc/ada/s-atopri.ads new file mode 100644 index 0000000..6f39cf0 --- /dev/null +++ b/gcc/ada/s-atopri.ads @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 6b45c07..6feb84c 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1666,6 +1666,9 @@ package body Sem_Ch5 is if not Is_Entity_Name (Iter_Name) and then (Nkind (Parent (N)) /= N_Quantified_Expression + + -- The following two tests need comments ??? + or else Operating_Mode = Check_Semantics or else Alfa_Mode) then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ab08e77..ef5f8b4 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2624,10 +2624,10 @@ package body Sem_Res is -- an error. We can't do this earlier, because it would cause legal -- cases to get errors (when some other type has an abstract "+"). - if Ada_Version >= Ada_2005 and then - Nkind (N) in N_Op and then - Is_Overloaded (N) and then - Is_Universal_Numeric_Type (Etype (Entity (N))) + if Ada_Version >= Ada_2005 + and then Nkind (N) in N_Op + and then Is_Overloaded (N) + and then Is_Universal_Numeric_Type (Etype (Entity (N))) then Get_First_Interp (N, I, It); while Present (It.Typ) loop @@ -6118,15 +6118,36 @@ package body Sem_Res is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); Else_Expr : Node_Id := Next (Then_Expr); + Else_Typ : Entity_Id; + Then_Typ : Entity_Id; begin Resolve (Condition, Any_Boolean); 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 Present (Else_Expr) then 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 -- and we provide a Standard.True result converted to the appropriate diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e7958058..b8e4d81 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -740,15 +740,16 @@ package body Sem_Util is N : Node_Id) return Entity_Id is Loc : constant Source_Ptr := Sloc (N); - Bas : Entity_Id; - -- The base type that is to be constrained by the defaults. - Disc : Entity_Id; + Bas : Entity_Id; + -- The base type that is to be constrained by the defaults + begin if not Has_Discriminants (T) or else Is_Constrained (T) then return T; end if; + Bas := Base_Type (T); -- If T is non-private but its base type is private, this is @@ -757,9 +758,7 @@ package body Sem_Util is -- proper discriminants are to be found in the full view of -- the base. - if Is_Private_Type (Bas) - and then Present (Full_View (Bas)) - then + if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then Bas := Full_View (Bas); end if; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0972d9c..e9f1c8e 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1252,7 +1252,7 @@ package Sinfo is -- to the node for the spec of the instance, inserted as part of the -- 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 -- an extra actual that carries the accessibility level of the actual -- for an access parameter, in a function that dispatches on result and -- 2.7.4