From patchwork Fri Jul 18 09:05:18 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 371370 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 28178140132 for ; Fri, 18 Jul 2014 19:05:34 +1000 (EST) 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=Cq1klozJFUzK/i3UNxMUZU1juLE9tZBVJi68ve+LYy8Ep1vsDH VxQV7jkMaaRW2503wzpHEGZ4ZpA9NVq7+USN5sNjiqd7xhElD/kxKkO7l19bbvgk g3zNdydSKJIpYvLU9YK7Zk7nSCEYJ8zcX7ADS+yGlQTWIowHjYvvb/6Ek= 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=RPVWCfWjs6cczTbgXLeDumKWyyU=; b=VH3qEpprZ/ebLy6Tp9B5 KaA8Z8qOtPMnYBm3CsIXf2GvU8pyEELoX8fTRevDzoosFvFJXPWBOE1+sE0Dm8Mi KVxt7fsTe3gl62kjW3ioq59GNzMcysQ47Ut0KEo2ivnSqtMMiEJwmlrPWeXteu5m tMUb1aljZtNQmdoLss9AJDA= Received: (qmail 16086 invoked by alias); 18 Jul 2014 09:05:26 -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 15871 invoked by uid 89); 18 Jul 2014 09:05:24 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham version=3.3.2 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 (AES256-SHA encrypted) ESMTPS; Fri, 18 Jul 2014 09:05:20 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 4D0F9116293; Fri, 18 Jul 2014 05:05:18 -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 46QwobTeXfio; Fri, 18 Jul 2014 05:05:18 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [IPv6:2620:20:4000:0:a6ba:dbff:fe26:1f63]) by rock.gnat.com (Postfix) with ESMTP id 395F2116269; Fri, 18 Jul 2014 05:05:18 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 33E183FE21; Fri, 18 Jul 2014 05:05:18 -0400 (EDT) Date: Fri, 18 Jul 2014 05:05:18 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Implement No_Standard_Allocators_After_Elaboration Message-ID: <20140718090518.GA3394@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15) This implements the final definition of the Ada 2012 restriction No_Standard_Allocators_After_Elaboration. There are two static cases. First appearence in task body, this one we already had before (compiled with -gnatj55 -gnatld7) 1. procedure Pmain2 is 2. type P is access all Integer; 3. PV : P; 4. task X; 5. task body X is 6. begin 7. PV := new Integer; | >>> violation of restriction "No_Standard_Allocators_After_Elaboration" at gnat.adc:1 8. end; 9. begin 10. null; 11. end; Second, also a static case, appearence in a parameterless library level procedure (same switches) 1. procedure Pmain is 2. type R is access all Integer; 3. RV : R; 4. begin 5. RV := new Integer; | >>> violation of restriction "No_Standard_Allocators_After_Elaboration" at gnat.adc:1 6. end; Finally the dynamic case tested at run-time: 1. with Allocate_After_Elab; 2. procedure Allocate_After_Elab_Test is 3. begin 4. Allocate_After_Elab (42); 5. end Allocate_After_Elab_Test; 1. with Ada.Text_IO; 2. procedure Allocate_After_Elab (X : Integer) is 3. type Int_Ptr_Type is access Integer; 4. My_Int_Ptr : Int_Ptr_Type; 5. begin 6. My_Int_Ptr := new Integer'(X); 7. Ada.Text_IO.Put_Line ("Have used allocator"); 8. end Allocate_After_Elab; If we run Allocate_After_Elab_Test, we get: raised PROGRAM_ERROR : standard allocator after elaboration is complete is not allowed (No_Standard_Allocators_After_Elaboration restriction active) Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-18 Robert Dewar * gcc-interface/Make-lang.in: Add entry for s-elaall.o * bcheck.adb (Check_Consistent_Restrictions): Remove obsolete code checking for violation of No_Standard_Allocators_After_Elaboration (main program) * bindgen.adb (Gen_Adainit): Handle No_Standard_Allocators_After_Elaboration (Gen_Output_File_Ada): ditto. * exp_ch4.adb (Expand_N_Allocator): Handle No_Standard_Allocators_After_Elaboration. * Makefile.rtl: Add entry for s-elaall * rtsfind.ads: Add entry for Check_Standard_Allocator. * s-elaall.ads, s-elaall.adb: New files. * sem_ch4.adb (Analyze_Allocator): Handle No_Standard_Allocators_After_Elaboration. Index: bindgen.adb =================================================================== --- bindgen.adb (revision 212735) +++ bindgen.adb (working copy) @@ -739,8 +739,8 @@ if Dispatching_Domains_Used then WBI (" procedure Freeze_Dispatching_Domains;"); WBI (" pragma Import"); - WBI (" (Ada, Freeze_Dispatching_Domains, " & - """__gnat_freeze_dispatching_domains"");"); + WBI (" (Ada, Freeze_Dispatching_Domains, " + & """__gnat_freeze_dispatching_domains"");"); end if; WBI (" begin"); @@ -749,6 +749,18 @@ WBI (" end if;"); WBI (" Is_Elaborated := True;"); + -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if + -- restriction No_Standard_Allocators_After_Elaboration is active. + + if Cumulative_Restrictions.Set + (No_Standard_Allocators_After_Elaboration) + then + WBI (" System.Elaboration_Allocators." + & "Mark_Start_Of_Elaboration;"); + end if; + + -- Generate assignments to initialize globals + Set_String (" Main_Priority := "); Set_Int (Main_Priority); Set_Char (';'); @@ -996,6 +1008,15 @@ Gen_Elab_Calls; + -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if + -- restriction No_Standard_Allocators_After_Elaboration is active. + + if Cumulative_Restrictions.Set + (No_Standard_Allocators_After_Elaboration) + then + WBI (" System.Elaboration_Allocators.Mark_End_Of_Elaboration;"); + end if; + -- From this point, no new dispatching domain can be created. if Dispatching_Domains_Used then @@ -2482,10 +2503,23 @@ WBI ("with System.Restrictions;"); end if; + -- Generate with of Ada.Exceptions if needs library finalization + if Needs_Library_Finalization then WBI ("with Ada.Exceptions;"); end if; + -- Generate with of System.Elaboration_Allocators if the restriction + -- No_Standard_Allocators_After_Elaboration was present. + + if Cumulative_Restrictions.Set + (No_Standard_Allocators_After_Elaboration) + then + WBI ("with System.Elaboration_Allocators;"); + end if; + + -- Generate start of package body + WBI (""); WBI ("package body " & Ada_Main & " is"); WBI (" pragma Warnings (Off);"); Index: rtsfind.ads =================================================================== --- rtsfind.ads (revision 212725) +++ rtsfind.ads (working copy) @@ -241,6 +241,7 @@ System_Dim, System_DSA_Services, System_DSA_Types, + System_Elaboration_Allocators, System_Exception_Table, System_Exceptions_Debug, System_Exn_Int, @@ -856,6 +857,8 @@ RE_Any_Container_Ptr, -- System.DSA_Types + RE_Check_Standard_Allocator, -- System.Elaboration_Allocators + RE_Register_Exception, -- System.Exception_Table RE_Local_Raise, -- System.Exceptions_Debug @@ -2141,6 +2144,8 @@ RE_Any_Container_Ptr => System_DSA_Types, + RE_Check_Standard_Allocator => System_Elaboration_Allocators, + RE_Register_Exception => System_Exception_Table, RE_Local_Raise => System_Exceptions_Debug, Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 212728) +++ exp_ch4.adb (working copy) @@ -4490,6 +4490,20 @@ end if; end if; + -- If no storage pool has been specified and we have the restriction + -- No_Standard_Allocators_After_Elaboration is present, then generate + -- a call to Elaboration_Allocators.Check_Standard_Allocator. + + if Nkind (N) = N_Allocator + and then No (Storage_Pool (N)) + and then Restriction_Active (No_Standard_Allocators_After_Elaboration) + then + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Check_Standard_Allocator), Loc))); + end if; + -- Handle case of qualified expression (other than optimization above) -- First apply constraint checks, because the bounds or discriminants -- in the aggregate might not match the subtype mark in the allocator. Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 212735) +++ sem_ch4.adb (working copy) @@ -400,6 +400,7 @@ Type_Id : Entity_Id; P : Node_Id; C : Node_Id; + Onode : Node_Id; begin Check_SPARK_Restriction ("allocator is not allowed", N); @@ -420,33 +421,40 @@ P := Parent (C); while Present (P) loop - -- In both cases we need a handled sequence of statements, where - -- the occurrence of the allocator is within the statements. + -- For the task case we need a handled sequence of statements, + -- where the occurrence of the allocator is within the statements + -- and the parent is a task body if Nkind (P) = N_Handled_Sequence_Of_Statements and then Is_List_Member (C) and then List_Containing (C) = Statements (P) then + Onode := Original_Node (Parent (P)); + -- Check for allocator within task body, this is a definite -- violation of No_Allocators_After_Elaboration we can detect -- at compile time. - if Nkind (Original_Node (Parent (P))) = N_Task_Body then + if Nkind (Onode) = N_Task_Body then Check_Restriction (No_Standard_Allocators_After_Elaboration, N); exit; end if; + end if; - -- The other case is appearance in a subprogram body. This may - -- be a violation if this is a library level subprogram, and it - -- turns out to be used as the main program, but only the - -- binder knows that, so just record the occurrence. + -- The other case is appearance in a subprogram body. This is + -- a violation if this is a library level subprogram with no + -- parameters. Note that this is now a static error even if the + -- subprogram is not the main program (this is a change, in an + -- earlier version only the main program was affected, and the + -- check had to be done in the binder. - if Nkind (Original_Node (Parent (P))) = N_Subprogram_Body - and then Nkind (Parent (Parent (P))) = N_Compilation_Unit - then - Set_Has_Allocator (Current_Sem_Unit); - end if; + if Nkind (P) = N_Subprogram_Body + and then Nkind (Parent (P)) = N_Compilation_Unit + and then No (Parameter_Specifications (Specification (P))) + then + Check_Restriction + (No_Standard_Allocators_After_Elaboration, N); end if; C := P; Index: s-elaall.adb =================================================================== --- s-elaall.adb (revision 0) +++ s-elaall.adb (revision 0) @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E L A B O R A T I O N _ A L L O C A T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Elaboration_Allocators is + + Elaboration_In_Progress : Boolean; + pragma Atomic (Elaboration_In_Progress); + -- Flag to show if elaboration is active. We don't attempt to initialize + -- this because we want to be sure it gets reset if we are in a multiple + -- elaboration situation of some kind. Make it atomic to prevent race + -- conditions of any kind (not clearly necessary, but harmless!) + + ------------------------------ + -- Check_Standard_Allocator -- + ------------------------------ + + procedure Check_Standard_Allocator is + begin + if not Elaboration_In_Progress then + raise Program_Error with + "standard allocator after elaboration is complete is not allowed " + & "(No_Standard_Allocators_After_Elaboration restriction active)"; + end if; + end Check_Standard_Allocator; + + ----------------------------- + -- Mark_End_Of_Elaboration -- + ----------------------------- + + procedure Mark_End_Of_Elaboration is + begin + Elaboration_In_Progress := False; + end Mark_End_Of_Elaboration; + + ------------------------------- + -- Mark_Start_Of_Elaboration -- + ------------------------------- + + procedure Mark_Start_Of_Elaboration is + begin + Elaboration_In_Progress := True; + end Mark_Start_Of_Elaboration; + +end System.Elaboration_Allocators; Index: s-elaall.ads =================================================================== --- s-elaall.ads (revision 0) +++ s-elaall.ads (revision 0) @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E L A B O R A T I O N _ A L L O C A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the interfaces for proper handling of restriction +-- No_Standard_Allocators_After_Elaboration. It is used only by programs +-- which use this restriction. + +package System.Elaboration_Allocators is + pragma Preelaborate; + + procedure Mark_Start_Of_Elaboration; + -- Called right at the start of main elaboration if the program activates + -- restriction No_Standard_Allocators_After_Elaboration. We don't want to + -- rely on the normal elaboration mechanism for marking this event, since + -- that would require us to be sure to elaborate this first, which would + -- be awkward, and it is convenient to have this package be Preelaborate. + + procedure Mark_End_Of_Elaboration; + -- Called when main elaboration is complete if the program has activated + -- restriction No_Standard_Allocators_After_Elaboration. This is the point + -- beyond which any standard allocator use will violate the restriction. + + procedure Check_Standard_Allocator; + -- Called as part of every allocator in a program for which the restriction + -- No_Standard_Allocators_After_Elaboration is active. This will raise an + -- exception (Program_Error with an appropriate message) if it is called + -- after the call to Mark_End_Of_Elaboration. + +end System.Elaboration_Allocators; Index: Makefile.rtl =================================================================== --- Makefile.rtl (revision 212660) +++ Makefile.rtl (working copy) @@ -518,6 +518,7 @@ s-direio$(objext) \ s-dmotpr$(objext) \ s-dsaser$(objext) \ + s-elaall$(objext) \ s-excdeb$(objext) \ s-except$(objext) \ s-exctab$(objext) \ Index: bcheck.adb =================================================================== --- bcheck.adb (revision 212640) +++ bcheck.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -923,22 +923,19 @@ -- Start of processing for Check_Consistent_Restrictions begin - -- A special test, if we have a main program, then if it has an - -- allocator in the body, this is considered to be a violation of - -- the restriction No_Allocators_After_Elaboration. We just mark - -- this restriction and then the normal circuit will flag it. + -- We used to have a special test here: - if Bind_Main_Program - and then ALIs.Table (ALIs.First).Main_Program /= None - and then not No_Main_Subprogram - and then ALIs.Table (ALIs.First).Allocator_In_Body - then - Cumulative_Restrictions.Violated - (No_Standard_Allocators_After_Elaboration) := True; - ALIs.Table (ALIs.First).Restrictions.Violated - (No_Standard_Allocators_After_Elaboration) := True; - end if; + -- A special test, if we have a main program, then if it has an + -- allocator in the body, this is considered to be a violation of + -- the restriction No_Allocators_After_Elaboration. We just mark + -- this restriction and then the normal circuit will flag it. + -- But we don't do that any more, because in the final version of Ada + -- 2012, it is statically illegal to have an allocator in a library- + -- level subprogram, so we don't need this bind time test any more. + -- If we have a main program with parameters (which GNAT allows), then + -- allocators in that will be caught by the run-time check. + -- Loop through all restriction violations for R in All_Restrictions loop