Controlled allocator named subpools

--  { dg-do run }
--  { dg-options "-gnata" }

with Ada.Finalization;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocate_Subpool;
with System;
with System.Storage_Elements; use System.Storage_Elements;
with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;

procedure Controlled_Subpool_Allocator is
   Finalizations : Natural := 0;

   type Test_Subpool is new Root_Subpool with null record;
   type Test_Interface is limited interface;

   type Test_Pool is new Root_Storage_Pool_With_Subpools with record
      Region      : aliased Test_Subpool;
      Storage     : aliased Storage_Array (1 .. 4_096);
      Next        : Storage_Offset := 1;
      Allocations : Natural := 0;
      Releases    : Natural := 0;
   end record;

   overriding
   function Create_Subpool
     (Pool : in out Test_Pool) return not null Subpool_Handle;

   overriding
   procedure Allocate_From_Subpool
     (Pool                     : in out Test_Pool;
      Storage_Address          : out System.Address;
      Size_In_Storage_Elements : Storage_Count;
      Alignment                : Storage_Count;
      Subpool                  : not null Subpool_Handle);

   overriding
   procedure Deallocate_Subpool
     (Pool : in out Test_Pool; Subpool : in out Subpool_Handle);

   type Tracked is new Ada.Finalization.Limited_Controlled
     and Test_Interface with record
      Value : Natural := 0;
   end record;

   overriding procedure Finalize (Object : in out Tracked);

   overriding
   function Create_Subpool
     (Pool : in out Test_Pool) return not null Subpool_Handle
   is
      Result : constant not null Subpool_Handle :=
        Pool.Region'Unchecked_Access;
   begin
      Set_Pool_Of_Subpool (Result, Pool);
      return Result;
   end Create_Subpool;

   overriding
   procedure Allocate_From_Subpool
     (Pool                     : in out Test_Pool;
      Storage_Address          : out System.Address;
      Size_In_Storage_Elements : Storage_Count;
      Alignment                : Storage_Count;
      Subpool                  : not null Subpool_Handle)
   is
      Current : System.Address := Pool.Storage (Pool.Next)'Address;
   begin
      if Subpool /= Pool.Region'Unchecked_Access then
         raise Program_Error with "allocation used an unexpected subpool";
      end if;

      while Current mod Alignment /= 0 loop
         Pool.Next := Pool.Next + 1;
         Current := Pool.Storage (Pool.Next)'Address;
      end loop;

      Storage_Address := Current;
      Pool.Next := Pool.Next + Storage_Offset (Size_In_Storage_Elements);
      Pool.Allocations := Pool.Allocations + 1;
   end Allocate_From_Subpool;

   overriding
   procedure Deallocate_Subpool
     (Pool : in out Test_Pool; Subpool : in out Subpool_Handle)
   is
   begin
      Pool.Releases := Pool.Releases + 1;
      Subpool := null;
   end Deallocate_Subpool;

   overriding procedure Finalize (Object : in out Tracked) is
   begin
      if Object.Value /= 7 then
         raise Program_Error with "controlled object value was not preserved";
      end if;
      Finalizations := Finalizations + 1;
   end Finalize;

   Pool       : Test_Pool;
   Region     : Subpool_Handle := Create_Subpool (Pool);
   Selections : Natural := 0;

   function Select_Region return not null Subpool_Handle is
   begin
      Selections := Selections + 1;
      return Region;
   end Select_Region;

   type Plain_Access is access Integer with Storage_Pool => Pool;
   type Tracked_Access is access Tracked with Storage_Pool => Pool;
   type Interface_Access is access Test_Interface'Class
     with Storage_Pool => Pool;

   Plain_Object     : Plain_Access := new (Region) Integer'(3);
   Tracked_Object   : Tracked_Access :=
     new (Select_Region) Tracked'
       (Ada.Finalization.Limited_Controlled with Value => 7);
   Interface_Object : Interface_Access :=
     new (Select_Region) Tracked'
       (Ada.Finalization.Limited_Controlled with Value => 7);

begin
   if Plain_Object.all /= 3 or else Tracked_Object.Value /= 7 then
      raise Program_Error with "allocated values were not preserved";
   end if;
   if Interface_Object = null or else Pool.Allocations /= 3 then
      raise Program_Error with "named subpool did not receive all allocations";
   end if;
   if Selections /= 2 then
      raise Program_Error with "subpool expressions were not evaluated once";
   end if;

   Ada.Unchecked_Deallocate_Subpool (Region);
   if Region /= null or else Pool.Releases /= 1 or else Finalizations /= 2 then
      raise Program_Error with "subpool release did not finalize both objects";
   end if;

   Plain_Object := null;
   Tracked_Object := null;
   Interface_Object := null;
   Put_Line ("PASS controlled named subpool allocator");
end Controlled_Subpool_Allocator;

#!/usr/bin/env bash
set -euo pipefail

if [[ $# -ne 3 ]]; then
  echo "usage: $0 TOOLCHAIN_ROOT GCC_VERSION unpatched|patched" >&2
  exit 2
fi

root=$(cd "$(dirname "${BASH_SOURCE[0]}")/../.." && pwd)
source "$root/scripts/regression-common.sh"
resolve_regression_toolchain "$1"
version=$2
state=$3
[[ "$state" == unpatched || "$state" == patched ]] || {
  echo "error: state must be unpatched or patched" >&2
  exit 2
}

case "$version" in
  13.2.0|14.2.0|15.1.0) affected=yes ;;
  15.3.0|16.1.0|16.2.0) affected=no ;;
  *) echo "error: unsupported GCC version: $version" >&2; exit 2 ;;
esac

fixture="$root/bundles/controlled-subpool-allocator/tests/controlled_subpool_allocator.adb"
work=$(mktemp -d "${TMPDIR:-/tmp}/gnat-controlled-subpool-test.XXXXXX")
trap 'rm -rf "$work"' EXIT

for optimization in 0 2; do
  case_dir="$work/O$optimization"
  mkdir -p "$case_dir"
  cp "$fixture" "$case_dir/controlled_subpool_allocator.adb"
  (
    cd "$case_dir"
    "${REGRESSION_ENV[@]}" "$REGRESSION_GNATMAKE" -q -f \
      "-O$optimization" -gnata controlled_subpool_allocator.adb
  )

  set +e
  "${REGRESSION_ENV[@]}" "$case_dir/controlled_subpool_allocator" \
    >"$case_dir/output.log" 2>&1
  run_status=$?
  set -e

  if [[ "$state" == unpatched && "$affected" == yes ]]; then
    [[ $run_status -ne 0 ]] || {
      echo "error: unpatched controlled-subpool regression unexpectedly passed at -O$optimization" >&2
      exit 1
    }
    grep -Eiq 'PROGRAM_ERROR.*Default_Subpool_For_Pool' "$case_dir/output.log" || {
      cat "$case_dir/output.log"
      exit 1
    }
    expected=expected-null-subpool-failure
  else
    [[ $run_status -eq 0 ]] || { cat "$case_dir/output.log"; exit 1; }
    grep -Fx "PASS controlled named subpool allocator" "$case_dir/output.log"
    if [[ "$affected" == no ]]; then
      expected=known-good-control
    else
      expected=patched
    fi
  fi

  echo "controlled-subpool-allocator -O$optimization: $expected (GCC $version)"
done