From patchwork Mon Oct 18 09:59:54 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68157 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id D4F2FB70E9 for ; Mon, 18 Oct 2010 21:00:11 +1100 (EST) Received: (qmail 25106 invoked by alias); 18 Oct 2010 10:00:08 -0000 Received: (qmail 25076 invoked by uid 22791); 18 Oct 2010 10:00:04 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 18 Oct 2010 09:59:57 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 0B916CB0326; Mon, 18 Oct 2010 11:59:55 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id ORZ8seLUp3RV; Mon, 18 Oct 2010 11:59:54 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id E004ACB022E; Mon, 18 Oct 2010 11:59:54 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id BF906D9BB4; Mon, 18 Oct 2010 11:59:54 +0200 (CEST) Date: Mon, 18 Oct 2010 11:59:54 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Cleanup: simplify use of Primitive_Operations attribute Message-ID: <20101018095954.GA13654@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch does not change the functionality of the compiler. It is cleanup that simplifies the use of the tree attribute Primitive_Operations with concurrent types. No test required. Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-18 Javier Miranda * einfo.ads, einfo.adb (Primitive_Operations): New synthesized attribute. (Direct_Primitive_Operations): Renaming of old Primitive_Operations. (Set_Direct_Primitive_Operations): Renaming of old Set_Primitive_Operations. Update documentation * sem_ch3.adb, exp_util.adb, sem_ch7.adb, sem_ch8.adb, exp_ch3.adb: Replace occurrences of Set_Primitive_Operations by Set_Direct_Primitive_Operations. * sem_cat.adb (Validate_RACW_Primitives): No action needed for tagged concurrent types. * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Do not process primitives of concurrent types. * lib-xref.adb (Generate_Prim_Op_References): Minor code cleanup. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165616) +++ sem_ch3.adb (working copy) @@ -2444,7 +2444,7 @@ package body Sem_Ch3 is if Tagged_Present (N) then Set_Is_Tagged_Type (T); Make_Class_Wide_Type (T); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; Push_Scope (T); @@ -2496,7 +2496,7 @@ package body Sem_Ch3 is or else Task_Present (Def)); Set_Interfaces (T, New_Elmt_List); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already -- built (i.e. during the creation of the limited view) @@ -3936,8 +3936,8 @@ package body Sem_Ch3 is if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Id); Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); - Set_Primitive_Operations - (Id, Primitive_Operations (T)); + Set_Direct_Primitive_Operations + (Id, Direct_Primitive_Operations (T)); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); if Is_Interface (T) then @@ -3960,10 +3960,11 @@ package body Sem_Ch3 is (Id, Known_To_Have_Preelab_Init (T)); if Is_Tagged_Type (T) then - Set_Is_Tagged_Type (Id); - Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); - Set_Primitive_Operations (Id, Primitive_Operations (T)); - Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + Set_Is_Tagged_Type (Id); + Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); + Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + Set_Direct_Primitive_Operations (Id, + Direct_Primitive_Operations (T)); end if; -- In general the attributes of the subtype of a private type @@ -7352,7 +7353,7 @@ package body Sem_Ch3 is -- Set fields for tagged types if Is_Tagged then - Set_Primitive_Operations (Derived_Type, New_Elmt_List); + Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); -- All tagged types defined in Ada.Finalization are controlled @@ -8237,7 +8238,8 @@ package body Sem_Ch3 is Set_Corresponding_Record_Type (Def_Id, Corresponding_Record_Type (T)); else - Set_Primitive_Operations (Def_Id, Primitive_Operations (T)); + Set_Direct_Primitive_Operations (Def_Id, + Direct_Primitive_Operations (T)); end if; Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); @@ -9811,7 +9813,8 @@ package body Sem_Ch3 is if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); - Set_Primitive_Operations (Full, Primitive_Operations (Full_Base)); + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Full_Base)); -- Inherit class_wide type of full_base in case the partial view was -- not tagged. Otherwise it has already been created when the private @@ -11552,7 +11555,8 @@ package body Sem_Ch3 is Conditional_Delay (Full, Priv); if Is_Tagged_Type (Full) then - Set_Primitive_Operations (Full, Primitive_Operations (Priv)); + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Priv)); if Priv = Base_Type (Priv) then Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); @@ -13529,8 +13533,10 @@ package body Sem_Ch3 is Set_Etype (T, Any_Type); Set_Scalar_Range (T, Scalar_Range (Any_Type)); - if Is_Tagged_Type (T) then - Set_Primitive_Operations (T, New_Elmt_List); + if Is_Tagged_Type (T) + and then Is_Record_Type (T) + then + Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; return; @@ -14290,7 +14296,6 @@ package body Sem_Ch3 is if not Tagged_Present (Type_Definition (N)) then Tag_Mismatch; Set_Is_Tagged_Type (Id); - Set_Primitive_Operations (Id, New_Elmt_List); end if; elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then @@ -14302,7 +14307,6 @@ package body Sem_Ch3 is -- Set some attributes to produce a usable full view Set_Is_Tagged_Type (Id); - Set_Primitive_Operations (Id, New_Elmt_List); end if; else @@ -15421,12 +15425,12 @@ package body Sem_Ch3 is -- Customize the class-wide type: It has no prim. op., it cannot be -- abstract and its Etype points back to the specific root type. - Set_Ekind (CW_Type, E_Class_Wide_Type); - Set_Is_Tagged_Type (CW_Type, True); - Set_Primitive_Operations (CW_Type, New_Elmt_List); - Set_Is_Abstract_Type (CW_Type, False); - Set_Is_Constrained (CW_Type, False); - Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); + Set_Ekind (CW_Type, E_Class_Wide_Type); + Set_Is_Tagged_Type (CW_Type, True); + Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); + Set_Is_Abstract_Type (CW_Type, False); + Set_Is_Constrained (CW_Type, False); + Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); @@ -16990,7 +16994,7 @@ package body Sem_Ch3 is -- of the class-wide type which depend on the full declaration. if Is_Tagged_Type (Priv_T) then - Set_Primitive_Operations (Priv_T, Full_List); + Set_Direct_Primitive_Operations (Priv_T, Full_List); Set_Class_Wide_Type (Base_Type (Full_T), Class_Wide_Type (Priv_T)); @@ -18268,14 +18272,13 @@ package body Sem_Ch3 is end if; Make_Class_Wide_Type (T); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; - -- We must suppress range checks when processing the components - -- of a record in the presence of discriminants, since we don't - -- want spurious checks to be generated during their analysis, but - -- must reset the Suppress_Range_Checks flags after having processed - -- the record definition. + -- We must suppress range checks when processing record components in + -- the presence of discriminants, since we don't want spurious checks to + -- be generated during their analysis, but Suppress_Range_Checks flags + -- must be reset the after processing the record definition. -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, -- couldn't we just use the normal range check suppression method here. Index: exp_util.adb =================================================================== --- exp_util.adb (revision 165614) +++ exp_util.adb (working copy) @@ -4115,8 +4115,8 @@ package body Exp_Util is if Is_Tagged_Type (Priv_Subtyp) then Set_Class_Wide_Type (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ)); - Set_Primitive_Operations (Priv_Subtyp, - Primitive_Operations (Unc_Typ)); + Set_Direct_Primitive_Operations (Priv_Subtyp, + Direct_Primitive_Operations (Unc_Typ)); end if; Set_Full_View (Priv_Subtyp, Full_Subtyp); Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 165615) +++ sem_ch7.adb (working copy) @@ -1956,11 +1956,11 @@ package body Sem_Ch7 is Set_Private_Dependents (Id, New_Elmt_List); if Tagged_Present (Def) then - Set_Ekind (Id, E_Record_Type_With_Private); - Set_Primitive_Operations (Id, New_Elmt_List); - Set_Is_Abstract_Type (Id, Abstract_Present (Def)); - Set_Is_Limited_Record (Id, Limited_Present (Def)); - Set_Has_Delayed_Freeze (Id, True); + Set_Ekind (Id, E_Record_Type_With_Private); + Set_Direct_Primitive_Operations (Id, New_Elmt_List); + Set_Is_Abstract_Type (Id, Abstract_Present (Def)); + Set_Is_Limited_Record (Id, Limited_Present (Def)); + Set_Has_Delayed_Freeze (Id, True); -- Create a class-wide type with the same attributes Index: einfo.adb =================================================================== --- einfo.adb (revision 165614) +++ einfo.adb (working copy) @@ -121,7 +121,7 @@ package body Einfo is -- Entry_Parameters_Type Node15 -- Extra_Formal Node15 -- Lit_Indexes Node15 - -- Primitive_Operations Elist15 + -- Direct_Primitive_Operations Elist15 -- Related_Instance Node15 -- Scale_Value Uint15 -- Storage_Size_Variable Node15 @@ -817,6 +817,12 @@ package body Einfo is return Uint17 (Id); end Digits_Value; + function Direct_Primitive_Operations (Id : E) return L is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Elist15 (Id); + end Direct_Primitive_Operations; + function Directly_Designated_Type (Id : E) return E is begin pragma Assert (Is_Access_Type (Id)); @@ -2355,8 +2361,16 @@ package body Einfo is function Primitive_Operations (Id : E) return L is begin - pragma Assert (Is_Tagged_Type (Id)); - return Elist15 (Id); + if Is_Concurrent_Type (Id) then + if Present (Corresponding_Record_Type (Id)) then + return Direct_Primitive_Operations + (Corresponding_Record_Type (Id)); + else + return No_Elist; + end if; + else + return Direct_Primitive_Operations (Id); + end if; end Primitive_Operations; function Prival (Id : E) return E is @@ -4817,11 +4831,18 @@ package body Einfo is Set_Node8 (Id, V); end Set_Postcondition_Proc; - procedure Set_Primitive_Operations (Id : E; V : L) is + procedure Set_Direct_Primitive_Operations (Id : E; V : L) is begin - pragma Assert (Is_Tagged_Type (Id)); + pragma Assert + (Is_Tagged_Type (Id) + and then + (Is_Record_Type (Id) + or else + Is_Incomplete_Type (Id) + or else + Ekind_In (Id, E_Private_Type, E_Private_Subtype))); Set_Elist15 (Id, V); - end Set_Primitive_Operations; + end Set_Direct_Primitive_Operations; procedure Set_Prival (Id : E; V : E) is begin @@ -7583,7 +7604,7 @@ package body Einfo is E_Record_Type | E_Record_Subtype | Private_Kind => - Write_Str ("Primitive_Operations"); + Write_Str ("Direct_Primitive_Operations"); when E_Component => Write_Str ("DT_Entry_Count"); Index: einfo.ads =================================================================== --- einfo.ads (revision 165612) +++ einfo.ads (working copy) @@ -769,6 +769,16 @@ package Einfo is -- Present in floating point types and subtypes and decimal types and -- subtypes. Contains the Digits value specified in the declaration. +-- Direct_Primitive_Operations (Elist15) +-- Present in tagged record types and subtypes, in tagged private types +-- and in tagged incomplete types. Points to an element list of entities +-- for primitive operations for the tagged type. Not present in untagged +-- types (it is an error to reference the primitive operations field of a +-- type that is not tagged). In order to fulfill the C++ ABI, entities of +-- primitives that come from source must be stored in this list following +-- their order of occurrence in the sources. For incomplete types the +-- list is always empty. + -- Directly_Designated_Type (Node20) -- Present in access types. This field points to the type that is -- directly designated by the access type. In the case of an access @@ -3201,15 +3211,12 @@ package Einfo is -- to generate the call to this procedure in case the expander inserts -- implicit return statements. --- Primitive_Operations (Elist15) --- Present in tagged record types and subtypes and in tagged private --- types. Points to an element list of entities for primitive operations --- for the tagged type. Not present (and not set) in untagged types (it --- is an error to reference the primitive operations field of a type --- that is not tagged). In order to fulfill the C++ ABI, entities of --- primitives that come from source must be stored in this list following --- their order of occurrence in the sources. Also present in incomplete --- types, but in this case the list is always empty. +-- Primitive_Operations (synthesized) +-- Present in concurrent types, tagged record types and subtypes, tagged +-- private types and tagged incomplete types. For concurrent types that +-- have available their Corresponding_Record_Type (CRT) returns the list +-- of Direct_Primitive_Operations of its CRT; otherwise returns No_Elist. +-- For all the other types returns its Direct_Primitive_Operations. -- Prival (Node17) -- Present in private components of protected types. Refers to the entity @@ -5262,7 +5269,7 @@ package Einfo is -- E_Private_Type -- E_Private_Subtype - -- Primitive_Operations (Elist15) + -- Direct_Primitive_Operations (Elist15) -- First_Entity (Node17) -- Private_Dependents (Elist18) -- Underlying_Full_View (Node19) @@ -5369,7 +5376,7 @@ package Einfo is -- E_Record_Type -- E_Record_Subtype - -- Primitive_Operations (Elist15) + -- Direct_Primitive_Operations (Elist15) -- Access_Disp_Table (Elist16) (base type only) -- Dispatch_Table_Wrappers (Elist26) (base type only) -- Cloned_Subtype (Node16) (subtype case only) @@ -5402,7 +5409,7 @@ package Einfo is -- E_Record_Type_With_Private -- E_Record_Subtype_With_Private - -- Primitive_Operations (Elist15) + -- Direct_Primitive_Operations (Elist15) -- Access_Disp_Table (Elist16) (base type only) -- Dispatch_Table_Wrappers (Elist26) (base type only) -- First_Entity (Node17) @@ -6072,7 +6079,7 @@ package Einfo is function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Postcondition_Proc (Id : E) return E; - function Primitive_Operations (Id : E) return L; + function Direct_Primitive_Operations (Id : E) return L; function Prival (Id : E) return E; function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; @@ -6248,8 +6255,9 @@ package Einfo is function Number_Dimensions (Id : E) return Pos; function Number_Entries (Id : E) return Nat; function Number_Formals (Id : E) return Pos; - function Root_Type (Id : E) return E; function Parameter_Mode (Id : E) return Formal_Kind; + function Primitive_Operations (Id : E) return L; + function Root_Type (Id : E) return E; function Scope_Depth_Set (Id : E) return B; function Size_Clause (Id : E) return N; function Stream_Size_Clause (Id : E) return N; @@ -6641,7 +6649,7 @@ package Einfo is procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Postcondition_Proc (Id : E; V : E); - procedure Set_Primitive_Operations (Id : E; V : L); + procedure Set_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Prival (Id : E; V : E); procedure Set_Prival_Link (Id : E; V : E); procedure Set_Private_Dependents (Id : E; V : L); @@ -7047,6 +7055,7 @@ package Einfo is pragma Inline (Dependent_Instances); pragma Inline (Depends_On_Private); pragma Inline (Digits_Value); + pragma Inline (Direct_Primitive_Operations); pragma Inline (Directly_Designated_Type); pragma Inline (Discard_Names); pragma Inline (Discriminal); @@ -7358,7 +7367,6 @@ package Einfo is pragma Inline (Parameter_Mode); pragma Inline (Parent_Subtype); pragma Inline (Postcondition_Proc); - pragma Inline (Primitive_Operations); pragma Inline (Prival); pragma Inline (Prival_Link); pragma Inline (Private_Dependents); @@ -7482,6 +7490,7 @@ package Einfo is pragma Inline (Set_Dependent_Instances); pragma Inline (Set_Depends_On_Private); pragma Inline (Set_Digits_Value); + pragma Inline (Set_Direct_Primitive_Operations); pragma Inline (Set_Directly_Designated_Type); pragma Inline (Set_Discard_Names); pragma Inline (Set_Discriminal); @@ -7748,7 +7757,6 @@ package Einfo is pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Postcondition_Proc); - pragma Inline (Set_Primitive_Operations); pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); Index: sem_ch8.adb =================================================================== --- sem_ch8.adb (revision 165614) +++ sem_ch8.adb (working copy) @@ -5707,7 +5707,7 @@ package body Sem_Ch8 is end if; Set_Is_Tagged_Type (T); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); Make_Class_Wide_Type (T); Set_Entity (N, Class_Wide_Type (T)); Set_Etype (N, Class_Wide_Type (T)); Index: sem_cat.adb =================================================================== --- sem_cat.adb (revision 165610) +++ sem_cat.adb (working copy) @@ -1334,6 +1334,12 @@ package body Sem_Cat is begin Desig_Type := Etype (Designated_Type (T)); + -- No action needed for concurrent types + + if Is_Concurrent_Type (Desig_Type) then + return; + end if; + Primitive_Subprograms := Primitive_Operations (Desig_Type); Subprogram_Elmt := First_Elmt (Primitive_Subprograms); Index: exp_dist.adb =================================================================== --- exp_dist.adb (revision 165610) +++ exp_dist.adb (working copy) @@ -1316,7 +1316,9 @@ package body Exp_Dist is -- Build callers, receivers for every primitive operations and a RPC -- receiver for this type. - if Present (Primitive_Operations (Designated_Type)) then + if not Is_Concurrent_Type (Designated_Type) + and then Present (Primitive_Operations (Designated_Type)) + then Overload_Counter_Table.Reset; Current_Primitive_Elmt := @@ -1336,8 +1338,9 @@ package body Exp_Dist is Is_TSS (Current_Primitive, TSS_Stream_Input) or else Is_TSS (Current_Primitive, TSS_Stream_Output) or else Is_TSS (Current_Primitive, TSS_Stream_Read) or else - Is_TSS (Current_Primitive, TSS_Stream_Write) or else - Is_Predefined_Interface_Primitive (Current_Primitive)) + Is_TSS (Current_Primitive, TSS_Stream_Write) + or else + Is_Predefined_Interface_Primitive (Current_Primitive)) and then not Is_Hidden (Current_Primitive) then -- The first thing to do is build an up-to-date copy of the @@ -1413,8 +1416,8 @@ package body Exp_Dist is RACW_Type => Stub_Elements.RACW_Type, Parent_Primitive => Current_Primitive); - Current_Receiver := Defining_Unit_Name ( - Specification (Current_Receiver_Body)); + Current_Receiver := + Defining_Unit_Name (Specification (Current_Receiver_Body)); Append_To (Body_Decls, Current_Receiver_Body); Index: lib-xref.adb =================================================================== --- lib-xref.adb (revision 165610) +++ lib-xref.adb (working copy) @@ -241,14 +241,7 @@ package body Lib.Xref is -- The check for Present here is to protect against previously -- reported critical errors. - if Is_Concurrent_Type (Base_T) - and then Present (Corresponding_Record_Type (Base_T)) - then - Prim_List := Primitive_Operations - (Corresponding_Record_Type (Base_T)); - else - Prim_List := Primitive_Operations (Base_T); - end if; + Prim_List := Primitive_Operations (Base_T); if No (Prim_List) then return; Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 165610) +++ exp_ch3.adb (working copy) @@ -6144,8 +6144,8 @@ package body Exp_Ch3 is (Rep, Access_Disp_Table (Def_Id)); Set_Dispatch_Table_Wrappers (Rep, Dispatch_Table_Wrappers (Def_Id)); - Set_Primitive_Operations - (Rep, Primitive_Operations (Def_Id)); + Set_Direct_Primitive_Operations + (Rep, Direct_Primitive_Operations (Def_Id)); end; end if;