Geek Gadgets 1/ADE-1.bin/ade-bin/lib/gcc-lib/m68k-amigaos/2.7.2.1/adainclude/s-secsta.adb

Text File | 1995-10-17 | 9.9 KB | 294 lines

------------------------------------------------------------------------------
--                                                                          --
--                         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.24 $                             --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

with System.Task_Specific_Data;
with System.Tasking_Soft_Links;
with Unchecked_Conversion;
with Unchecked_Deallocation;

package body System.Secondary_Stack is



   --                                      +------------------+
   --                                      |       Next       |
   --                                      +------------------+
   --                                      |                  | Last (200)
   --                                      |                  |
   --                                      |                  |
   --                                      |                  |
   --                                      |                  |
   --                                      |                  |
   --                                      |                  | First (101)
   --                                      +------------------+
   --                         +----------> |          |       |
   --                         |            +----------+-------+
   --                         |                    |  |
   --                         |                    ^  V
   --                         |                    |  |
   --                         |            +-------+----------+
   --                         |            |       |          |
   --                         |            +------------------+
   --                         |            |                  | Last (100)
   --                         |            |         C        |
   --                         |            |         H        |
   --    +-----------------+  |  +-------->|         U        |
   --    |  Current_Chunk -|--+  |         |         N        |
   --    +-----------------+     |         |         K        |
   --    |       Top      -|-----+         |                  | First (1)
   --    +-----------------+               +------------------+
   --    | Default_Size    |               |       Prev       |
   --    +-----------------+               +------------------+
   --
   --

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

   type Chunk_Id (First, Last : Mark_Id);
   type Chunk_Ptr is access Chunk_Id;

   type Chunk_Id (First, Last : Mark_Id) is record
      Prev, Next : Chunk_Ptr;
      Mem        : Memory (First .. Last);
   end record;

   type Stack_Id is record
      Top           : Mark_Id;
      Current_Chunk : Chunk_Ptr;
      Default_Size  : Storage_Count;
   end record;

   type Stack_Ptr is access Stack_Id;

   function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr);
   function To_Addr   is new Unchecked_Conversion (Stack_Ptr, System.Address);

   ------------------
   -- Storage_Size --
   ------------------

   function Storage_Size (Pool : Secondary_Stack_Pool) return Storage_Count is
      Stack : constant Stack_Ptr
        := From_Addr (System.Task_Specific_Data.Get_Sec_Stack_Addr);
      Chunk : Chunk_Ptr := Stack.Current_Chunk;

   begin
      while Chunk.Next /= null loop
         Chunk := Chunk.Next;
      end loop;

      return Storage_Count (Chunk.Last);
   end Storage_Size;

   --------------
   -- Allocate --
   --------------

   procedure Allocate
     (Pool         : in out Secondary_Stack_Pool;
      Address      : out System.Address;
      Storage_Size : Storage_Count;
      Alignment    : Storage_Count)
   is
      Stack        : constant Stack_Ptr :=
                       From_Addr
                         (System.Task_Specific_Data.Get_Sec_Stack_Addr);
      Chunk        : Chunk_Ptr := Stack.Current_Chunk;
      Max_Size     : constant Mark_Id := Mark_Id (Storage_Size + Alignment);
      Align_Offset : Storage_Count;

   begin
      --  The Current_Chunk may not be the good one if a lot of release
      --  operations have taken place. So go down the stack if necessary

      while  Chunk.First > Stack.Top loop
         Chunk := Chunk.Prev;
      end loop;

      --  Find out if the available memory in the current chunk is sufficient.
      --  if not, go to the next one and eventally create the necessary room

      while Chunk.Last - Stack.Top + 1 < Max_Size loop
         if Chunk.Next /= null then
            Chunk := Chunk.Next;

         --  Create new chunk of the default size unless it is not sufficient

         elsif Storage_Count (Max_Size) <= Stack.Default_Size then
            Chunk.Next := new Chunk_Id (
              First => Chunk.Last + 1,
              Last  => Chunk.Last + Mark_Id (Stack.Default_Size));

            Chunk.Next.Prev := Chunk;

         else
            Chunk.Next := new Chunk_Id (
              First => Chunk.Last + 1,
              Last  => Chunk.Last + Max_Size);

            Chunk.Next.Prev := Chunk;
         end if;

         Stack.Top := Chunk.First;
      end loop;

      --  Resulting address is the address pointed by Stack.Top

      Address      := Chunk.Mem (Stack.Top)'Address;
      Align_Offset := Address mod Alignment;
      Stack.Top    := Stack.Top + Mark_Id (Storage_Size);

      if Align_Offset /= 0 then
         Address := Address + Alignment - Align_Offset;
         Stack.Top := Stack.Top + Mark_Id (Alignment - Align_Offset);
      end if;

      Stack.Current_Chunk := Chunk;
   end Allocate;

   ----------------
   -- Deallocate --
   ----------------

   --  Nothing to do, since space is released by an unmark operation

   procedure Deallocate
     (Pool         : in out Secondary_Stack_Pool;
      Address      : System.Address;
      Storage_Size : Storage_Count;
      Alignment    : Storage_Count)
   is
   begin
      null;
   end Deallocate;

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

   procedure SS_Init (Stk : out System.Address; Size : Natural) is
      Stack : Stack_Ptr;

   begin
      Stack               := new Stack_Id;
      Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
      Stack.Top           := 1;
      Stack.Default_Size  := Storage_Count (Size);

      Stk := To_Addr (Stack);
   end SS_Init;

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

   procedure SS_Free (Stk : System.Address) is
      Stack : Stack_Ptr := From_Addr (Stk);
      Chunk : Chunk_Ptr := Stack.Current_Chunk;

      procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
      procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);

   begin
      while Chunk.Prev /= null loop
         Chunk := Chunk.Prev;
      end loop;

      while Chunk.Next /= null loop
         Chunk := Chunk.Next;
         Free (Chunk.Prev);
      end loop;

      Free (Chunk);
      Free (Stack);
   end SS_Free;

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

   function SS_Mark return Mark_Id is
   begin
      return From_Addr (System.Task_Specific_Data.Get_Sec_Stack_Addr).Top;
   end SS_Mark;

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

   procedure SS_Release (M : Mark_Id) is
   begin
      From_Addr (System.Task_Specific_Data.Get_Sec_Stack_Addr).Top := M;
   end SS_Release;

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

   procedure SS_Info is
      Stack     : constant Stack_Ptr :=
                    From_Addr
                      (System.Task_Specific_Data.Get_Sec_Stack_Addr);
      Nb_Chunks : Integer            := 1;
      Chunk     : Chunk_Ptr          := Stack.Current_Chunk;

   begin
      Put_Line ("Secondary Stack information:");

      while Chunk.Prev /= null loop
         Chunk := Chunk.Prev;
      end loop;

      while Chunk.Next /= null loop
         Nb_Chunks := Nb_Chunks + 1;
         Chunk := Chunk.Next;
      end loop;

      --  Current Chunk information

      Put_Line (
        "  Total size              : "
        & Mark_Id'Image (Chunk.Last)
        & " bytes");
      Put_Line (
        "  Current allocated space : "
        & Mark_Id'Image (Stack.Top - 1)
        & " bytes");

      Put_Line (
        "  Number of Chunks       : "
        & Integer'Image (Nb_Chunks));

      Put_Line (
        "  Default size of Chunks : "
        & Storage_Count'Image (Stack.Default_Size));
   end SS_Info;

begin
   System.Tasking_Soft_Links.SS_Init := SS_Init'Access;
   System.Tasking_Soft_Links.SS_Free := SS_Free'Access;

end System.Secondary_Stack;