From patchwork Tue Aug 20 09:51:28 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: 1150005 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-507360-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="F88NqogF"; 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 46CR4V5N51z9s4Y for ; Tue, 20 Aug 2019 19:55:38 +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=yekRj7jO6AAG0WkOHL0nwiiAfYJ6tCHhsBnvK96AlOYA/pXLts h1H4AQDGKETsST0vkaLGlYEFQEv1LPF/Z05QSY5MsBirqlEwS+WfrPjOz9svdOn5 ilThA7m8oksWbVCpiPUNi98gCYVnn3ezj8ES0XdDYecUt6gl8ftlWzmt0= 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=QP+e6AuVaBfGZvjJaTnmuU2g5Mo=; b=F88NqogFhzqldiDDOxg/ j3EeIi3Rbmfw1/l88bCAIwDoSshkK5XHdBu2u6VM8LjNDxlPDklN+AxGdMXyJQZe sJLWFGbgm3UBhLcCWjw5fKYJFJFk6DVHz1pCJ4He8OXkq/b+9QHCCvoEqpYqRCS7 Zxs/vZImoNCPpc72/fa27MI= Received: (qmail 125105 invoked by alias); 20 Aug 2019 09:51:55 -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 122663 invoked by uid 89); 20 Aug 2019 09:51:35 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.7 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy=Limited, actions, Empty, Underlying_Type X-HELO: eggs.gnu.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (209.51.188.92) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 20 Aug 2019 09:51:31 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1i00nZ-0005Mg-DK for gcc-patches@gcc.gnu.org; Tue, 20 Aug 2019 05:51:30 -0400 Received: from rock.gnat.com ([2620:20:4000:0:a9e:1ff:fe9b:1d1]:55559) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1i00nZ-0005MP-7l for gcc-patches@gcc.gnu.org; Tue, 20 Aug 2019 05:51:29 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id E8C38560C6; Tue, 20 Aug 2019 05:51:28 -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 O6t+0iuZwuHd; Tue, 20 Aug 2019 05:51:28 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id D4F02560C4; Tue, 20 Aug 2019 05:51:28 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id D420D63E; Tue, 20 Aug 2019 05:51:28 -0400 (EDT) Date: Tue, 20 Aug 2019 05:51:28 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [Ada] Improve speed of discriminated return types Message-ID: <20190820095128.GA75578@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [fuzzy] X-Received-From: 2620:20:4000:0:a9e:1ff:fe9b:1d1 X-IsSubscribed: yes The compiler now generates faster code for functions that return discriminated types in many cases where the size is known at compile time. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-20 Bob Duff gcc/ada/ * exp_ch6.adb (Needs_BIP_Alloc_Form): Call Requires_Transient_Scope rather than checking constrainedness and so forth. We have previously improved Requires_Transient_Scope to return False in various cases, notably a limited record with an access discriminant. This change takes advantage of that to avoid using the secondary stack for functions returning such types. (Make_Build_In_Place_Call_In_Allocator): Be consistent by calling Needs_BIP_Alloc_Form rather than Is_Constrained and so forth. * sem_ch4.adb (Analyze_Allocator): The above change causes the compiler to generate code that is not legal Ada, in particular an uninitialized allocator for indefinite subtype. This is harmless, so we suppress the error message in this case. --- gcc/ada/exp_ch6.adb +++ gcc/ada/exp_ch6.adb @@ -5615,7 +5615,23 @@ package body Exp_Ch6 is Set_Comes_From_Extended_Return_Statement (Return_Stmt); Rewrite (N, Result); - Analyze (N, Suppress => All_Checks); + + declare + T : constant Entity_Id := Etype (Ret_Obj_Id); + begin + Analyze (N, Suppress => All_Checks); + + -- In some cases, analysis of N can set the Etype of an N_Identifier + -- to a subtype of the Etype of the Entity of the N_Identifier, which + -- gigi doesn't like. Reset the Etypes correctly here. + + if Nkind (Expression (Return_Stmt)) = N_Identifier + and then Entity (Expression (Return_Stmt)) = Ret_Obj_Id + then + Set_Etype (Ret_Obj_Id, T); + Set_Etype (Expression (Return_Stmt), T); + end if; + end; end Expand_N_Extended_Return_Statement; ---------------------------- @@ -8108,13 +8124,41 @@ package body Exp_Ch6 is -- since it is already attached on the related finalization master. -- Here and in related routines, we must examine the full view of the - -- type, because the view at the point of call may differ from that - -- that in the function body, and the expansion mechanism depends on + -- type, because the view at the point of call may differ from the + -- one in the function body, and the expansion mechanism depends on -- the characteristics of the full view. - if Is_Constrained (Underlying_Type (Result_Subt)) - and then not Needs_Finalization (Underlying_Type (Result_Subt)) - then + if Needs_BIP_Alloc_Form (Function_Id) then + Temp_Init := Empty; + + -- Case of a user-defined storage pool. Pass an allocation parameter + -- indicating that the function should allocate its result in the + -- pool, and pass the pool. Use 'Unrestricted_Access because the + -- pool may not be aliased. + + if Present (Associated_Storage_Pool (Acc_Type)) then + Alloc_Form := User_Storage_Pool; + Pool := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Associated_Storage_Pool (Acc_Type), Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- No user-defined pool; pass an allocation parameter indicating that + -- the function should allocate its result on the heap. + + else + Alloc_Form := Global_Heap; + Pool := Make_Null (No_Location); + end if; + + -- The caller does not provide the return object in this case, so we + -- have to pass null for the object access actual. + + Return_Obj_Actual := Empty; + + else -- Replace the initialized allocator of form "new T'(Func (...))" -- with an uninitialized allocator of form "new T", where T is the -- result subtype of the called function. The call to the function @@ -8163,35 +8207,6 @@ package body Exp_Ch6 is -- perform the allocation of the return object, so we pass parameters -- indicating that. - else - Temp_Init := Empty; - - -- Case of a user-defined storage pool. Pass an allocation parameter - -- indicating that the function should allocate its result in the - -- pool, and pass the pool. Use 'Unrestricted_Access because the - -- pool may not be aliased. - - if Present (Associated_Storage_Pool (Acc_Type)) then - Alloc_Form := User_Storage_Pool; - Pool := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Associated_Storage_Pool (Acc_Type), Loc), - Attribute_Name => Name_Unrestricted_Access); - - -- No user-defined pool; pass an allocation parameter indicating that - -- the function should allocate its result on the heap. - - else - Alloc_Form := Global_Heap; - Pool := Make_Null (No_Location); - end if; - - -- The caller does not provide the return object in this case, so we - -- have to pass null for the object access actual. - - Return_Obj_Actual := Empty; end if; -- Declare the temp object @@ -9279,30 +9294,8 @@ package body Exp_Ch6 is function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is pragma Assert (Is_Build_In_Place_Function (Func_Id)); Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); - begin - -- A build-in-place function needs to know which allocation form to - -- use when: - -- - -- 1) The result subtype is unconstrained. In this case, depending on - -- the context of the call, the object may need to be created in the - -- secondary stack, the heap, or a user-defined storage pool. - -- - -- 2) The result subtype is tagged. In this case the function call may - -- dispatch on result and thus needs to be treated in the same way as - -- calls to functions with class-wide results, because a callee that - -- can be dispatched to may have any of various result subtypes, so - -- if any of the possible callees would require an allocation form to - -- be passed then they all do. - -- - -- 3) The result subtype needs finalization actions. In this case, based - -- on the context of the call, the object may need to be created at - -- the caller site, in the heap, or in a user-defined storage pool. - - return - not Is_Constrained (Func_Typ) - or else Is_Tagged_Type (Func_Typ) - or else Needs_Finalization (Func_Typ); + return Requires_Transient_Scope (Func_Typ); end Needs_BIP_Alloc_Form; -------------------------------------- --- gcc/ada/sem_ch4.adb +++ gcc/ada/sem_ch4.adb @@ -796,25 +796,47 @@ package body Sem_Ch4 is ("\constraint with discriminant values required", N); end if; - -- Limited Ada 2005 and general nonlimited case + -- Limited Ada 2005 and general nonlimited case. + -- This is an error, except in the case of an + -- uninitialized allocator that is generated + -- for a build-in-place function return of a + -- discriminated but compile-time-known-size + -- type. else - Error_Msg_N - ("uninitialized unconstrained allocation not " - & "allowed", N); + if Original_Node (N) /= N + and then Nkind (Original_Node (N)) = N_Allocator + then + declare + Qual : constant Node_Id := + Expression (Original_Node (N)); + pragma Assert + (Nkind (Qual) = N_Qualified_Expression); + Call : constant Node_Id := Expression (Qual); + pragma Assert + (Is_Expanded_Build_In_Place_Call (Call)); + begin + null; + end; - if Is_Array_Type (Type_Id) then + else Error_Msg_N - ("\qualified expression or constraint with " - & "array bounds required", N); + ("uninitialized unconstrained allocation not " + & "allowed", N); - elsif Has_Unknown_Discriminants (Type_Id) then - Error_Msg_N ("\qualified expression required", N); + if Is_Array_Type (Type_Id) then + Error_Msg_N + ("\qualified expression or constraint with " + & "array bounds required", N); - else pragma Assert (Has_Discriminants (Type_Id)); - Error_Msg_N - ("\qualified expression or constraint with " - & "discriminant values required", N); + elsif Has_Unknown_Discriminants (Type_Id) then + Error_Msg_N ("\qualified expression required", N); + + else pragma Assert (Has_Discriminants (Type_Id)); + Error_Msg_N + ("\qualified expression or constraint with " + & "discriminant values required", N); + end if; end if; end if; end if;