From patchwork Tue May 16 08:40:22 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 94539 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:b0ea:0:b0:3b6:4342:cba0 with SMTP id b10csp275222vqo; Tue, 16 May 2023 01:54:48 -0700 (PDT) X-Google-Smtp-Source: ACHHUZ7ZA3w8KD+dkB1sROkWbYO6W11s+VhJx5aA8uTwWaRjZIOs4Vrr2KPDcM4BmY7ldwYkP5IN X-Received: by 2002:a50:ed99:0:b0:504:8929:71ca with SMTP id h25-20020a50ed99000000b00504892971camr29870706edr.6.1684227288021; Tue, 16 May 2023 01:54:48 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1684227288; cv=none; d=google.com; s=arc-20160816; b=w5aHOoDjqzrMktdU9i2gosOqbqviYVGNEUSFIqAtI2PoGLlyfYr/Q/gzuMfbzS5VrI 3gnER4hZNxkVYPFRA8jejgAR/OrK7qipEkPgvKGqvbw9hRmM7OaMhD//W+s9Fj3+yq3n vfHKrzWjF+gOq91XedebK8bmEhwfeBV878uQeEb4rhcCAWx81j7rlJrgfClWZ+U1ITFQ nJ6VxNoqJ2vFNz5ZunInDH+adxOMuAvSpMkFp5ivLBG903h8lfm4tDlEbNIdUWaQQ59c SfW+/+78udNqMvjLOcaGzzZctO4EGOsEjSfLBkhhx9BYo2t21q9duLmZA92dWlLjGZF4 JftQ== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence :content-transfer-encoding:mime-version:message-id:date:subject:cc :to:dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=CsVRIzOhhSp2lTy5fGOmNkGDDnW5J/6SIWnM2gJnGSg=; b=05ZktGpNFVBJ9hbNSpdMXcV616NDOgeQzx7/5QJYikT2QiJGwVx1Z3Tez0jLiT9nL2 z4A0q4ymM7k3rX7DSaGKheziCn7XIzhcimlefnJeOLrQtnGQtVsMjWAGMtSzuP6zc8fX IbcRqm5YzOZiWfyRQmearg5RG+V+tyt6hn7fIIh74pn/9+tZXGTccahzTha+EQwKNUOa LosKsj2Crm82Qiyv4igJ2AJ5WnoYnoP1hRPCqv/gb4FGcCBHj0TVPbtEZThlv4DRS8Ie LKDRLDluv5v5wHuUr5+P5SeBC+silosEayPlOpESxnvJIy1lIrTg62DEA1/3vYLU5PoD DAjg== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=cmPAGylO; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id n21-20020a056402515500b0050bf8da1ceesi12011966edd.543.2023.05.16.01.54.47 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 16 May 2023 01:54:48 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=cmPAGylO; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2E3DF3894C0C for ; Tue, 16 May 2023 08:47:38 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 2E3DF3894C0C DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1684226858; bh=CsVRIzOhhSp2lTy5fGOmNkGDDnW5J/6SIWnM2gJnGSg=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=cmPAGylOCJSYuDtqnDM0jagLLqM34uqShYpsj4cAQOZHfiulUy2n6+64vqdxwzN5i 8mGBmWr6ERAqkV8mabAbHO22rlhVjcdRUa8MxHaC9PArTZI2GCV3Z8RieZL1TVHKF+ bDDbxVa9aqi2iuJbENaGTmpqEOeV4ZQrqN6Qcfhk= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x332.google.com (mail-wm1-x332.google.com [IPv6:2a00:1450:4864:20::332]) by sourceware.org (Postfix) with ESMTPS id 2B7C53856DC3 for ; Tue, 16 May 2023 08:40:26 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2B7C53856DC3 Received: by mail-wm1-x332.google.com with SMTP id 5b1f17b1804b1-3f427118644so92984285e9.0 for ; Tue, 16 May 2023 01:40:25 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1684226424; x=1686818424; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=CsVRIzOhhSp2lTy5fGOmNkGDDnW5J/6SIWnM2gJnGSg=; b=b6JQYjJfudGCe/wgVept/gs5nzVS0i1sUeOblsy9t6eBxKy/kAOBRhhPMf06J3OE6J iZJ7sxun2j4nGENI+3445Sm3iSL7KZ99w9nspxM+soahvH0rTgvJ9Nvt9JggszAIAR2Z l6OELd8gZ0iThVVXADVRscBklxLN76d9ww+HVWwjQn2zgSZJjfUdveIcZ3EZ9HkpVdd5 DnI4DydKny/x+kW8jvGSzRzM6H7LJVYN4HNtnBAMfFQkQgzZJ3emO+2ozQlF9vOdtJz6 GsocQQ7sMbf9FwK9f6pyvt5UeL595kmz7fmQi5Q0GoR2zZBe1ziB6W3qCTufFzC8hpyM i4VA== X-Gm-Message-State: AC+VfDwwXoctz+/cEwQ0ZQ8VAmPZnfOStmmXbrsQ+jZ3eGqhesso2EGR eu05IbWSqV0uSyzYRy1j/y1KnOcP5eV/7qiUiOF1sw== X-Received: by 2002:a5d:4fd1:0:b0:2f4:e96e:3c86 with SMTP id h17-20020a5d4fd1000000b002f4e96e3c86mr30726914wrw.14.1684226424100; Tue, 16 May 2023 01:40:24 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id w9-20020adff9c9000000b00301a351a8d6sm1754426wrr.84.2023.05.16.01.40.23 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 16 May 2023 01:40:23 -0700 (PDT) To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Adjust semantics and implementation of storage models Date: Tue, 16 May 2023 10:40:22 +0200 Message-Id: <20230516084022.1501474-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: =?utf-8?q?Marc_Poulhi=C3=A8s_via_Gcc-patches?= From: =?utf-8?q?Marc_Poulhi=C3=A8s?= Reply-To: =?utf-8?q?Marc_Poulhi=C3=A8s?= Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1766040312571343490?= X-GMAIL-MSGID: =?utf-8?q?1766040312571343490?= From: Eric Botcazou This makes the following adjustments to the semantics and implementation of storage models in the compiler: 1. By-copy semantics in subprogram calls: when an object accessed with a nonnative storage model is passed as an actual parameter in a call to a subprogram, an intermediate copy made on the host is passed instead. 2. More generally, any additional temporary required on the host by the semantics of nonnative storage models is now created by the front-end instead of the code generator. 3. All the temporaries created on the host for nonnative storage models are allocated on the secondary stack instead of the primary stack. As a result, this should simplify the implementation in code generators. gcc/ada/ * exp_aggr.adb (Build_Assignment_With_Temporary): Adjust comment and fix type of second parameter. Create the temporary on the secondary stack by calling Build_Temporary_On_Secondary_Stack. (Convert_Array_Aggr_In_Allocator): Adjust formatting. (Expand_Array_Aggregate): Likewise. * exp_ch4.adb (Expand_N_Allocator): Set Actual_Designated_Subtype on the dereference in the initialization for all composite types. * exp_ch5.adb (Expand_N_Assignment_Statement): Create a temporary on the host for an assignment between nonnative storage models. Suppress more checks when Suppress_Assignment_Checks is set. * exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Deal with actuals that are dereferences with an Actual_Designated_Subtype. Add support for nonnative storage models. (Expand_Actuals): Create a copy if the actual is a dereference with a nonnative storage model. * exp_util.ads (Build_Temporary_On_Secondary_Stack): Declare. * exp_util.adb (Build_Temporary_On_Secondary_Stack): New function. * sem_ch5.adb (Analyze_Assignment.Set_Assignment_Type): Do not build an actual subtype for dereferences with an Actual_Designated_Subtype * sinfo.ads (Actual_Designated_Subtype): Adjust documentation. (Suppress_Assignment_Checks): Likewise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 51 +++++++++--------- gcc/ada/exp_ch4.adb | 52 +++++++++---------- gcc/ada/exp_ch5.adb | 58 +++++++++++++++++++-- gcc/ada/exp_ch6.adb | 121 ++++++++++++++++++++++++++++++++++++------- gcc/ada/exp_util.adb | 49 ++++++++++++++++++ gcc/ada/exp_util.ads | 12 +++++ gcc/ada/sem_ch5.adb | 9 ++-- gcc/ada/sinfo.ads | 4 +- 8 files changed, 274 insertions(+), 82 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index f1cbbfc3155..cf8bac0f4bf 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -62,7 +62,7 @@ with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; -use Sem_Util.Storage_Model_Support; + use Sem_Util.Storage_Model_Support; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; @@ -78,12 +78,10 @@ package body Exp_Aggr is function Build_Assignment_With_Temporary (Target : Node_Id; - Typ : Node_Id; + Typ : Entity_Id; Source : Node_Id) return List_Id; -- Returns a list of actions to assign Source to Target of type Typ using - -- an extra temporary: - -- Tmp := Source; - -- Target := Tmp; + -- an extra temporary, which can potentially be large. type Case_Bounds is record Choice_Lo : Node_Id; @@ -2524,33 +2522,33 @@ package body Exp_Aggr is function Build_Assignment_With_Temporary (Target : Node_Id; - Typ : Node_Id; + Typ : Entity_Id; Source : Node_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Source); Aggr_Code : List_Id; Tmp : Entity_Id; - Tmp_Decl : Node_Id; begin - Tmp := Make_Temporary (Loc, 'A', Source); - Tmp_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Tmp, - Object_Definition => New_Occurrence_Of (Typ, Loc)); - Set_No_Initialization (Tmp_Decl, True); + Aggr_Code := New_List; + + Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Aggr_Code); - Aggr_Code := New_List (Tmp_Decl); Append_To (Aggr_Code, Make_OK_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Tmp, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)), Expression => Source)); Append_To (Aggr_Code, Make_OK_Assignment_Statement (Loc, Name => Target, - Expression => New_Occurrence_Of (Tmp, Loc))); + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)))); + return Aggr_Code; end Build_Assignment_With_Temporary; @@ -4571,8 +4569,9 @@ package body Exp_Aggr is (Storage_Model_Object (Etype (Prefix (Expression (Target)))))) then - Aggr_Code := Build_Assignment_With_Temporary (Target, - Typ, New_Aggr); + Aggr_Code := + Build_Assignment_With_Temporary (Target, Typ, New_Aggr); + else Aggr_Code := New_List ( @@ -7139,20 +7138,20 @@ package body Exp_Aggr is (Storage_Model_Object (Etype (Prefix (Name (Parent_Node)))))) then - Aggr_Code := Build_Assignment_With_Temporary (Target, - Typ, New_Copy_Tree (N)); + Aggr_Code := Build_Assignment_With_Temporary + (Target, Typ, New_Copy_Tree (N)); + else if Maybe_In_Place_OK then return; end if; - Aggr_Code := - New_List ( - Make_Assignment_Statement (Loc, - Name => Target, - Expression => New_Copy_Tree (N))); - + Aggr_Code := New_List ( + Make_Assignment_Statement (Loc, + Name => Target, + Expression => New_Copy_Tree (N))); end if; + else Aggr_Code := Build_Array_Aggr_Code (N, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9558596ffa0..95b81fb8e53 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5066,13 +5066,12 @@ package body Exp_Ch4 is -- Add discriminants if discriminated type declare - Dis : Boolean := False; - Typ : Entity_Id := Empty; + Dis : Boolean := False; + Typ : Entity_Id := T; begin if Has_Discriminants (T) then Dis := True; - Typ := T; -- Type may be a private type with no visible discriminants -- in which case check full view if in scope, or the @@ -5115,30 +5114,6 @@ package body Exp_Ch4 is Set_Expression (N, New_Occurrence_Of (Typ, Loc)); end if; - -- When the designated subtype is unconstrained and - -- the allocator specifies a constrained subtype (or - -- such a subtype has been created, such as above by - -- Build_Default_Subtype), associate that subtype with - -- the dereference of the allocator's access value. - -- This is needed by the back end for cases where - -- the access type has a Designated_Storage_Model, - -- to support allocation of a host object of the right - -- size for passing to the initialization procedure. - - if not Is_Constrained (Dtyp) - and then Is_Constrained (Typ) - then - declare - Init_Deref : constant Node_Id := - Unqual_Conv (Init_Arg1); - begin - pragma Assert - (Nkind (Init_Deref) = N_Explicit_Dereference); - - Set_Actual_Designated_Subtype (Init_Deref, Typ); - end; - end if; - Discr := First_Elmt (Discriminant_Constraint (Typ)); while Present (Discr) loop Nod := Node (Discr); @@ -5161,6 +5136,29 @@ package body Exp_Ch4 is Next_Elmt (Discr); end loop; end if; + + -- When the designated subtype is unconstrained and + -- the allocator specifies a constrained subtype (or + -- such a subtype has been created, such as above by + -- Build_Default_Subtype), associate that subtype with + -- the dereference of the allocator's access value. + -- This is needed by the expander for cases where the + -- access type has a Designated_Storage_Model in order + -- to support allocation of a host object of the right + -- size for passing to the initialization procedure. + + if not Is_Constrained (Dtyp) + and then Is_Constrained (Typ) + then + declare + Deref : constant Node_Id := Unqual_Conv (Init_Arg1); + + begin + pragma Assert (Nkind (Deref) = N_Explicit_Dereference); + + Set_Actual_Designated_Subtype (Deref, Typ); + end; + end if; end; -- We set the allocator as analyzed so that when we analyze diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 0dbf2d55192..0c89856b58b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -59,6 +59,7 @@ with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; + use Sem_Util.Storage_Model_Support; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -2658,10 +2659,50 @@ package body Exp_Ch5 is Convert_Aggr_In_Assignment (N); Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); - return; end if; + -- An assignment between nonnative storage models requires creating an + -- intermediate temporary on the host, which can potentially be large. + + if Nkind (Lhs) = N_Explicit_Dereference + and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Lhs))) + and then Present (Storage_Model_Copy_To + (Storage_Model_Object (Etype (Prefix (Lhs))))) + and then Nkind (Rhs) = N_Explicit_Dereference + and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Rhs))) + and then Present (Storage_Model_Copy_From + (Storage_Model_Object (Etype (Prefix (Rhs))))) + then + declare + Assign_Code : List_Id; + Tmp : Entity_Id; + + begin + Assign_Code := New_List; + + Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Assign_Code); + + Append_To (Assign_Code, + Make_Assignment_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)), + Expression => Relocate_Node (Rhs))); + + Append_To (Assign_Code, + Make_Assignment_Statement (Loc, + Name => Relocate_Node (Lhs), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tmp, Loc)))); + + Insert_Actions (N, Assign_Code); + Rewrite (N, Make_Null_Statement (Loc)); + return; + end; + end if; + -- Apply discriminant check if required. If Lhs is an access type to a -- designated type with discriminants, we must always check. If the -- type has unknown discriminants, more elaborate processing below. @@ -2672,7 +2713,7 @@ package body Exp_Ch5 is -- Skip discriminant check if change of representation. Will be -- done when the change of representation is expanded out. - if not Crep then + if not Crep and then not Suppress_Assignment_Checks (N) then Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs); end if; @@ -2712,7 +2753,9 @@ package body Exp_Ch5 is Set_Etype (Lhs, Ubt); Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs)); - Apply_Discriminant_Check (Rhs, Ubt, Lhs); + if not Suppress_Assignment_Checks (N) then + Apply_Discriminant_Check (Rhs, Ubt, Lhs); + end if; Set_Etype (Lhs, Lt); end; @@ -2732,12 +2775,16 @@ package body Exp_Ch5 is then Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); - Apply_Discriminant_Check (Rhs, Typ, Lhs); + if not Suppress_Assignment_Checks (N) then + Apply_Discriminant_Check (Rhs, Typ, Lhs); + end if; elsif Is_Array_Type (Typ) and then Is_Constrained (Typ) then Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); - Apply_Length_Check (Rhs, Typ); + if not Suppress_Assignment_Checks (N) then + Apply_Length_Check (Rhs, Typ); + end if; end if; -- In the access type case, we need the same discriminant check, and @@ -2745,6 +2792,7 @@ package body Exp_Ch5 is elsif Is_Access_Type (Etype (Lhs)) and then Is_Constrained (Designated_Type (Etype (Lhs))) + and then not Suppress_Assignment_Checks (N) then if Has_Discriminants (Designated_Type (Etype (Lhs))) then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7abf25e3859..af7f75342fa 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -70,6 +70,7 @@ with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_SCIL; use Sem_SCIL; with Sem_Util; use Sem_Util; + use Sem_Util.Storage_Model_Support; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; @@ -1936,8 +1937,14 @@ package body Exp_Ch6 is ---------------------------------- procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is + With_Storage_Model : constant Boolean := + Nkind (Actual) = N_Explicit_Dereference + and then + Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))); + + Cpcod : List_Id; Decl : Node_Id; - F_Typ : Entity_Id := Etype (Formal); + F_Typ : Entity_Id; Incod : Node_Id; Indic : Node_Id; Lhs : Node_Id; @@ -1952,6 +1959,8 @@ package body Exp_Ch6 is return; end if; + F_Typ := Etype (Formal); + -- Handle formals whose type comes from the limited view if From_Limited_With (F_Typ) @@ -1960,12 +1969,21 @@ package body Exp_Ch6 is F_Typ := Non_Limited_View (F_Typ); end if; + -- Use the actual designated subtype for a dereference, if any + + if Nkind (Actual) = N_Explicit_Dereference + and then Present (Actual_Designated_Subtype (Actual)) + then + Indic := + New_Occurrence_Of (Actual_Designated_Subtype (Actual), Loc); + -- Use formal type for temp, unless formal type is an unconstrained -- array, in which case we don't have to worry about bounds checks, -- and we use the actual type, since that has appropriate bounds. - if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then + elsif Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then Indic := New_Occurrence_Of (Etype (Actual), Loc); + else Indic := New_Occurrence_Of (F_Typ, Loc); end if; @@ -1974,7 +1992,6 @@ package body Exp_Ch6 is Reset_Packed_Prefix; - Temp := Make_Temporary (Loc, 'T', Actual); Incod := Relocate_Node (Actual); Outcod := New_Copy_Tree (Incod); @@ -1990,7 +2007,10 @@ package body Exp_Ch6 is if Ekind (Formal) = E_Out_Parameter then Incod := Empty; - if Has_Discriminants (F_Typ) then + if Has_Discriminants (F_Typ) + and then (Nkind (Actual) /= N_Explicit_Dereference + or else No (Actual_Designated_Subtype (Actual))) + then Indic := New_Occurrence_Of (Etype (Actual), Loc); end if; @@ -2017,15 +2037,31 @@ package body Exp_Ch6 is end if; end if; - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => Indic, - Expression => Incod); + Cpcod := New_List; + + if With_Storage_Model then + Temp := + Build_Temporary_On_Secondary_Stack (Loc, Entity (Indic), Cpcod); + + if Present (Incod) then + Append_To (Cpcod, + Make_Assignment_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)), + Expression => Incod)); + Set_Suppress_Assignment_Checks (Last (Cpcod)); + end if; + + else + Temp := Make_Temporary (Loc, 'T', Actual); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => Indic, + Expression => Incod); - if Inside_Init_Proc - and then No (Incod) - then -- If the call is to initialize a component of a composite type, -- and the component does not depend on discriminants, use the -- actual type of the component. This is required in case the @@ -2035,23 +2071,42 @@ package body Exp_Ch6 is -- discriminant, the presence of the initialization in the -- declaration will generate an expression for the actual subtype. - Set_No_Initialization (Decl); - Set_Object_Definition (Decl, - New_Occurrence_Of (Etype (Actual), Loc)); + if Inside_Init_Proc and then No (Incod) then + Set_No_Initialization (Decl); + Set_Object_Definition (Decl, + New_Occurrence_Of (Etype (Actual), Loc)); + end if; + + Append_To (Cpcod, Decl); end if; - Insert_Action (N, Decl); + Insert_Actions (N, Cpcod); -- The actual is simply a reference to the temporary - Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); + if With_Storage_Model then + Rewrite (Actual, + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc))); + else + Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); + end if; + + Analyze (Actual); -- Generate copy out if OUT or IN OUT parameter if Ekind (Formal) /= E_In_Parameter then Lhs := Outcod; - Rhs := New_Occurrence_Of (Temp, Loc); - Set_Is_True_Constant (Temp, False); + + if With_Storage_Model then + Rhs := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)); + else + Rhs := New_Occurrence_Of (Temp, Loc); + Set_Is_True_Constant (Temp, False); + end if; -- Deal with conversion @@ -2064,6 +2119,7 @@ package body Exp_Ch6 is Make_Assignment_Statement (Loc, Name => Lhs, Expression => Rhs)); + Set_Suppress_Assignment_Checks (Last (Post_Call)); Set_Assignment_OK (Name (Last (Post_Call))); end if; end Add_Simple_Call_By_Copy_Code; @@ -2452,6 +2508,22 @@ package body Exp_Ch6 is elsif Is_Ref_To_Bit_Packed_Array (Actual) then Add_Simple_Call_By_Copy_Code (Force => True); + -- If the actual has a nonnative storage model, we need a copy + + elsif Nkind (Actual) = N_Explicit_Dereference + and then + Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))) + and then + (Present (Storage_Model_Copy_To + (Storage_Model_Object (Etype (Prefix (Actual))))) + or else + (Ekind (Formal) = E_In_Out_Parameter + and then + (Present (Storage_Model_Copy_From + (Storage_Model_Object (Etype (Prefix (Actual)))))))) + then + Add_Simple_Call_By_Copy_Code (Force => True); + -- If a nonscalar actual is possibly bit-aligned, we need a copy -- because the back-end cannot cope with such objects. In other -- cases where alignment forces a copy, the back-end generates @@ -2598,6 +2670,17 @@ package body Exp_Ch6 is elsif Is_Ref_To_Bit_Packed_Array (Actual) then Add_Simple_Call_By_Copy_Code (Force => True); + -- If the actual has a nonnative storage model, we need a copy + + elsif Nkind (Actual) = N_Explicit_Dereference + and then + Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual))) + and then + Present (Storage_Model_Copy_From + (Storage_Model_Object (Etype (Prefix (Actual))))) + then + Add_Simple_Call_By_Copy_Code (Force => True); + -- If we have a C++ constructor call, we need to create the object elsif Is_CPP_Constructor_Call (Actual) then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 80c01bf40fd..f010dac4978 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4699,6 +4699,55 @@ package body Exp_Util is return Build_Task_Image_Function (Loc, Decls, Stats, Res); end Build_Task_Record_Image; + ---------------------------------------- + -- Build_Temporary_On_Secondary_Stack -- + ---------------------------------------- + + function Build_Temporary_On_Secondary_Stack + (Loc : Source_Ptr; + Typ : Entity_Id; + Code : List_Id) return Entity_Id + is + Acc_Typ : Entity_Id; + Alloc : Node_Id; + Alloc_Obj : Entity_Id; + + begin + pragma Assert (RTE_Available (RE_SS_Pool) + and then not Needs_Finalization (Typ)); + + Acc_Typ := Make_Temporary (Loc, 'A'); + Mutate_Ekind (Acc_Typ, E_Access_Type); + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + + Append_To (Code, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Typ, Loc)))); + + Alloc := + Make_Allocator (Loc, Expression => New_Occurrence_Of (Typ, Loc)); + Set_No_Initialization (Alloc); + + Alloc_Obj := Make_Temporary (Loc, 'R'); + + Append_To (Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Acc_Typ, Loc), + Expression => Alloc)); + + Set_Uses_Sec_Stack (Current_Scope); + + return Alloc_Obj; + end Build_Temporary_On_Secondary_Stack; + --------------------------------------- -- Build_Transient_Object_Statements -- --------------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 3dd10d77cea..eef6800f371 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -351,6 +351,18 @@ package Exp_Util is -- is false, the call is for a stand-alone object, and the generated -- function itself must do its own cleanups. + function Build_Temporary_On_Secondary_Stack + (Loc : Source_Ptr; + Typ : Entity_Id; + Code : List_Id) return Entity_Id; + -- Build a temporary of type Typ on the secondary stack, appending the + -- necessary actions to Code, and return a constant holding the access + -- value designating this temporary, under the assumption that Typ does + -- not need finalization. + + -- This should be used when Typ can potentially be large, to avoid putting + -- too much pressure on the primary stack, for example with storage models. + procedure Build_Transient_Object_Statements (Obj_Decl : Node_Id; Fin_Call : out Node_Id; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index ab5a2083a00..27ab0b738cd 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -324,10 +324,13 @@ package body Sem_Ch5 is then Opnd_Type := Get_Actual_Subtype (Opnd); - -- If assignment operand is a component reference, then we get the - -- actual subtype of the component for the unconstrained case. + -- If the assignment operand is a component reference, then we build + -- the actual subtype of the component for the unconstrained case, + -- unless there is already one or the type is an unchecked union. - elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference + elsif (Nkind (Opnd) = N_Selected_Component + or else (Nkind (Opnd) = N_Explicit_Dereference + and then No (Actual_Designated_Subtype (Opnd)))) and then not Is_Unchecked_Union (Opnd_Type) then Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 6cacebe7775..ce54dd3fb91 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -830,7 +830,7 @@ package Sinfo is -- an unconstrained packed array and the dereference is the prefix of -- a 'Size attribute reference, or 2) when the dereference node is -- created for the expansion of an allocator with a subtype_indication - -- and the designated subtype is an unconstrained discriminated type. + -- and the designated subtype is an unconstrained composite type. -- Address_Warning_Posted -- Present in N_Attribute_Definition nodes. Set to indicate that we have @@ -2311,7 +2311,7 @@ package Sinfo is -- can be set in N_Object_Declaration nodes, to similarly suppress any -- checks on the initializing value. In assignment statements it also -- suppresses access checks in the generated code for out- and in-out - -- parameters in entry calls, as well as length checks. + -- parameters in entry calls, as well as discriminant and length checks. -- Suppress_Loop_Warnings -- Used in N_Loop_Statement node to indicate that warnings within the