Patchwork [Ada] Implement No_Standard_Allocators_After_Elaboration

login
register
mail settings
Submitter Arnaud Charlet
Date July 18, 2014, 9:05 a.m.
Message ID <20140718090518.GA3394@adacore.com>
Download mbox | patch
Permalink /patch/371370/
State New
Headers show

Comments

Arnaud Charlet - July 18, 2014, 9:05 a.m.
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  <dewar@adacore.com>

	* 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.

Patch

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    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- 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    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- 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