[Ada] Secondary stack implementation clean up
This patch reimplements the secondary stack runtime support as follows:
* The compiler interface remains unchanged. This applies to both types and
subprograms used by the compiler to create and manage secondary stacks.
* The secondary stack is no longer a doubly linked list of chunks.
* Various allocation scenarios are now handled by the same mechanism.
In addition, the patch introduces a lightweight private interface for testing
purposes.
------------
-- Source --
------------
-- comparator.ads
generic
type Field_Typ is private;
-- The type of the field being compared
with function Image (Val : Field_Typ) return String;
-- Field-to-String converted
procedure Comparator
(Field_Nam : String;
Actual_Val : Field_Typ;
Expected_Val : Field_Typ);
-- Compare actual value Actual_Val against expected value Expected_Val for
-- field Field_Nam. Emit an error if this is not the case.
-- comparator.adb
with Ada.Text_IO; use Ada.Text_IO;
procedure Comparator
(Field_Nam : String;
Actual_Val : Field_Typ;
Expected_Val : Field_Typ)
is
begin
if Actual_Val /= Expected_Val then
Put_Line (Field_Nam);
Put_Line (" Actual :" & Image (Actual_Val));
Put_Line (" Expected :" & Image (Expected_Val));
end if;
end Comparator;
-- debugger.ads
package Debugger is
Verbouse : constant Boolean := False;
-- Set to True in order to obtain verbouse output
procedure Output (Msg : String);
-- Emit Msg to standard output if Verbouse is True
end Debugger;
-- debugger.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Debugger is
------------
-- Output --
------------
procedure Output (Msg : String) is
begin
if Verbouse then
Put_Line (Msg);
end if;
end Output;
end Debugger;
-- s-sestte.ads
package System.Secondary_Stack.Tester is
procedure Test_Dynamic_Stack_Dynamic_Chunks;
-- Test various properties of a dynamic stack's dynamic chunks
procedure Test_Dynamic_Stack_Illegal_Allocations;
-- Test whether illegal allocations on a dynamic stack are properly
-- detected and reported.
procedure Test_Dynamic_Stack_Static_Chunk;
-- Test various properties of a dynamic stack's static chunk
procedure Test_Dynamic_Stack_Zero_Chunk_Size;
-- Test various properties of a dynamic stack with default chunk size of
-- zero.
procedure Test_Static_Stack_Illegal_Allocations;
-- Test whether illegal allocations on a static stack are properly
-- detected and reported.
procedure Test_Static_Stack_Overflow;
-- Test whether overflow of a static stack's static chunk is properly
-- detected and reported.
procedure Test_Static_Stack_Static_Chunk;
-- Test various properties of a static chunk's static chunk
end System.Secondary_Stack.Tester;
-- s-sestte.adb
with Ada.Assertions; use Ada.Assertions;
with Ada.Text_IO; use Ada.Text_IO;
with System; use System;
with System.Parameters; use System.Parameters;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
with Comparator;
with Debugger; use Debugger;
package body System.Secondary_Stack.Tester is
Units : constant := Standard'Maximum_Alignment;
-- Each allocation of the secondary stack is rouded up to the nearest
-- multiple of the maximum alignment. This value is called a "unit" in
-- order to facilitate further allocations.
-----------------------
-- Local subprograms --
-----------------------
procedure Compare_Boolean is
new Comparator
(Field_Typ => Boolean,
Image => Boolean'Image);
procedure Compare_Chunk_Count is
new Comparator
(Field_Typ => Chunk_Count,
Image => Chunk_Count'Image);
procedure Compare_Chunk_Id is
new Comparator
(Field_Typ => Chunk_Id,
Image => Chunk_Id'Image);
procedure Compare_Memory_Index is
new Comparator
(Field_Typ => Memory_Index,
Image => Memory_Index'Image);
procedure Compare_Memory_Size is
new Comparator
(Field_Typ => Memory_Size,
Image => Memory_Size'Image);
procedure Compare_MSWI is
new Comparator
(Field_Typ => Memory_Size_With_Invalid,
Image => Memory_Size_With_Invalid'Image);
procedure Initialize_Stack (Size : Memory_Size);
-- Create a new secondary stack for the calling task where the default
-- chunk size is Size.
procedure Match_Chunk
(Match_Nam : String;
Actual : Chunk_Info;
Expected : Chunk_Info);
-- Check whether actual chunk info Actual matches expected chunk info
-- Expected. Match_Nam is the name of the match.
procedure Match_Pointer
(Actual : Stack_Pointer_Info;
Expected : Stack_Pointer_Info);
-- Check whether actual pointer info Actual matches expected pointer info
-- Expected.
procedure Match_Stack
(Match_Nam : String;
Actual : Stack_Info;
Expected : Stack_Info);
-- Check whether actual stack info Stack matches expected stack info
-- Expected. Match_Nam is the name of the match.
procedure Test_Static_Chunk (Def_Chunk_Size : Memory_Size);
-- Common testing for properties of the static chunk for both static and
-- dynamic secondary stacks. Def_Chunk_Size denotes the default size of a
-- secondary stack chunk. This routine assumes that the secondary stack
-- can fit 12 * Units.
----------------------
-- Initialize_Stack --
----------------------
procedure Initialize_Stack (Size : Memory_Size) is
Stack : SS_Stack_Ptr;
begin
-- Obtain the secondary stack of the calling task
Stack := Get_Sec_Stack.all;
-- If the calling task has an existing secodnary stack, destroy it
-- because this scenario utilizes a custom secondary stack.
if Stack /= null then
-- Destroy the existing secondary stack because it will be replaced
-- with a new one.
SS_Free (Stack);
pragma Assert (Stack = null);
end if;
-- Create a brand new empty secondary stack
SS_Init (Stack, Size);
pragma Assert (Stack /= null);
-- Associate the secondary stack with the calling task
Set_Sec_Stack (Stack);
end Initialize_Stack;
-----------------
-- Match_Chunk --
-----------------
procedure Match_Chunk
(Match_Nam : String;
Actual : Chunk_Info;
Expected : Chunk_Info)
is
begin
Output (Match_Nam);
Compare_MSWI
("Size", Actual.Size,
Expected.Size);
Compare_MSWI
("Size_Up_To_Chunk", Actual.Size_Up_To_Chunk,
Expected.Size_Up_To_Chunk);
end Match_Chunk;
-------------------
-- Match_Pointer --
-------------------
procedure Match_Pointer
(Actual : Stack_Pointer_Info;
Expected : Stack_Pointer_Info)
is
begin
Compare_Memory_Index
("Byte", Actual.Byte,
Expected.Byte);
Compare_Chunk_Id
("Chunk", Actual.Chunk,
Expected.Chunk);
end Match_Pointer;
-----------------
-- Match_Stack --
-----------------
procedure Match_Stack
(Match_Nam : String;
Actual : Stack_Info;
Expected : Stack_Info)
is
begin
Output (Match_Nam);
Compare_Memory_Size
("Default_Chunk_Size", Actual.Default_Chunk_Size,
Expected.Default_Chunk_Size);
Compare_Boolean
("Freeable", Actual.Freeable,
Expected.Freeable);
Compare_Memory_Size
("High_Water_Mark", Actual.High_Water_Mark,
Expected.High_Water_Mark);
Compare_Chunk_Count
("Number_Of_Chunks", Actual.Number_Of_Chunks,
Expected.Number_Of_Chunks);
Match_Pointer (Actual.Top, Expected.Top);
end Match_Stack;
---------------------------------------
-- Test_Dynamic_Stack_Dynamic_Chunks --
---------------------------------------
procedure Test_Dynamic_Stack_Dynamic_Chunks is
Def_Chunk_Size : constant Memory_Size := 4 * Units;
Dummy_1 : Address;
Dummy_2 : Address;
Dummy_3 : Address;
Dummy_4 : Address;
Mark : Mark_Id;
begin
Output ("#### Test_DSDCs ####");
-- Create a brand new empty secondary stack
--
-- 1 2 3 4
-- +------------+
-- | |
-- +------------+
Initialize_Stack (Def_Chunk_Size);
Match_Stack
(Match_Nam => "Empty stack",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 0,
Number_Of_Chunks => 1,
Top => (Byte => 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "Empty stack, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Mark
-- |
-- 1 2 3 4
-- +------------+
-- | |
-- +------------+
Mark := SS_Mark;
-- Mark Top.Byte
-- | |
-- 1 2 3 4 1 2 3 4 5 6
-- +------------+ +---------------+
-- | |->|###############|
-- +------------+ +---------------+
-- 1 2 3 4 5 6 7 8 9
-- |
-- HWM
SS_Allocate (Dummy_1, 5 * Units);
Match_Stack
(Match_Nam => "After 5u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 9 * Units,
Number_Of_Chunks => 2,
Top => (Byte => (5 * Units) + 1, Chunk => 2)));
Match_Chunk
(Match_Nam => "After 5u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 5u allocation, chunk 2",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 2),
Expected =>
(Size => 5 * Units,
Size_Up_To_Chunk => 4 * Units));
-- Mark Top.Byte
-- | |
-- 1 2 3 4 1 2 3 4 5 1 2 3 4
-- +------------+ +---------------+ +------------+
-- | |->|###############|->|###### |
-- +------------+ +---------------+ +------------+
-- 1 2 3 4 5 6 7 8 9 10 11 12 13
-- |
-- HWM
--
-- Note that the size of Chunk 3 defaults to 4 because the request is
-- smaller than the default chunk size.
SS_Allocate (Dummy_2, 2 * Units);
Match_Stack
(Match_Nam => "After 2u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 11 * Units,
Number_Of_Chunks => 3,
Top => (Byte => (2 * Units) + 1, Chunk => 3)));
Match_Chunk
(Match_Nam => "After 2u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 2u allocation, chunk 2",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 2),
Expected =>
(Size => 5 * Units,
Size_Up_To_Chunk => 4 * Units));
Match_Chunk
(Match_Nam => "After 2u allocation, chunk 3",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 3),
Expected =>
(Size => 4 * Units,
Size_Up_To_Chunk => 9 * Units));
-- Top.Byte
-- |
-- 1 2 3 4 1 2 3 4 5 1 2 3 4
-- +------------+ +---------------+ +------------+
-- | | --> |###############| --> |###### |
-- +------------+ +---------------+ +------------+
-- 1 2 3 4 5 6 7 8 9 10 11 12 13
-- |
-- HWM
SS_Release (Mark);
-- Top.Byte
-- |
-- 1 2 3 4 1 2 3 4 5 1 2 3 4
-- +------------+ +---------------+ +------------+
-- |######### | --> |###############| --> |###### |
-- +------------+ +---------------+ +------------+
-- 1 2 3 4 5 6 7 8 9 10 11 12 13
-- |
-- HWM
SS_Allocate (Dummy_3, 3 * Units);
Match_Stack
(Match_Nam => "After 3u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 11 * Units,
Number_Of_Chunks => 3,
Top => (Byte => (3 * Units) + 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After 3u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 3u allocation, chunk 2",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 2),
Expected =>
(Size => 5 * Units,
Size_Up_To_Chunk => 4 * Units));
Match_Chunk
(Match_Nam => "After 3u allocation, chunk 3",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 3),
Expected =>
(Size => 4 * Units,
Size_Up_To_Chunk => 9 * Units));
-- Top.Byte
-- |
-- 1 2 3 4 1 2 3 4 5 6 7 8 9
-- +------------+ +------------------------+
-- |######### | --> |########################|
-- +------------+ +------------------------+
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- |
-- HWM
SS_Allocate (Dummy_4, 8 * Units);
Match_Stack
(Match_Nam => "After 8u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 12 * Units,
Number_Of_Chunks => 2,
Top => (Byte => (8 * Units) + 1, Chunk => 2)));
Match_Chunk
(Match_Nam => "After 8u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 8u allocation, chunk 2",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 2),
Expected =>
(Size => 8 * Units,
Size_Up_To_Chunk => 4 * Units));
exception
when others =>
Put_Line ("Test_DSDCs: unexpected exception");
end Test_Dynamic_Stack_Dynamic_Chunks;
--------------------------------------------
-- Test_Dynamic_Stack_Illegal_Allocations --
--------------------------------------------
procedure Test_Dynamic_Stack_Illegal_Allocations is
Def_Chunk_Size : constant Memory_Size := 4 * Units;
Dummy_1 : Address;
Dummy_2 : Address;
begin
Output ("#### Test_DSIA ####");
-- Create a brand new empty secondary stack
--
-- 1 2 3 4
-- +------------+
-- | |
-- +------------+
Initialize_Stack (Def_Chunk_Size);
Match_Stack
(Match_Nam => "Empty stack",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 0,
Number_Of_Chunks => 1,
Top => (Byte => 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "Empty stack, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- It should not be possible to allocate an object of size zero
Zero_Allocation : begin
SS_Allocate (Dummy_1, 0);
Put_Line ("Test_DSIA: ERROR: zero allocation succeeded");
exception
when Assertion_Error =>
Match_Stack
(Match_Nam => "After zero allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 0,
Number_Of_Chunks => 1,
Top => (Byte => 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After zero allocation",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
when others =>
Put_Line ("Test_DSIA: zero allocation: unexpected exception");
end Zero_Allocation;
-- It should not be possible to allocate an object of negative size
Negative_Allocation : begin
SS_Allocate (Dummy_2, -8);
Put_Line ("Test_DSIA: ERROR: negative allocation succeeded");
exception
when Assertion_Error =>
Match_Stack
(Match_Nam => "After negative allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 0,
Number_Of_Chunks => 1,
Top => (Byte => 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After negative allocation",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
when others =>
Put_Line ("Test_DSIA: negative allocation: unexpected exception");
end Negative_Allocation;
exception
when others =>
Put_Line ("Test_DSIA: unexpected exception");
end Test_Dynamic_Stack_Illegal_Allocations;
-------------------------------------
-- Test_Dynamic_Stack_Static_Chunk --
-------------------------------------
procedure Test_Dynamic_Stack_Static_Chunk is
Def_Chunk_Size : constant Memory_Size := 12 * Units;
Dummy_1 : Address;
Dummy_2 : Address;
Dummy_3 : Address;
Dummy_4 : Address;
Mark_1 : Mark_Id;
Mark_2 : Mark_Id;
begin
Output ("#### Test_DSSC ####");
-- Create a brand new empty secondary stack
--
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------+
-- | |
-- +------------------------------------+
Initialize_Stack (Def_Chunk_Size);
Test_Static_Chunk (Def_Chunk_Size);
exception
when others =>
Put_Line ("Test_DSSC: unexpected exception");
end Test_Dynamic_Stack_Static_Chunk;
----------------------------------------
-- Test_Dynamic_Stack_Zero_Chunk_Size --
----------------------------------------
procedure Test_Dynamic_Stack_Zero_Chunk_Size is
Def_Chunk_Size : constant Memory_Size := 0;
Dummy_1 : Address;
Dummy_2 : Address;
Mark : Mark_Id;
begin
Output ("#### Test_DSZCS ####");
-- Create a brand new empty secondary stack
--
-- ++
-- ||
-- ++
Initialize_Stack (Def_Chunk_Size);
Match_Stack
(Match_Nam => "Empty stack",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 0,
Number_Of_Chunks => 1,
Top => (Byte => 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "Empty stack, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Mark
-- |
-- 1
-- ++
-- ||
-- ++
Mark := SS_Mark;
-- Mark Top.Byte
-- | |
-- | 1 2 3 4
-- ++ +---------+
-- ||->|#########|
-- ++ +---------+
-- 1 2 3
-- |
-- HWM
SS_Allocate (Dummy_1, 3 * Units);
Match_Stack
(Match_Nam => "After 3u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 3 * Units,
Number_Of_Chunks => 2,
Top => (Byte => (3 * Units) + 1, Chunk => 2)));
Match_Chunk
(Match_Nam => "After 3u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 3u allocation, chunk 2",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 2),
Expected =>
(Size => 3 * Units,
Size_Up_To_Chunk => 0));
-- Mark Top.Byte
-- | |
-- | 1 2 3 1 2 3
-- ++ +---------+ +------+
-- ||->|#########|->|######|
-- ++ +---------+ +------+
-- 1 2 3 4 5
-- |
-- HWM
SS_Allocate (Dummy_2, 2 * Units);
Match_Stack
(Match_Nam => "After 2u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 5 * Units,
Number_Of_Chunks => 3,
Top => (Byte => (2 * Units) + 1, Chunk => 3)));
Match_Chunk
(Match_Nam => "After 2u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 2u allocation, chunk 2",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 2),
Expected =>
(Size => 3 * Units,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 2u allocation, chunk 3",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 3),
Expected =>
(Size => 2 * Units,
Size_Up_To_Chunk => 3 * Units));
-- Top.Byte
-- |
-- | 1 2 3 1 2
-- ++ +---------+ +------+
-- ||->|#########|->|######|
-- ++ +---------+ +------+
-- 1 2 3 4 5
-- |
-- HWM
SS_Release (Mark);
-- Top.Byte
-- |
-- 1 2 3 4 5 6 7
-- ++ +------------------+
-- ||->|##################|
-- ++ +------------------+
-- 1 2 3 4 5 6
-- |
-- HWM
SS_Allocate (Dummy_2, 6 * Units);
Match_Stack
(Match_Nam => "After 6u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 6 * Units,
Number_Of_Chunks => 2,
Top => (Byte => (6 * Units) + 1, Chunk => 2)));
Match_Chunk
(Match_Nam => "After 6u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
Match_Chunk
(Match_Nam => "After 6u allocation, chunk 2",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 2),
Expected =>
(Size => 6 * Units,
Size_Up_To_Chunk => 0));
exception
when others =>
Put_Line ("Test_DSZCS: unexpected exception");
end Test_Dynamic_Stack_Zero_Chunk_Size;
-----------------------
-- Test_Static_Chunk --
-----------------------
procedure Test_Static_Chunk (Def_Chunk_Size : Memory_Size) is
Dummy_1 : Address;
Dummy_2 : Address;
Dummy_3 : Address;
Dummy_4 : Address;
Mark_1 : Mark_Id;
Mark_2 : Mark_Id;
begin
-- This routine assumes an empty secondary stack
Match_Stack
(Match_Nam => "Empty stack",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 0,
Number_Of_Chunks => 1,
Top => (Byte => 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "Empty stack, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Top.Byte
-- |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |############
-- +------------------------------------. . .
-- |
-- HWM
SS_Allocate (Dummy_1, 4 * Units);
Match_Stack
(Match_Nam => "After 4u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 4 * Units,
Number_Of_Chunks => 1,
Top => (Byte => (4 * Units) + 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After 4u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Mark_1
-- Top.Byte
-- |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |############
-- +------------------------------------. . .
-- |
-- HWM
Mark_1 := SS_Mark;
-- Mark_1
-- | Top.Byte
-- | |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |###########################
-- +------------------------------------. . .
-- |
-- HWM
SS_Allocate (Dummy_2, 5 * Units);
Match_Stack
(Match_Nam => "After 5u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 9 * Units,
Number_Of_Chunks => 1,
Top => (Byte => (9 * Units) + 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After 5u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Mark_1 Mark_2
-- | Top.Byte
-- | |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |###########################
-- +------------------------------------. . .
-- |
-- HWM
Mark_2 := SS_Mark;
-- Mark_1 Mark_2
-- | | Top.Byte
-- | | |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |#################################
-- +------------------------------------. . .
-- |
-- HWM
SS_Allocate (Dummy_3, 2 * Units);
Match_Stack
(Match_Nam => "After 2u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 11 * Units,
Number_Of_Chunks => 1,
Top => (Byte => (11 * Units) + 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After 2u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Mark_1
-- | Top.Byte
-- | |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |#################################
-- +------------------------------------. . .
-- |
-- HWM
SS_Release (Mark_2);
Match_Stack
(Match_Nam => "After Mark_2 release",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 11 * Units,
Number_Of_Chunks => 1,
Top => (Byte => (9 * Units) + 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After Mark_2 release, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Top.Byte
-- |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |#################################
-- +------------------------------------. . .
-- |
-- HWM
SS_Release (Mark_1);
Match_Stack
(Match_Nam => "After Mark_1 release",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 11 * Units,
Number_Of_Chunks => 1,
Top => (Byte => (4 * Units) + 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After Mark_1 release, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
-- Top.Byte
-- |
-- 1 2 3 4 5 6 7 8 9 10 11 12
-- +------------------------------------. . .
-- |#################################
-- +------------------------------------. . .
-- |
-- HWM
SS_Allocate (Dummy_4, 6 * Units);
Match_Stack
(Match_Nam => "After 6u allocation",
Actual => Get_Stack_Info (Get_Sec_Stack.all),
Expected =>
(Default_Chunk_Size => Def_Chunk_Size,
Freeable => True,
High_Water_Mark => 11 * Units,
Number_Of_Chunks => 1,
Top => (Byte => (10 * Units) + 1, Chunk => 1)));
Match_Chunk
(Match_Nam => "After 6u allocation, chunk 1",
Actual => Get_Chunk_Info (Get_Sec_Stack.all, 1),
Expected =>
(Size => Def_Chunk_Size,
Size_Up_To_Chunk => 0));
end Test_Static_Chunk;
-------------------------------------------
-- Test_Static_Stack_Illegal_Allocations --
-------------------------------------------
procedure Test_Static_Stack_Illegal_Allocations is
Dummy_1 : Address;
Dummy_2 : Address;
begin
Output ("#### Test_SSIA ####");
-- It should not be possible to allocate an object of size zero
Zero_Allocation : begin
SS_Allocate (Dummy_1, 0);
Put_Line ("Test_SSIA: ERROR: zero allocation succeeded");
exception
when Assertion_Error =>
Output ("After zero allocation");
when others =>
Put_Line ("Test_SSIA: zero allocation: unexpected exception");
end Zero_Allocation;
-- It should not be possible to allocate an object of negative size
Negative_Allocation : begin
SS_Allocate (Dummy_2, -8);
Put_Line ("Test_SSIA: ERROR: negative allocation succeeded");
exception
when Assertion_Error =>
Output ("After negative allocation");
when others =>
Put_Line ("Test_SSIA: negative allocation: unexpected exception");
end Negative_Allocation;
exception
when others =>
Put_Line ("Test_SSIA: unexpected exception");
end Test_Static_Stack_Illegal_Allocations;
--------------------------------
-- Test_Static_Stack_Overflow --
--------------------------------
procedure Test_Static_Stack_Overflow is
Info : constant Stack_Info := Get_Stack_Info (Get_Sec_Stack.all);
Dummy : Address;
begin
Output ("#### Test_SSO ####");
-- Try to overflow the static chunk
Overflow : begin
SS_Allocate (Dummy, Storage_Offset (Info.Default_Chunk_Size));
Put_Line ("Test_SSO: ERROR: Overflow not detected");
exception
when Storage_Error =>
Output ("After overflow");
when others =>
Put_Line ("Test_SSO: overflow: unexpected exception");
end Overflow;
exception
when others =>
Put_Line ("Test_SSO: unexpected exception");
end Test_Static_Stack_Overflow;
------------------------------------
-- Test_Static_Stack_Static_Chunk --
------------------------------------
procedure Test_Static_Stack_Static_Chunk is
Info : Stack_Info;
begin
Output ("#### Test_SSSC ####");
Info := Get_Stack_Info (Get_Sec_Stack.all);
Test_Static_Chunk (Info.Default_Chunk_Size);
exception
when others =>
Put_Line ("Test_SSSC: unexpected exception");
end Test_Static_Stack_Static_Chunk;
end System.Secondary_Stack.Tester;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with System.Parameters; use System.Parameters;
with System.Secondary_Stack.Tester; use System.Secondary_Stack.Tester;
procedure Main is
task Tester;
-- The various scenarios are tested within a task because this guarantees
-- that on a normal compilation, the task's secondary stack is created on
-- the heap and can be safely freed and replaced with a custom one.
task body Tester is
begin
if Sec_Stack_Dynamic then
Test_Dynamic_Stack_Static_Chunk;
Test_Dynamic_Stack_Dynamic_Chunks;
Test_Dynamic_Stack_Zero_Chunk_Size;
Test_Dynamic_Stack_Illegal_Allocations;
else
Test_Static_Stack_Static_Chunk;
Test_Static_Stack_Overflow;
Test_Static_Stack_Illegal_Allocations;
end if;
end Tester;
begin null; end Main;
-----------------
-- Compilation --
-----------------
$ gnatmake -a -f -q -gnata -gnatws main.adb
$ ./main
2018-05-30 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* libgnat/s-secsta.adb: Reimplement the secondary stack support.
* libgnat/s-secsta.ads: Update the documentation of all routines in the
public part of the package. Reimplement the private part of the
package to account for the new secondary stack structure. Add types
and subprograms for testing purposes. Add several documentation
sections.
From-SVN: r260924
projects / gcc.git / commit