------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--               S Y S T E M . S E C O N D A R Y _ S T A C K                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.14 $                              --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- 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 2,  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.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
--                                                                          --
------------------------------------------------------------------------------

with System;                    use System;
with System.Storage_Elements;   use System.Storage_Elements;
with System.Task_Specific_Data; use System.Task_Specific_Data;

with Unchecked_Conversion;
with Unchecked_Deallocation;

package body System.Secondary_Stack is

   --  This secondary stack implementation is a combinaison of 2 models. If
   --  there are fewer allocations during a Push Cycle than the size provided
   --  during Initialize then the stack behaves as an Array and no dynamic
   --  (de)allocation is performed. If the array runs out of space then a
   --  linked list of memory chunks is used (one chunk for each Allocate)
   --  and then dynamic (de)allocation is heavily used.


   --   Stack
   --
   --    +---------+      +--------------------------------------------------+
   --    | Heap  --|----> |  chunk of memory corresponding to 1 allocation   |
   --    +---------+      +--------------------------------------------------+
   --    | Mark    |
   --    +---------+
   --    | Prev |  |
   --    +------+--+
   --           |
   --           V
   --    +---------+     +--------------------+
   --    |       --|---->|                    |
   --    +---------+     +--------------------+
   --    |         |
   --    +---------+
   --    |      |  |
   --    +------+--+                        +--------------+
   --           |       +-----------------> |              | <-+
   --           V       |                   |              |   |
   --    +---------+    |                   |              |   |
   --    |       --|----+                   +- - - - - - - +   |
   --    +---------+                    +-> |     mark   --|---+
   --    |  mark --|--+                 |   +- - - - - -- -+
   --    +---------+  |                 |   |              |
   --    |  null   |  |                 |   |              |
   --    +---------+  |                 |   |              |
   --    (main stack) |                 |   +- - - - - - - +
   --                 +------------->   +---|--   mark     |
   --                                       +- - - - - - - +
   --                                       |              |
   --                                       |              |
   --                                       +--------------+
   --                                          (main array)

   type Memory is array (Mark_Id range <>) of Storage_Element;
   type Memory_Access is access Memory;

   --  Stack abstaction :

   --    Prev : if this field is Null is means that this stack elmt is the
   --           main stack. Otherwise the main stack has run out of space and
   --           this stack elmt is part of the auxiliary linked list of stacks

   --    Mark : for the main stack, gives the index of the first free memory
   --           element. Otherwise, is incremented by 1 for each new Stack elmt

   --    Heap : Contains the actual data. Only one allocation for each stack
   --           elmt other than the main stack where all allocations are
   --           separated by Marks which form a linked list inside the Heap.

   type Stack_Id;
   type Stack_Access is access Stack_Id;

   type Stack_Id is record
      Heap : Memory_Access;
      Mark : Mark_Id := Mark_Id'First;
      Prev : Stack_Access;
   end record;

   Mark_Length : constant Mark_Id := Mark_Id'Size / Storage_Unit;

   --  Package Convert is needed to peek and poke marks in memory

   package Convert is new Address_To_Access_Conversions (Mark_Id);
   use Convert;

   function To_Addr is new
     Unchecked_Conversion (Stack_Access, Address);

   function From_Addr is new
     Unchecked_Conversion (Address, Stack_Access);

   procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Access);
   procedure Free is new Unchecked_Deallocation (Memory, Memory_Access);

   -----------------
   -- SS_Allocate --
   -----------------

   function SS_Allocate (Size : Natural) return System.Address is
      Siz        : constant Mark_Id      := Mark_Id (Size);
      Stack_Addr : constant Address      := Get_Sec_Stack_Addr;
      Stack      : constant Stack_Access := From_Addr (Stack_Addr);
      Next_Mark  : constant Mark_Id      := Stack.Mark + Siz + Mark_Length;
      Res        : Address;

   begin
      --  Normal allocation

      if Stack.Prev = null
        and then Next_Mark < Stack.Heap'Last
      then
         --  The value of the next_mark if the index of previous mark

         To_Pointer (Stack.Heap (Next_Mark)'Address).all := Stack.Mark;
         Stack.Mark := Next_Mark;
         return Stack.Heap (Next_Mark - Siz)'Address;

      else
         declare
            S : Stack_Access := new Stack_Id;

         begin
            S.Heap := new Memory (Mark_Id'First .. Mark_Id'First + Siz - 1);
            S.Mark := Stack.Mark + 1;
            S.Prev := Stack;
            Set_Sec_Stack_Addr (To_Addr (S));
            return S.Heap (Mark_Id'First)'Address;
         end;
      end if;
   end SS_Allocate;

   -------------
   -- SS_Init --
   -------------

   procedure SS_Init (Stk : out Address; Size : Natural) is
      Stack : Stack_Access;

   begin
      Stack := new Stack_Id;
      Stack.Heap :=
        new Memory (Mark_Id'First .. Mark_Id'First + Mark_Id (Size) - 1);
      Stack.Mark := Mark_Id'First;
      Stack.Prev := null;
      Stk := To_Addr (Stack);
   end SS_Init;

   -------------
   -- SS_Free --
   -------------

   procedure SS_Free (Stk : Address) is
      Stack : Stack_Access := From_Addr (Stk);
      S     : Stack_Access := Stack;

   begin
      while Stack /= null loop
         Stack := Stack.Prev;
         Free (S.Heap);
         Free (S);
         S := Stack;
      end loop;
   end SS_Free;

   -------------
   -- SS_Mark --
   -------------

   function SS_Mark return Mark_Id is
      Stack_Addr : constant Address      := Get_Sec_Stack_Addr;
      Stack      : constant Stack_Access := From_Addr (Stack_Addr);

   begin
      return Stack.Mark;
   end SS_Mark;

   ----------------
   -- SS_Release --
   ----------------

   procedure SS_Release (M : Mark_Id) is
      Stack_Addr : constant Address := Get_Sec_Stack_Addr;
      Stack      : Stack_Access     := From_Addr (Stack_Addr);

   begin
      --  Deallocation of the overflow list

      while Stack.Mark /= M  and then Stack.Prev /= null loop
         declare
            S : Stack_Access := Stack;

         begin
            Stack := Stack.Prev;
            Set_Sec_Stack_Addr (To_Addr (Stack));
            Free (S.Heap);
            Free (S);
         end;
      end loop;

      --  Deallocation of the main secondary stack

      while Stack.Mark /= M  loop
         Stack.Mark := To_Pointer (Stack.Heap (Stack.Mark)'Address).all;
      end loop;
   end SS_Release;

   -------------
   -- SS_Info --
   -------------

   procedure SS_Info is
      Stack_Addr : constant Address := Get_Sec_Stack_Addr;
      S          : Stack_Access := From_Addr (Stack_Addr);
      Nb_Blocks  : Integer := 0;
      Total_Size : Integer := 0;

   begin
      Put_Line ("Secondary Stack information:");

      while S.Prev /= null loop
         Nb_Blocks := Nb_Blocks + 1;
         Total_Size := Total_Size + Integer (S.Heap.all'Last + 1);
         S := S.Prev;
      end loop;

      --  Main Block information

      Put_Line (
        "  Size of Main Block:          "
        & Mark_Id'Image (S.Heap.all'Last + 1)
        & " bytes");
      Put_Line (
        "  free space in Main Block:    "
        & Mark_Id'Image (S.Heap.all'Last - S.Mark)
        & " bytes");

      --  Secondary blocks information

      if Nb_Blocks > 0 then
         Put_Line (
           "  Number of additionnal blocks:" & Integer'Image (Nb_Blocks));
         Put_Line (
           "  Total allocated space in additional blocks:"
           & Integer'Image (Total_Size)
           & " bytes");
      end if;
   end SS_Info;

end System.Secondary_Stack;
