From patchwork Mon Dec 12 12:00:06 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 130732 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 F17421007D1 for ; Mon, 12 Dec 2011 23:00:31 +1100 (EST) Received: (qmail 13917 invoked by alias); 12 Dec 2011 12:00:28 -0000 Received: (qmail 13891 invoked by uid 22791); 12 Dec 2011 12:00:24 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 12 Dec 2011 12:00:08 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 4538E2BB2B3; Mon, 12 Dec 2011 07:00:07 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id GwPk7kZbIgTQ; Mon, 12 Dec 2011 07:00:07 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 3BAEE2BB2B9; Mon, 12 Dec 2011 07:00:06 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 36D7D3FEE8; Mon, 12 Dec 2011 07:00:06 -0500 (EST) Date: Mon, 12 Dec 2011 07:00:06 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Store the value of 'alignment of tagged types in the TSD Message-ID: <20111212120006.GA8185@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 removes primitive 'alignment to tagged types. This value is now stored in the Type Specific Data record associated with each tagged type since it is information known at compile-time. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-12-12 Javier Miranda * a-tags.ads (Alignment): New TSD field. (Max_Predef_Prims): Value lowered to 15 (or 9 in case of configurable runtime) Update documentation of predefined primitives since Alignment has been removed. * exp_disp.ads Update documentation of slots of dispatching primitives. * exp_disp.adb (Default_Prim_Op_Position): Update slot values since alignment is no longer a predefined primitive. (Is_Predefined_Dispatch_Operation): Remove _alignment. (Is_Predefined_Internal_Operation): Remove _alignment. (Make_DT): Update static test on the value stored in a-tags.ads for Max_Predef_Prims; store the value of 'alignment in the TSD. * exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram that retrieves the alignment from the TSD * exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation of class-wide types obtain the value of alignment from the TSD. * exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment applied to a class-wide type invoke Build_Get_Alignment to generate code which retrieves the value of the alignment from the TSD. * rtsfind.ads (RE_Alignment): New Ada.Tags entity * sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged types if the value of the alignment is bigger than the Maximum alignment then set the value of the alignment to the Maximum alignment and report a warning. * exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate spec of _alignment. (Predefined_Primitive_Bodies): Do not generate body of _alignment. Index: exp_atag.adb =================================================================== --- exp_atag.adb (revision 182223) +++ exp_atag.adb (working copy) @@ -289,6 +289,25 @@ (RTE_Record_Component (RE_Access_Level), Loc)); end Build_Get_Access_Level; + ------------------------- + -- Build_Get_Alignment -- + ------------------------- + + function Build_Get_Alignment + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id + is + begin + return + Make_Selected_Component (Loc, + Prefix => + Build_TSD (Loc, + Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Alignment), Loc)); + end Build_Get_Alignment; + ------------------------------------------ -- Build_Get_Predefined_Prim_Op_Address -- ------------------------------------------ Index: exp_atag.ads =================================================================== --- exp_atag.ads (revision 182223) +++ exp_atag.ads (working copy) @@ -66,6 +66,13 @@ -- -- Generates: TSD (Tag).Access_Level + function Build_Get_Alignment + (Loc : Source_Ptr; + Tag_Node : Node_Id) return Node_Id; + -- Build code that retrieves the alignment of the tagged type. + -- + -- Generates: TSD (Tag).Alignment + procedure Build_Get_Predefined_Prim_Op_Address (Loc : Source_Ptr; Position : Uint; Index: exp_util.adb =================================================================== --- exp_util.adb (revision 182223) +++ exp_util.adb (working copy) @@ -755,8 +755,33 @@ Append_To (Actuals, New_Reference_To (Addr_Id, Loc)); Append_To (Actuals, New_Reference_To (Size_Id, Loc)); - Append_To (Actuals, New_Reference_To (Alig_Id, Loc)); + if Is_Allocate + or else not Is_Class_Wide_Type (Desig_Typ) + then + Append_To (Actuals, New_Reference_To (Alig_Id, Loc)); + + -- For deallocation of class wide types we obtain the value of + -- alignment from the Type Specific Record of the deallocated object. + -- This is needed because the frontend expansion of class-wide types + -- into equivalent types confuses the backend. + + else + -- Generate: + -- Obj.all'Alignment + + -- ... because 'Alignment applied to class-wide types is expanded + -- into the code that reads the value of alignment from the TSD + -- (see Expand_N_Attribute_Reference) + + Append_To (Actuals, + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, Relocate_Node (Expr)), + Attribute_Name => Name_Alignment))); + end if; + -- h) Is_Controlled -- Generate a run-time check to determine whether a class-wide object Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 182223) +++ exp_attr.adb (working copy) @@ -1120,19 +1120,11 @@ elsif Is_Class_Wide_Type (Ptyp) then - -- No need to do anything else compiling under restriction - -- No_Dispatching_Calls. During the semantic analysis we - -- already notified such violation. - - if Restriction_Active (No_Dispatching_Calls) then - return; - end if; - New_Node := - Make_Function_Call (Loc, - Name => New_Reference_To - (Find_Prim_Op (Ptyp, Name_uAlignment), Loc), - Parameter_Associations => New_List (Pref)); + Build_Get_Alignment (Loc, + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Tag)); if Typ /= Standard_Integer then Index: a-tags.ads =================================================================== --- a-tags.ads (revision 182223) +++ a-tags.ads (working copy) @@ -98,6 +98,8 @@ -- : primitive ops : +-------------------+ -- | pointers | | access level | -- +--------------------+ +-------------------+ + -- | alignment | + -- +-------------------+ -- | expanded name | -- +-------------------+ -- | external tag | @@ -269,6 +271,7 @@ -- function return, and class-wide stream I/O, the danger of objects -- outliving their type declaration can be eliminated (Ada 2005: AI-344) + Alignment : Natural; Expanded_Name : Cstring_Ptr; External_Tag : Cstring_Ptr; HT_Link : Tag_Ptr; @@ -545,25 +548,24 @@ procedure Unregister_Tag (T : Tag); -- Remove a particular tag from the external tag hash table - Max_Predef_Prims : constant Positive := 16; + Max_Predef_Prims : constant Positive := 15; -- Number of reserved slots for the following predefined ada primitives: -- -- 1. Size - -- 2. Alignment, - -- 3. Read - -- 4. Write - -- 5. Input - -- 6. Output - -- 7. "=" - -- 8. assignment - -- 9. deep adjust - -- 10. deep finalize - -- 11. async select - -- 12. conditional select - -- 13. prim_op kind - -- 14. task_id - -- 15. dispatching requeue - -- 16. timed select + -- 2. Read + -- 3. Write + -- 4. Input + -- 5. Output + -- 6. "=" + -- 7. assignment + -- 8. deep adjust + -- 9. deep finalize + -- 10. async select + -- 11. conditional select + -- 12. prim_op kind + -- 13. task_id + -- 14. dispatching requeue + -- 15. timed select -- -- The compiler checks that the value here is correct Index: rtsfind.ads =================================================================== --- rtsfind.ads (revision 182223) +++ rtsfind.ads (working copy) @@ -570,6 +570,7 @@ RE_Unbounded_String, -- Ada.Strings.Unbounded RE_Access_Level, -- Ada.Tags + RE_Alignment, -- Ada.Tags RE_Address_Array, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags RE_Base_Address, -- Ada.Tags @@ -1768,6 +1769,7 @@ RE_Unbounded_String => Ada_Strings_Unbounded, RE_Access_Level => Ada_Tags, + RE_Alignment => Ada_Tags, RE_Address_Array => Ada_Tags, RE_Addr_Ptr => Ada_Tags, RE_Base_Address => Ada_Tags, Index: exp_disp.adb =================================================================== --- exp_disp.adb (revision 182227) +++ exp_disp.adb (working copy) @@ -579,55 +579,52 @@ if Chars (E) = Name_uSize then return Uint_1; - elsif Chars (E) = Name_uAlignment then + elsif TSS_Name = TSS_Stream_Read then return Uint_2; - elsif TSS_Name = TSS_Stream_Read then + elsif TSS_Name = TSS_Stream_Write then return Uint_3; - elsif TSS_Name = TSS_Stream_Write then + elsif TSS_Name = TSS_Stream_Input then return Uint_4; - elsif TSS_Name = TSS_Stream_Input then + elsif TSS_Name = TSS_Stream_Output then return Uint_5; - elsif TSS_Name = TSS_Stream_Output then + elsif Chars (E) = Name_Op_Eq then return Uint_6; - elsif Chars (E) = Name_Op_Eq then + elsif Chars (E) = Name_uAssign then return Uint_7; - elsif Chars (E) = Name_uAssign then + elsif TSS_Name = TSS_Deep_Adjust then return Uint_8; - elsif TSS_Name = TSS_Deep_Adjust then + elsif TSS_Name = TSS_Deep_Finalize then return Uint_9; - elsif TSS_Name = TSS_Deep_Finalize then - return Uint_10; - -- In VM targets unconditionally allow obtaining the position associated -- with predefined interface primitives since in these platforms any -- tagged type has these primitives. elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then if Chars (E) = Name_uDisp_Asynchronous_Select then - return Uint_11; + return Uint_10; elsif Chars (E) = Name_uDisp_Conditional_Select then - return Uint_12; + return Uint_11; elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then - return Uint_13; + return Uint_12; elsif Chars (E) = Name_uDisp_Get_Task_Id then - return Uint_14; + return Uint_13; elsif Chars (E) = Name_uDisp_Requeue then - return Uint_15; + return Uint_14; elsif Chars (E) = Name_uDisp_Timed_Select then - return Uint_16; + return Uint_15; end if; end if; @@ -1945,7 +1942,6 @@ TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); if Chars (E) = Name_uSize - or else Chars (E) = Name_uAlignment or else TSS_Name = TSS_Stream_Read or else TSS_Name = TSS_Stream_Write or else TSS_Name = TSS_Stream_Input @@ -1991,7 +1987,6 @@ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); if Chars (E) = Name_uSize - or else Chars (E) = Name_uAlignment or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) @@ -4513,16 +4508,16 @@ end if; -- Ensure that the value of Max_Predef_Prims defined in a-tags is - -- correct. Valid values are 10 under configurable runtime or 16 + -- correct. Valid values are 9 under configurable runtime or 15 -- with full runtime. if RTE_Available (RE_Interface_Data) then - if Max_Predef_Prims /= 16 then + if Max_Predef_Prims /= 15 then Error_Msg_N ("run-time library configuration error", Typ); return Result; end if; else - if Max_Predef_Prims /= 10 then + if Max_Predef_Prims /= 9 then Error_Msg_N ("run-time library configuration error", Typ); Error_Msg_CRT ("tagged types", Typ); return Result; @@ -4846,6 +4841,7 @@ -- TSD : Type_Specific_Data (I_Depth) := -- (Idepth => I_Depth, -- Access_Level => Type_Access_Level (Typ), + -- Alignment => Typ'Alignment, -- Expanded_Name => Cstring_Ptr!(Exname'Address)) -- External_Tag => Cstring_Ptr!(Exname'Address)) -- HT_Link => HT_Link'Address, @@ -4895,6 +4891,23 @@ Append_To (TSD_Aggr_List, Make_Integer_Literal (Loc, Type_Access_Level (Typ))); + -- Alignment + + -- For CPP types we cannot rely on the value of 'Alignment provided + -- by the backend to initialize this TSD field. + + if Convention (Typ) = Convention_CPP + or else Is_CPP_Class (Root_Type (Typ)) + then + Append_To (TSD_Aggr_List, + Make_Integer_Literal (Loc, 0)); + else + Append_To (TSD_Aggr_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Typ, Loc), + Attribute_Name => Name_Alignment)); + end if; + -- Expanded_Name Append_To (TSD_Aggr_List, Index: exp_disp.ads =================================================================== --- exp_disp.ads (revision 182223) +++ exp_disp.ads (working copy) @@ -52,65 +52,61 @@ -- type. Constructs of the form Prefix'Size are converted into -- Prefix._Size. - -- _Alignment (2) - implementation of the attribute 'Alignment for - -- any tagged type. Constructs of the form Prefix'Alignment are - -- converted into Prefix._Alignment. - - -- TSS_Stream_Read (3) - implementation of the stream attribute Read + -- TSS_Stream_Read (2) - implementation of the stream attribute Read -- for any tagged type. - -- TSS_Stream_Write (4) - implementation of the stream attribute Write + -- TSS_Stream_Write (3) - implementation of the stream attribute Write -- for any tagged type. - -- TSS_Stream_Input (5) - implementation of the stream attribute Input + -- TSS_Stream_Input (4) - implementation of the stream attribute Input -- for any tagged type. - -- TSS_Stream_Output (6) - implementation of the stream attribute + -- TSS_Stream_Output (5) - implementation of the stream attribute -- Output for any tagged type. - -- Op_Eq (7) - implementation of the equality operator for any non- + -- Op_Eq (6) - implementation of the equality operator for any non- -- limited tagged type. - -- _Assign (8) - implementation of the assignment operator for any + -- _Assign (7) - implementation of the assignment operator for any -- non-limited tagged type. - -- TSS_Deep_Adjust (9) - implementation of the finalization operation + -- TSS_Deep_Adjust (8) - implementation of the finalization operation -- Adjust for any non-limited tagged type. - -- TSS_Deep_Finalize (10) - implementation of the finalization + -- TSS_Deep_Finalize (9) - implementation of the finalization -- operation Finalize for any non-limited tagged type. - -- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with + -- _Disp_Asynchronous_Select (10) - used in the expansion of ATC with -- dispatching triggers. Null implementation for limited interfaces, -- full body generation for types that implement limited interfaces, -- not generated for the rest of the cases. See Expand_N_Asynchronous_ -- Select in Exp_Ch9 for more information. - -- _Disp_Conditional_Select (12) - used in the expansion of conditional + -- _Disp_Conditional_Select (11) - used in the expansion of conditional -- selects with dispatching triggers. Null implementation for limited -- interfaces, full body generation for types that implement limited -- interfaces, not generated for the rest of the cases. See Expand_N_ -- Conditional_Entry_Call in Exp_Ch9 for more information. - -- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion + -- _Disp_Get_Prim_Op_Kind (12) - helper routine used in the expansion -- of ATC with dispatching triggers. Null implementation for limited -- interfaces, full body generation for types that implement limited -- interfaces, not generated for the rest of the cases. - -- _Disp_Get_Task_Id (14) - helper routine used in the expansion of + -- _Disp_Get_Task_Id (13) - helper routine used in the expansion of -- Abort, attributes 'Callable and 'Terminated for task interface -- class-wide types. Full body generation for task types, null -- implementation for limited interfaces, not generated for the rest -- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and -- Expand_N_Abort_Statement in Exp_Ch9 for more information. - -- _Disp_Requeue (15) - used in the expansion of dispatching requeue + -- _Disp_Requeue (14) - used in the expansion of dispatching requeue -- statements. Null implementation is provided for protected, task -- and synchronized interfaces. Protected and task types implementing -- concurrent interfaces receive full bodies. See Expand_N_Requeue_ -- Statement in Exp_Ch9 for more information. - -- _Disp_Timed_Select (16) - used in the expansion of timed selects + -- _Disp_Timed_Select (15) - used in the expansion of timed selects -- with dispatching triggers. Null implementation for limited -- interfaces, full body generation for types that implement limited -- interfaces, not generated for the rest of the cases. See Expand_N_ Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 182228) +++ sem_ch13.adb (working copy) @@ -2495,8 +2495,8 @@ -- Alignment attribute definition clause when Attribute_Alignment => Alignment : declare - Align : constant Uint := Get_Alignment_Value (Expr); - + Align : constant Uint := Get_Alignment_Value (Expr); + Max_Align : constant Uint := UI_From_Int (Maximum_Alignment); begin FOnly := True; @@ -2511,8 +2511,17 @@ elsif Align /= No_Uint then Set_Has_Alignment_Clause (U_Ent); - Set_Alignment (U_Ent, Align); + if Is_Tagged_Type (U_Ent) + and then Align > Max_Align + then + Error_Msg_N + ("?alignment for & set to Maximum_Aligment", Nam); + Set_Alignment (U_Ent, Max_Align); + else + Set_Alignment (U_Ent, Align); + end if; + -- For an array type, U_Ent is the first subtype. In that case, -- also set the alignment of the anonymous base type so that -- other subtypes (such as the itypes for aggregates of the Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 182223) +++ exp_ch3.adb (working copy) @@ -250,7 +250,6 @@ -- Dispatching is required in general, since the result of the attribute -- will vary with the actual object subtype. -- - -- _alignment provides result of 'Alignment attribute -- _size provides result of 'Size attribute -- typSR provides result of 'Read attribute -- typSW provides result of 'Write attribute @@ -8156,18 +8155,6 @@ Ret_Type => Standard_Long_Long_Integer)); - -- Spec of _Alignment - - Append_To (Res, Predef_Spec_Or_Body (Loc, - Tag_Typ => Tag_Typ, - Name => Name_uAlignment, - Profile => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), - Parameter_Type => New_Reference_To (Tag_Typ, Loc))), - - Ret_Type => Standard_Integer)); - -- Specs for dispatching stream attributes declare @@ -8740,29 +8727,6 @@ end loop; end if; - -- Body of _Alignment - - Decl := Predef_Spec_Or_Body (Loc, - Tag_Typ => Tag_Typ, - Name => Name_uAlignment, - Profile => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), - Parameter_Type => New_Reference_To (Tag_Typ, Loc))), - - Ret_Type => Standard_Integer, - For_Body => True); - - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_X), - Attribute_Name => Name_Alignment))))); - - Append_To (Res, Decl); - -- Body of _Size Decl := Predef_Spec_Or_Body (Loc,