From patchwork Thu Apr 27 08:51:34 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 755900 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3wD9g00Mffz9s7v for ; Thu, 27 Apr 2017 18:51:55 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="KFHFDIuj"; dkim-atps=neutral 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=yqTT7cVZr3bCIdxRFR2gOLObkjEsJqBQbMOLlTBv/HBZCfG5bn ZmXzaC+gLYS9bYNdWxIIKOm/1fUVYE1AdqKYrviKz1/nb+UK33/RC0FhcZ4IXzDv TLh5lx2eCzpp8q+JY5NAH9yquXBFK04tQZmBQIb8/5CyDj1VJE9TqzxUo= 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=UiIgR8jiXG6iijn9y2fzYEjqYQA=; b=KFHFDIujkY7csq/WI925 lqu9FeAG85f5+EveCOX+8RqZB2WaYZIyfWaJx/m6WCARMRGH5UD00Qs2/4ezgoRZ xEk7fwyUT8U7mjgb2FVqmjBfs1KXgH5IOm9TWGaHKgjRFc1vYqJQqT3hVG0b4UH2 OdlvPsogS39zbdkYn8Qu0+8= Received: (qmail 26967 invoked by alias); 27 Apr 2017 08:51:38 -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 26889 invoked by uid 89); 27 Apr 2017 08:51:37 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-10.2 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=dr, gray, Forces, dv 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; Thu, 27 Apr 2017 08:51:33 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 5D24E3E83; Thu, 27 Apr 2017 04:51:34 -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 3EBriNAR5V0r; Thu, 27 Apr 2017 04:51:34 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 4ABC63E05; Thu, 27 Apr 2017 04:51:34 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 48F0B4F9; Thu, 27 Apr 2017 04:51:34 -0400 (EDT) Date: Thu, 27 Apr 2017 04:51:34 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Finer grained secondary stack management Message-ID: <20170427085134.GA76673@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch has several effects: 1) The management of the secondary stack is now "tighter". A transient block created for the purpose of managing the secondary stack will do so unless the block appears within a function returning on the secondary stack or when 2) is in effect. Previously, due to some questionable logic, the management was left to the nearest enclosing scoping construct and not the block even though the block was created to manage the secondary stack in the first place. 2) Switch -gnatd.s now controls an optimization where a transient block created for the purpose of managing the secondary stack will no longer manage the secondary stack when there is an enclosing scoping construct which already does so. ------------ -- Source -- ------------ -- pack.ads package Pack is type Truth_Array is array (Positive range <>) of Boolean; procedure Diagnose_Truth (Val : Truth_Array); function Diagnose_Truth (Val : Truth_Array) return Boolean; function Invert_Truth (Val : Truth_Array) return Truth_Array; function Is_All_False (Val : Truth_Array) return Boolean; function Is_All_True (Val : Truth_Array) return Boolean; function Is_Gray_Area (Val : Truth_Array) return Boolean; function Make_Truth (Ts : Natural; Fs : Natural) return Truth_Array; end Pack; -- pack.adb with Ada.Text_IO; use Ada.Text_IO; package body Pack is procedure Diagnose_Truth (Val : Truth_Array) is begin if Is_All_False (Val) then Put_Line (" it is all lies"); elsif Is_All_True (Val) then Put_Line (" it is all true"); elsif Is_Gray_Area (Val) then Put_Line (" 50 shades of gray"); else Put_Line (" truth not found"); end if; end Diagnose_Truth; function Diagnose_Truth (Val : Truth_Array) return Boolean is begin Diagnose_Truth (Val); return True; end Diagnose_Truth; function Invert_Truth (Val : Truth_Array) return Truth_Array is Result : Truth_Array := Val; begin for Index in Result'Range loop Result (Index) := not Val (Index); end loop; return Result; end Invert_Truth; function Is_All_False (Val : Truth_Array) return Boolean is Has_True : Boolean := False; Is_Empty : Boolean := True; begin for Index in Val'Range loop Is_Empty := False; if Val (Index) then Has_True := True; exit; end if; end loop; return not Is_Empty and not Has_True; end Is_All_False; function Is_All_True (Val : Truth_Array) return Boolean is Has_False : Boolean := False; Is_Empty : Boolean := True; begin for Index in Val'Range loop Is_Empty := False; if not Val (Index) then Has_False := True; exit; end if; end loop; return not Is_Empty and not Has_False; end Is_All_True; function Is_Gray_Area (Val : Truth_Array) return Boolean is Has_False : Boolean := False; Has_True : Boolean := False; Is_Empty : Boolean := True; begin for Index in Val'Range loop Is_Empty := False; if Val (Index) then Has_True := True; else Has_False := True; end if; end loop; return not Is_Empty and Has_False and Has_True; end Is_Gray_Area; function Make_Truth (Ts : Natural; Fs : Natural) return Truth_Array is Result : Truth_Array (1 .. Ts + Fs) := (others => False); begin for Index in 1 .. Ts loop Result (Index) := True; end loop; return Result; end Make_Truth; end Pack; -- optimization.adb with Ada.Text_IO; use Ada.Text_IO; with Pack; use Pack; pragma Warnings (Off); with System.Secondary_Stack; use System.Secondary_Stack; pragma Warnings (On); procedure Optimization is procedure Leaks (Val : Boolean) is Obj : constant Truth_Array := Make_Truth (100_000, 0); begin if Val then Diagnose_Truth (Invert_Truth (Make_Truth (0, 100_000))); end if; end Leaks; SS_Before : constant Mark_Id := SS_Mark; begin Leaks (True); if SS_Mark = SS_Before then Put_Line ("OK"); else Put_Line ("ERROR: secondary stack not reclaimed"); end if; end Optimization; ---------------------------- -- Compilation and output -- (only relevant parts shown) ---------------------------- $ gnatmake -q -f -gnatG -gnatdI optimization.adb $ ./optimization $ gnatmake -q -f -gnatG -gnatdI optimization.adb -gnatd.s $ ./optimization procedure optimization__leaks (val : boolean) is M...b : constant system__secondary_stack__mark_id := $system__secondary_stack__ss_mark; procedure optimization__leaks___finalizer; procedure optimization__leaks___finalizer is begin $system__secondary_stack__ss_release (M...b); return; end optimization__leaks___finalizer; begin type optimization__leaks__A...b is access all pack__truth_array; R...b : constant optimization__leaks__A...b := pack__make_truth ( 100000, 0)'reference; B...b : constant integer := R...b.all'first(1); B...b : constant integer := R...b.all'last(1); subtype optimization__leaks__TobjS is pack__truth_array (B...b .. B...b); [constraint_error when B...b >= B...b and then (B...b < 1) "range check failed"] obj : pack__truth_array renames R...b.all; if val then B...b : declare M...b : constant system__secondary_stack__mark_id := $system__secondary_stack__ss_mark; procedure optimization__leaks__B...b___finalizer; procedure optimization__leaks__B...b___finalizer is begin $system__secondary_stack__ss_release (M...b); return; end optimization__leaks__B...b___finalizer; begin pack__diagnose_truth (pack__invert_truth (pack__make_truth (0, 100000))); at end optimization__leaks__B...b___finalizer; end B...b; end if; return; at end optimization__leaks___finalizer; end optimization__leaks; it is all true OK procedure optimization__leaks (val : boolean) is M...b : constant system__secondary_stack__mark_id := $system__secondary_stack__ss_mark; procedure optimization__leaks___finalizer; procedure optimization__leaks___finalizer is begin $system__secondary_stack__ss_release (M...b); return; end optimization__leaks___finalizer; begin type optimization__leaks__A...b is access all pack__truth_array; R...b : constant optimization__leaks__A...b := pack__make_truth ( 100000, 0)'reference; B...b : constant integer := R...b.all'first(1); B...b : constant integer := R...b.all'last(1); subtype optimization__leaks__TobjS is pack__truth_array (B...b .. B...b); [constraint_error when B...b >= B...b and then (B...b < 1) "range check failed"] obj : pack__truth_array renames R...b.all; if val then B...b : declare begin pack__diagnose_truth (pack__invert_truth (pack__make_truth (0, 100000))); end B...b; end if; return; at end optimization__leaks___finalizer; end optimization__leaks; it is all true OK Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-27 Hristian Kirtchev * debug.adb: Document the use of switch -gnatd.s. * einfo.ads Update the documentation on attribute Sec_Stack_Needed_For_Return and attribute Uses_Sec_Stack. Remove the uses of these attributes from certain entities. * exp_ch7.adb (Make_Transient_Block): Reimplement the circuitry which determines whether the block should continue to manage the secondary stack. (Manages_Sec_Stack): New routine. Index: debug.adb =================================================================== --- debug.adb (revision 247293) +++ debug.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -109,7 +109,7 @@ -- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133) -- d.q Suppress optimizations on imported 'in' -- d.r Enable OK_To_Reorder_Components in non-variant records - -- d.s + -- d.s Minimize secondary stack Mark and Release calls -- d.t Disable static allocation of library level dispatch tables -- d.u Enable Modify_Tree_For_C (update tree for c) -- d.v Enable OK_To_Reorder_Components in variant records @@ -572,6 +572,11 @@ -- d.r Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have no discriminants. + -- d.s The compiler does not generate calls to secondary stack management + -- routines SS_Mark and SS_Release for a transient block when there is + -- an enclosing scoping construct which already manages the secondary + -- stack. + -- d.t The compiler has been modified (a fairly extensive modification) -- to generate static dispatch tables for library level tagged types. -- This debug switch disables this modification and reverts to the Index: einfo.ads =================================================================== --- einfo.ads (revision 247293) +++ einfo.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -4163,10 +4163,10 @@ -- needed, since returns an invalid value in this case. -- Sec_Stack_Needed_For_Return (Flag167) --- Defined in scope entities (blocks, functions, procedures, tasks, --- entries). Set to True when secondary stack is used to hold the --- returned value of a function and thus should not be released on --- scope exit. +-- Defined in scope entities (blocks, entries, entry families, functions, +-- and procedures). Set to True when secondary stack is used to hold the +-- returned value of a function and thus should not be released on scope +-- exit. -- Shadow_Entities (List14) -- Defined in package and generic package entities. Points to a list @@ -4522,9 +4522,10 @@ -- Protection object (see System.Tasking.Protected_Objects). -- Uses_Sec_Stack (Flag95) --- Defined in scope entities (block, entry, function, loop, procedure, --- task). Set to True when secondary stack is used in this scope and must --- be released on exit unless Sec_Stack_Needed_For_Return is set. +-- Defined in scope entities (blocks, entries, entry families, functions, +-- loops, and procedures). Set to True when the secondary stack is used +-- in this scope and must be released on exit unless flag +-- Sec_Stack_Needed_For_Return is set. -- Validated_Object (Node36) -- Defined in variables. Contains the object whose value is captured by @@ -6442,11 +6443,9 @@ -- SPARK_Pragma (Node40) -- SPARK_Aux_Pragma (Node41) -- Ignore_SPARK_Mode_Pragmas (Flag301) - -- Sec_Stack_Needed_For_Return (Flag167) ??? -- SPARK_Aux_Pragma_Inherited (Flag266) -- SPARK_Pragma_Inherited (Flag265) -- Uses_Lock_Free (Flag188) - -- Uses_Sec_Stack (Flag95) ??? -- First_Component (synth) -- First_Component_Or_Discriminant (synth) -- Has_Entries (synth) @@ -6597,10 +6596,8 @@ -- Has_Master_Entity (Flag21) -- Has_Storage_Size_Clause (Flag23) (base type only) -- Ignore_SPARK_Mode_Pragmas (Flag301) - -- Sec_Stack_Needed_For_Return (Flag167) ??? -- SPARK_Aux_Pragma_Inherited (Flag266) -- SPARK_Pragma_Inherited (Flag265) - -- Uses_Sec_Stack (Flag95) ??? -- First_Component (synth) -- First_Component_Or_Discriminant (synth) -- Has_Entries (synth) Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 247293) +++ exp_ch7.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -8266,83 +8266,115 @@ Action : Node_Id; Par : Node_Id) return Node_Id is - Decls : constant List_Id := New_List; - Instrs : constant List_Id := New_List (Action); + function Manages_Sec_Stack (Id : Entity_Id) return Boolean; + -- Determine whether scoping entity Id manages the secondary stack + + ----------------------- + -- Manages_Sec_Stack -- + ----------------------- + + function Manages_Sec_Stack (Id : Entity_Id) return Boolean is + begin + -- An exception handler with a choice parameter utilizes a dummy + -- block to provide a declarative region. Such a block should not be + -- considered because it never manifests in the tree and can never + -- release the secondary stack. + + if Ekind (Id) = E_Block + and then Uses_Sec_Stack (Id) + and then not Is_Exception_Handler (Id) + then + return True; + + -- Loops are intentionally excluded because they undergo special + -- treatment, see Establish_Transient_Scope. + + elsif Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure) + and then Uses_Sec_Stack (Id) + then + return True; + + else + return False; + end if; + end Manages_Sec_Stack; + + -- Local variables + + Decls : constant List_Id := New_List; + Instrs : constant List_Id := New_List (Action); + Trans_Id : constant Entity_Id := Current_Scope; + Block : Node_Id; Insert : Node_Id; + Scop : Entity_Id; + -- Start of processing for Make_Transient_Block + begin - -- Case where only secondary stack use is involved + -- Even though the transient block is tasked with managing the secondary + -- stack, the block may forgo this functionality depending on how the + -- secondary stack is managed by enclosing scopes. - if Uses_Sec_Stack (Current_Scope) - and then Nkind (Action) /= N_Simple_Return_Statement - and then Nkind (Par) /= N_Exception_Handler - then - declare - S : Entity_Id; + if Manages_Sec_Stack (Trans_Id) then - begin - S := Scope (Current_Scope); - loop - -- At the outer level, no need to release the sec stack + -- Determine whether an enclosing scope already manages the secondary + -- stack. - if S = Standard_Standard then - Set_Uses_Sec_Stack (Current_Scope, False); - exit; + Scop := Scope (Trans_Id); + while Present (Scop) loop + if Scop = Standard_Standard then + exit; - -- In a function, only release the sec stack if the function - -- does not return on the sec stack otherwise the result may - -- be lost. The caller is responsible for releasing. + -- The transient block must manage the secondary stack when the + -- block appears within a loop in order to reclaim the memory at + -- each iteration. - elsif Ekind (S) = E_Function then - Set_Uses_Sec_Stack (Current_Scope, False); + elsif Ekind (Scop) = E_Loop then + exit; - if not Requires_Transient_Scope (Etype (S)) then - Set_Uses_Sec_Stack (S, True); - Check_Restriction (No_Secondary_Stack, Action); - end if; + -- The transient block is within a function which returns on the + -- secondary stack. Take a conservative approach and assume that + -- the value on the secondary stack is part of the result. Note + -- that it is not possible to detect this dependency without flow + -- analysis which the compiler does not have. Letting the object + -- live longer than the transient block will not leak any memory + -- because the caller will reclaim the total storage used by the + -- function. - exit; + elsif Ekind (Scop) = E_Function + and then Sec_Stack_Needed_For_Return (Scop) + then + Set_Uses_Sec_Stack (Trans_Id, False); + exit; - -- In a loop or entry we should install a block encompassing - -- all the construct. For now just release right away. + -- When requested, the transient block does not need to manage the + -- secondary stack when there exists an enclosing block, entry, + -- entry family, function, or a procedure which already does that. + -- This optimization saves on SS_Mark and SS_Release calls but may + -- allow objects to live a little longer than required. - elsif Ekind_In (S, E_Entry, E_Loop) then - exit; + elsif Debug_Flag_Dot_S and then Manages_Sec_Stack (Scop) then + Set_Uses_Sec_Stack (Trans_Id, False); + exit; + end if; - -- In a procedure or a block, release the sec stack on exit - -- from the construct. Note that an exception handler with a - -- choice parameter requires a declarative region in the form - -- of a block. The block does not physically manifest in the - -- tree as it only serves as a scope. Do not consider such a - -- block because it will never release the sec stack. - - -- ??? Memory leak can be created by recursive calls - - elsif Ekind (S) = E_Procedure - or else (Ekind (S) = E_Block - and then not Is_Exception_Handler (S)) - then - Set_Uses_Sec_Stack (Current_Scope, False); - Set_Uses_Sec_Stack (S, True); - Check_Restriction (No_Secondary_Stack, Action); - exit; - - else - S := Scope (S); - end if; - end loop; - end; + Scop := Scope (Scop); + end loop; end if; -- Create the transient block. Set the parent now since the block itself - -- is not part of the tree. The current scope is the E_Block entity - -- that has been pushed by Establish_Transient_Scope. + -- is not part of the tree. The current scope is the E_Block entity that + -- has been pushed by Establish_Transient_Scope. - pragma Assert (Ekind (Current_Scope) = E_Block); + pragma Assert (Ekind (Trans_Id) = E_Block); + Block := Make_Block_Statement (Loc, - Identifier => New_Occurrence_Of (Current_Scope, Loc), + Identifier => New_Occurrence_Of (Trans_Id, Loc), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), @@ -8357,8 +8389,9 @@ (Action, Clean => False, Manage_SS => False); Insert := Prev (Action); + if Present (Insert) then - Freeze_All (First_Entity (Current_Scope), Insert); + Freeze_All (First_Entity (Trans_Id), Insert); end if; -- Transfer cleanup actions to the newly created block