Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

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

--                                                                          --

--          Copyright (C) 1992-2005, 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 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,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- As a special exception,  if other files  instantiate  generics from this --

-- unit, or you link  this unit with other files  to produce an executable, --

-- this  unit  does not  by itself cause  the resulting  executable  to  be --

-- covered  by the  GNU  General  Public  License.  This exception does not --

-- however invalidate  any other reasons why  the executable file  might be --

-- covered by the  GNU Public License.                                      --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with System.Soft_Links;

with System.Parameters;

with Unchecked_Conversion;

with Unchecked_Deallocation;

package body System.Secondary_Stack is

   package SSL renames System.Soft_Links;

   use type SSE.Storage_Offset;

   use type System.Parameters.Size_Type;

   SS_Ratio_Dynamic : constant Boolean :=

                        Parameters.Sec_Stack_Ratio = Parameters.Dynamic;

   --  There are two entirely different implementations of the secondary

   --  stack mechanism in this unit, and this Boolean is used to select

   --  between them (at compile time, so the generated code will contain

   --  only the code for the desired variant). If SS_Ratio_Dynamic is

   --  True, then the secondary stack is dynamically allocated from the

   --  heap in a linked list of chunks. If SS_Ration_Dynamic is False,

   --  then the secondary stack is allocated statically by grabbing a

   --  section of the primary stack and using it for this purpose.

   type Memory is array (SS_Ptr range <>) of SSE.Storage_Element;

   for Memory'Alignment use Standard'Maximum_Alignment;

   --  This is the type used for actual allocation of secondary stack

   --  areas. We require maximum alignment for all such allocations.

   ---------------------------------------------------------------

   -- Data Structures for Dynamically Allocated Secondary Stack --

   ---------------------------------------------------------------

   --  The following is a diagram of the data structures used for the

   --  case of a dynamically allocated secondary stack, where the stack

   --  is allocated as a linked list of chunks allocated from the heap.

   --                                      +------------------+

   --                                      |       Next       |

   --                                      +------------------+

   --                                      |                  | Last (200)

   --                                      |                  |

   --                                      |                  |

   --                                      |                  |

   --                                      |                  |

   --                                      |                  |

   --                                      |                  | First (101)

   --                                      +------------------+

   --                         +----------> |          |       |

   --                         |            +----------+-------+

   --                         |                    |  |

   --                         |                    ^  V

   --                         |                    |  |

   --                         |            +-------+----------+

   --                         |            |       |          |

   --                         |            +------------------+

   --                         |            |                  | Last (100)

   --                         |            |         C        |

   --                         |            |         H        |

   --    +-----------------+  |  +-------->|         U        |

   --    |  Current_Chunk -|--+  |         |         N        |

   --    +-----------------+     |         |         K        |

   --    |       Top      -|-----+         |                  | First (1)

   --    +-----------------+               +------------------+

   --    | Default_Size    |               |       Prev       |

   --    +-----------------+               +------------------+

   --

   type Chunk_Id (First, Last : SS_Ptr);

   type Chunk_Ptr is access all Chunk_Id;

   type Chunk_Id (First, Last : SS_Ptr) is record

      Prev, Next : Chunk_Ptr;

      Mem        : Memory (First .. Last);

   end record;

   type Stack_Id is record

      Top           : SS_Ptr;

      Default_Size  : SSE.Storage_Count;

      Current_Chunk : Chunk_Ptr;

   end record;

   type Stack_Ptr is access Stack_Id;

   --  Pointer to record used to represent a dynamically allocated secondary

   --  stack descriptor for a secondary stack chunk.

   procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);

   --  Free a dynamically allocated chunk

   function To_Stack_Ptr is new

     Unchecked_Conversion (Address, Stack_Ptr);

   function To_Addr is new

     Unchecked_Conversion (Stack_Ptr, Address);

   --  Convert to and from address stored in task data structures

   --------------------------------------------------------------

   -- Data Structures for Statically Allocated Secondary Stack --

   --------------------------------------------------------------

   --  For the static case, the secondary stack is a single contiguous

   --  chunk of storage, carved out of the primary stack, and represented

   --  by the following data strcuture

   type Fixed_Stack_Id is record

      Top : SS_Ptr;

      --  Index of next available location in Mem. This is initialized to

      --  0, and then incremented on Allocate, and Decremented on Release.

      Last : SS_Ptr;

      --  Length of usable Mem array, which is thus the index past the

      --  last available location in Mem. Mem (Last-1) can be used. This

      --  is used to check that the stack does not overflow.

      Max : SS_Ptr;

      --  Maximum value of Top. Initialized to 0, and then may be incremented

      --  on Allocate, but is never Decremented. The last used location will

      --  be Mem (Max - 1), so Max is the maximum count of used stack space.

      Mem : Memory (0 .. 0);

      --  This is the area that is actually used for the secondary stack.

      --  Note that the upper bound is a dummy value properly defined by

      --  the value of Last. We never actually allocate objects of type

      --  Fixed_Stack_Id, so the bounds declared here do not matter.

   end record;

   Dummy_Fixed_Stack : Fixed_Stack_Id;

   pragma Warnings (Off, Dummy_Fixed_Stack);

   --  Well it is not quite true that we never allocate an object of the

   --  type. This dummy object is allocated for the purpose of getting the

   --  offset of the Mem field via the 'Position attribute (such a nuisance

   --  that we cannot apply this to a field of a type!)

   type Fixed_Stack_Ptr is access Fixed_Stack_Id;

   --  Pointer to record used to describe statically allocated sec stack

   function To_Fixed_Stack_Ptr is new

     Unchecked_Conversion (Address, Fixed_Stack_Ptr);

   --  Convert from address stored in task data structures

   --------------

   -- Allocate --

   --------------

   procedure SS_Allocate

     (Addr         : out Address;

      Storage_Size : SSE.Storage_Count)

   is

      Max_Align    : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);

      Max_Size     : constant SS_Ptr :=

                       ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align)

                         * Max_Align;

   begin

      --  Case of fixed allocation secondary stack

      if not SS_Ratio_Dynamic then

         declare

            Fixed_Stack : constant Fixed_Stack_Ptr :=

                            To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);

         begin

            --  Check if max stack usage is increasing

            if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then

               --  If so, check if max size is exceeded

               if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then

                  raise Storage_Error;

               end if;

               --  Record new max usage

               Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;

            end if;

            --  Set resulting address and update top of stack pointer

            Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;

            Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;

         end;

      --  Case of dynamically allocated secondary stack

      else

         declare

            Stack : constant Stack_Ptr :=

                      To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);

            Chunk : Chunk_Ptr;

            To_Be_Released_Chunk : Chunk_Ptr;

         begin

            Chunk := Stack.Current_Chunk;

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

                  --  Release unused non-first empty chunk

                  if Chunk.Prev /= null and then Chunk.First = Stack.Top then

                     To_Be_Released_Chunk := Chunk;

                     Chunk := Chunk.Prev;

                     Chunk.Next := To_Be_Released_Chunk.Next;

                     To_Be_Released_Chunk.Next.Prev := Chunk;

                     Free (To_Be_Released_Chunk);

                  end if;

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

                  --  sufficient to satisfy the current request.

               elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then

                  Chunk.Next :=

                    new Chunk_Id

                      (First => Chunk.Last + 1,

                       Last  => Chunk.Last + SS_Ptr (Stack.Default_Size));

                  Chunk.Next.Prev := Chunk;

                  --  Otherwise create new chunk of requested size

               else

                  Chunk.Next :=

                    new Chunk_Id

                      (First => Chunk.Last + 1,

                       Last  => Chunk.Last + Max_Size);

                  Chunk.Next.Prev := Chunk;

               end if;

               Chunk     := Chunk.Next;

               Stack.Top := Chunk.First;

            end loop;

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

            Addr                := Chunk.Mem (Stack.Top)'Address;

            Stack.Top           := Stack.Top + Max_Size;

            Stack.Current_Chunk := Chunk;

         end;

      end if;

   end SS_Allocate;

   -------------

   -- SS_Free --

   -------------

   procedure SS_Free (Stk : in out Address) is

   begin

      --  Case of statically allocated secondary stack, nothing to free

      if not SS_Ratio_Dynamic then

         return;

      --  Case of dynamically allocated secondary stack

      else

         declare

            Stack : Stack_Ptr := To_Stack_Ptr (Stk);

            Chunk : Chunk_Ptr;

            procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);

         begin

            Chunk := Stack.Current_Chunk;

            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);

            Stk := Null_Address;

         end;

      end if;

   end SS_Free;

   ----------------

   -- SS_Get_Max --

   ----------------

   function SS_Get_Max return Long_Long_Integer is

   begin

      if SS_Ratio_Dynamic then

         return -1;

      else

         declare

            Fixed_Stack : constant Fixed_Stack_Ptr :=

                            To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);

         begin

            return Long_Long_Integer (Fixed_Stack.Max);

         end;

      end if;

   end SS_Get_Max;

   -------------

   -- SS_Info --

   -------------

   procedure SS_Info is

   begin

      Put_Line ("Secondary Stack information:");

      --  Case of fixed secondary stack

      if not SS_Ratio_Dynamic then

         declare

            Fixed_Stack : constant Fixed_Stack_Ptr :=

                            To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);

         begin

            Put_Line (

                      "  Total size              : "

                      & SS_Ptr'Image (Fixed_Stack.Last)

                      & " bytes");

            Put_Line (

                      "  Current allocated space : "

                      & SS_Ptr'Image (Fixed_Stack.Top - 1)

                      & " bytes");

         end;

      --  Case of dynamically allocated secondary stack

      else

         declare

            Stack     : constant Stack_Ptr :=

                          To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);

            Nb_Chunks : Integer   := 1;

            Chunk     : Chunk_Ptr := Stack.Current_Chunk;

         begin

            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              : "

                      & SS_Ptr'Image (Chunk.Last)

                      & " bytes");

            Put_Line (

                      "  Current allocated space : "

                      & SS_Ptr'Image (Stack.Top - 1)

                      & " bytes");

            Put_Line (

                      "  Number of Chunks       : "

                      & Integer'Image (Nb_Chunks));

            Put_Line (

                      "  Default size of Chunks : "

                      & SSE.Storage_Count'Image (Stack.Default_Size));

         end;

      end if;

   end SS_Info;

   -------------

   -- SS_Init --

   -------------

   procedure SS_Init

     (Stk  : in out Address;

      Size : Natural := Default_Secondary_Stack_Size)

   is

   begin

      --  Case of fixed size secondary stack

      if not SS_Ratio_Dynamic then

         declare

            Fixed_Stack : constant Fixed_Stack_Ptr :=

                            To_Fixed_Stack_Ptr (Stk);

         begin

            Fixed_Stack.Top  := 0;

            Fixed_Stack.Max  := 0;

            if Size < Dummy_Fixed_Stack.Mem'Position then

               Fixed_Stack.Last := 0;

            else

               Fixed_Stack.Last :=

                 SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;

            end if;

         end;

      --  Case of dynamically allocated secondary stack

      else

         declare

            Stack : Stack_Ptr;

         begin

            Stack               := new Stack_Id;

            Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));

            Stack.Top           := 1;

            Stack.Default_Size  := SSE.Storage_Count (Size);

            Stk := To_Addr (Stack);

         end;

      end if;

   end SS_Init;

   -------------

   -- SS_Mark --

   -------------

   function SS_Mark return Mark_Id is

      Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;

   begin

      if SS_Ratio_Dynamic then

         return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);

      else

         return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);

      end if;

   end SS_Mark;

   ----------------

   -- SS_Release --

   ----------------

   procedure SS_Release (M : Mark_Id) is

   begin

      if SS_Ratio_Dynamic then

         To_Stack_Ptr (M.Sstk).Top := M.Sptr;

      else

         To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;

      end if;

   end SS_Release;

   -------------------------

   -- Package Elaboration --

   -------------------------

   --  Allocate a secondary stack for the main program to use

   --  We make sure that the stack has maximum alignment. Some systems require

   --  this (e.g. Sun), and in any case it is a good idea for efficiency.

   Stack : aliased Stack_Id;

   for Stack'Alignment use Standard'Maximum_Alignment;

   Chunk : aliased Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));

   for Chunk'Alignment use Standard'Maximum_Alignment;

   Chunk_Address : Address;

begin

   if SS_Ratio_Dynamic then

      Stack.Top           := 1;

      Stack.Current_Chunk := Chunk'Access;

      Stack.Default_Size  := SSE.Storage_Offset (Default_Secondary_Stack_Size);

      System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);

   else

      Chunk_Address := Chunk'Address;

      SS_Init (Chunk_Address, Default_Secondary_Stack_Size);

      System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);

   end if;

end System.Secondary_Stack;