From patchwork Mon Aug 19 08:39:01 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1149110 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-507223-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="aybNIduW"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 46BnSd3lX8z9sN4 for ; Mon, 19 Aug 2019 18:40:49 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=XBxSxsGGUBbiUCWfLC1kPNAJ4yeJrceQFJQfb6otTRUe85SNEH aT68LvW2qJlTycZUCmqsfudnrrlWEZjfMPgMvtpCeYPZQObIJzckYpsbCLKBZXhY pSt3zroOcQhoYUYHk9iz+KcPD62eFgXd4LGFSrTheOXC7P0REm2V+jlCw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=ZLrTJbHD1YKHGrU/msgMWppPfm4=; b=aybNIduWAYtMr9zNIMMs n2novzE+9qBacbPz4L964kFAIm1DWGOyjH3Ek2LtDn8OkZBgtYfIM792d7xPJoXM UnV0iJsplA/fKJH2gZT1rjGIB4zBRJodw40/nzid+TwIwA0j60OSZj6IvDe32hbY Q2xHvSDZ/dJ8w2Hx4Pe9Ciw= Received: (qmail 115854 invoked by alias); 19 Aug 2019 08:39:08 -0000 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 Received: (qmail 115792 invoked by uid 89); 19 Aug 2019 08:39:08 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy= X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 19 Aug 2019 08:39:04 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A6A7856052; Mon, 19 Aug 2019 04:39:01 -0400 (EDT) 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 IE3CBG0tW7S3; Mon, 19 Aug 2019 04:39:01 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 9442011619A; Mon, 19 Aug 2019 04:39:01 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 9333E6AB; Mon, 19 Aug 2019 04:39:01 -0400 (EDT) Date: Mon, 19 Aug 2019 04:39:01 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Buffer reading overflow in dispatch table initialization Message-ID: <20190819083901.GA33473@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes For tagged types not defined at library level that derive from library level tagged types the compiler may generate code to initialize their dispatch table of predefined primitives copying from the parent type data stored in memory after the dispatch table of the parent; that is, at runtime the initialization of dispatch tables overflows reading the parent dispatch table. This problem does not affect the execution of the program since the target dispatch table always has enough space to store the extra data, and after such copy the compiler generates code to complete the initialization of the dispatch table. The following test must compile and execute without errors. package pkg_a is type Root is tagged null record; end pkg_a; with pkg_a; procedure main is type Derived is new pkg_a.Root with null record; -- Test begin null; end main; Command: gnatmake -q main -fsanitize=address; ./main Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-19 Javier Miranda gcc/ada/ PR ada/65696 * exp_atag.ads, exp_atag.adb (Build_Inherit_Predefined_Prims): Adding formal to specify how many predefined primitives are inherited from the parent type. * exp_disp.adb (Number_Of_Predefined_Prims): New subprogram. (Make_Secondary_DT): Compute the number of predefined primitives of all tagged types (including tagged types not defined at library level). Previously we unconditionally relied on the Max_Predef_Prims constant value when building the dispatch tables of tagged types not defined at library level (thus consuming more memory for their dispatch tables than required). (Make_DT): Compute the number of predefined primitives that must be inherited from their parent type when building the dispatch tables of tagged types not defined at library level. Previously we unconditionally relied on the Max_Predef_Prims constant value when building the dispatch tables of tagged types not defined at library level (thus copying more data than required from the parent type). --- gcc/ada/exp_atag.adb +++ gcc/ada/exp_atag.adb @@ -742,9 +742,10 @@ package body Exp_Atag is ------------------------------------ function Build_Inherit_Predefined_Prims - (Loc : Source_Ptr; - Old_Tag_Node : Node_Id; - New_Tag_Node : Node_Id) return Node_Id + (Loc : Source_Ptr; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id; + Num_Predef_Prims : Int) return Node_Id is begin return @@ -759,7 +760,7 @@ package body Exp_Atag is New_Tag_Node)))), Discrete_Range => Make_Range (Loc, Make_Integer_Literal (Loc, Uint_1), - New_Occurrence_Of (RTE (RE_Max_Predef_Prims), Loc))), + Make_Integer_Literal (Loc, Num_Predef_Prims))), Expression => Make_Slice (Loc, @@ -772,7 +773,7 @@ package body Exp_Atag is Discrete_Range => Make_Range (Loc, Make_Integer_Literal (Loc, 1), - New_Occurrence_Of (RTE (RE_Max_Predef_Prims), Loc)))); + Make_Integer_Literal (Loc, Num_Predef_Prims)))); end Build_Inherit_Predefined_Prims; ------------------------- --- gcc/ada/exp_atag.ads +++ gcc/ada/exp_atag.ads @@ -109,9 +109,10 @@ package Exp_Atag is -- generated code handles primary and secondary dispatch tables of Typ. function Build_Inherit_Predefined_Prims - (Loc : Source_Ptr; - Old_Tag_Node : Node_Id; - New_Tag_Node : Node_Id) return Node_Id; + (Loc : Source_Ptr; + Old_Tag_Node : Node_Id; + New_Tag_Node : Node_Id; + Num_Predef_Prims : Int) return Node_Id; -- Build code that inherits the predefined primitives of the parent. -- -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := --- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -3817,6 +3817,9 @@ package body Exp_Disp is -- this secondary dispatch table by Make_Tags when its unique external -- name was generated. + function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat; + -- Returns the number of predefined primitives of Typ + ------------------------------ -- Check_Premature_Freezing -- ------------------------------ @@ -3970,12 +3973,10 @@ package body Exp_Disp is DT_Constr_List : List_Id; DT_Aggr_List : List_Id; Empty_DT : Boolean := False; - Nb_Predef_Prims : Nat := 0; Nb_Prim : Nat; New_Node : Node_Id; OSD : Entity_Id; OSD_Aggr_List : List_Id; - Pos : Nat; Prim : Entity_Id; Prim_Elmt : Elmt_Id; Prim_Ops_Aggr_List : List_Id; @@ -4022,38 +4023,12 @@ package body Exp_Disp is -- predef-prim-op-thunk-n'address); -- for Predef_Prims'Alignment use Address'Alignment - -- Stage 1: Calculate the number of predefined primitives - - if not Building_Static_DT (Typ) then - Nb_Predef_Prims := Max_Predef_Prims; - else - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Is_Predefined_Dispatching_Operation (Prim) - and then not Is_Abstract_Subprogram (Prim) - then - Pos := UI_To_Int (DT_Position (Prim)); - - if Pos > Nb_Predef_Prims then - Nb_Predef_Prims := Pos; - end if; - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end if; - - if Generate_SCIL then - Nb_Predef_Prims := 0; - end if; - - -- Stage 2: Create the thunks associated with the predefined - -- primitives and save their entity to fill the aggregate. + -- Create the thunks associated with the predefined primitives and + -- save their entity to fill the aggregate. declare - Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; + Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ); + Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id; Decl : Node_Id; Thunk_Id : Entity_Id; Thunk_Code : Node_Id; @@ -4525,6 +4500,44 @@ package body Exp_Disp is Append_Elmt (Iface_DT, DT_Decl); end Make_Secondary_DT; + -------------------------------- + -- Number_Of_Predefined_Prims -- + -------------------------------- + + function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat is + Nb_Predef_Prims : Nat := 0; + + begin + if not Generate_SCIL then + declare + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Pos : Nat; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Abstract_Subprogram (Prim) + then + Pos := UI_To_Int (DT_Position (Prim)); + + if Pos > Nb_Predef_Prims then + Nb_Predef_Prims := Pos; + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + + pragma Assert (Nb_Predef_Prims <= Max_Predef_Prims); + return Nb_Predef_Prims; + end Number_Of_Predefined_Prims; + -- Local variables Elab_Code : constant List_Id := New_List; @@ -4584,7 +4597,6 @@ package body Exp_Disp is I_Depth : Nat := 0; Iface_Table_Node : Node_Id; Name_ITable : Name_Id; - Nb_Predef_Prims : Nat := 0; Nb_Prim : Nat := 0; New_Node : Node_Id; Num_Ifaces : Nat := 0; @@ -5924,112 +5936,85 @@ package body Exp_Disp is else declare - Pos : Nat; + Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ); + Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id; + Decl : Node_Id; + E : Entity_Id; begin - if not Building_Static_DT (Typ) then - Nb_Predef_Prims := Max_Predef_Prims; + Prim_Ops_Aggr_List := New_List; + Prim_Table := (others => Empty); - else - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + if Building_Static_DT (Typ) then + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) + and then not Generate_SCIL + and then not Present (Prim_Table + (UI_To_Int (DT_Position (Prim)))) then - Pos := UI_To_Int (DT_Position (Prim)); - - if Pos > Nb_Predef_Prims then - Nb_Predef_Prims := Pos; - end if; + E := Ultimate_Alias (Prim); + pragma Assert (not Is_Abstract_Subprogram (E)); + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; Next_Elmt (Prim_Elmt); end loop; end if; - declare - Prim_Table : array - (Nat range 1 .. Nb_Predef_Prims) of Entity_Id; - Decl : Node_Id; - E : Entity_Id; - - begin - Prim_Ops_Aggr_List := New_List; - - Prim_Table := (others => Empty); - - if Building_Static_DT (Typ) then - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Is_Predefined_Dispatching_Operation (Prim) - and then not Is_Abstract_Subprogram (Prim) - and then not Is_Eliminated (Prim) - and then not Present (Prim_Table - (UI_To_Int (DT_Position (Prim)))) - then - E := Ultimate_Alias (Prim); - pragma Assert (not Is_Abstract_Subprogram (E)); - Prim_Table (UI_To_Int (DT_Position (Prim))) := E; - end if; - - Next_Elmt (Prim_Elmt); - end loop; + for J in Prim_Table'Range loop + if Present (Prim_Table (J)) then + New_Node := + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Prim_Table (J), Loc), + Attribute_Name => Name_Unrestricted_Access)); + else + New_Node := Make_Null (Loc); end if; - for J in Prim_Table'Range loop - if Present (Prim_Table (J)) then - New_Node := - Unchecked_Convert_To (RTE (RE_Prim_Ptr), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Prim_Table (J), Loc), - Attribute_Name => Name_Unrestricted_Access)); - else - New_Node := Make_Null (Loc); - end if; - - Append_To (Prim_Ops_Aggr_List, New_Node); - end loop; + Append_To (Prim_Ops_Aggr_List, New_Node); + end loop; - New_Node := - Make_Aggregate (Loc, - Expressions => Prim_Ops_Aggr_List); + New_Node := + Make_Aggregate (Loc, + Expressions => Prim_Ops_Aggr_List); - Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'S'), - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Address_Array), Loc)); + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address_Array), Loc)); - Append_To (Result, Decl); + Append_To (Result, Decl); - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => Predef_Prims, - Aliased_Present => True, - Constant_Present => Building_Static_DT (Typ), - Object_Definition => - New_Occurrence_Of (Defining_Identifier (Decl), Loc), - Expression => New_Node)); + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Predef_Prims, + Aliased_Present => True, + Constant_Present => Building_Static_DT (Typ), + Object_Definition => + New_Occurrence_Of (Defining_Identifier (Decl), Loc), + Expression => New_Node)); - -- Remember aggregates initializing dispatch tables + -- Remember aggregates initializing dispatch tables - Append_Elmt (New_Node, DT_Aggr); + Append_Elmt (New_Node, DT_Aggr); - Append_To (Result, - Make_Attribute_Definition_Clause (Loc, - Name => New_Occurrence_Of (Predef_Prims, Loc), - Chars => Name_Alignment, - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Integer_Address), Loc), - Attribute_Name => Name_Alignment))); - end; + Append_To (Result, + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (Predef_Prims, Loc), + Chars => Name_Alignment, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Integer_Address), Loc), + Attribute_Name => Name_Alignment))); end; -- Stage 1: Initialize the discriminant and the record components @@ -6301,7 +6286,9 @@ package body Exp_Disp is (Node (Next_Elmt (First_Elmt - (Access_Disp_Table (Typ)))), Loc))); + (Access_Disp_Table (Typ)))), Loc), + Num_Predef_Prims => + Number_Of_Predefined_Prims (Parent_Typ))); if Nb_Prims /= 0 then Append_To (Elab_Code, @@ -6390,7 +6377,10 @@ package body Exp_Disp is Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Next_Elmt (Sec_DT_Typ)), - Loc)))); + Loc)), + Num_Predef_Prims => + Number_Of_Predefined_Prims + (Parent_Typ))); if Num_Prims /= 0 then Append_To (Elab_Code, @@ -6436,7 +6426,10 @@ package body Exp_Disp is Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (Next_Elmt (Sec_DT_Typ)), - Loc)))); + Loc)), + Num_Predef_Prims => + Number_Of_Predefined_Prims + (Parent_Typ))); if Num_Prims /= 0 then Append_To (Elab_Code,