gcc/ada/s-secsta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --               S Y S T E M . S E C O N D A R Y _ S T A C K                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Soft_Links;
  35 with System.Parameters;
  36 with Unchecked_Conversion;
  37 with Unchecked_Deallocation;
  38
  39 package body System.Secondary_Stack is
  40
  41    package SSL renames System.Soft_Links;
  42
  43    use type SSE.Storage_Offset;
  44    use type System.Parameters.Size_Type;
  45
  46    SS_Ratio_Dynamic : constant Boolean :=
  47                         Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
  48
  49    --                                      +------------------+
  50    --                                      |       Next       |
  51    --                                      +------------------+
  52    --                                      |                  | Last (200)
  53    --                                      |                  |
  54    --                                      |                  |
  55    --                                      |                  |
  56    --                                      |                  |
  57    --                                      |                  |
  58    --                                      |                  | First (101)
  59    --                                      +------------------+
  60    --                         +----------> |          |       |
  61    --                         |            +----------+-------+
  62    --                         |                    |  |
  63    --                         |                    ^  V
  64    --                         |                    |  |
  65    --                         |            +-------+----------+
  66    --                         |            |       |          |
  67    --                         |            +------------------+
  68    --                         |            |                  | Last (100)
  69    --                         |            |         C        |
  70    --                         |            |         H        |
  71    --    +-----------------+  |  +-------->|         U        |
  72    --    |  Current_Chunk -|--+  |         |         N        |
  73    --    +-----------------+     |         |         K        |
  74    --    |       Top      -|-----+         |                  | First (1)
  75    --    +-----------------+               +------------------+
  76    --    | Default_Size    |               |       Prev       |
  77    --    +-----------------+               +------------------+
  78    --
  79    --
  80    type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
  81
  82    type Chunk_Id (First, Last : Mark_Id);
  83    type Chunk_Ptr is access all Chunk_Id;
  84
  85    type Chunk_Id (First, Last : Mark_Id) is record
  86       Prev, Next : Chunk_Ptr;
  87       Mem        : Memory (First .. Last);
  88    end record;
  89
  90    type Stack_Id is record
  91       Top           : Mark_Id;
  92       Default_Size  : SSE.Storage_Count;
  93       Current_Chunk : Chunk_Ptr;
  94    end record;
  95
  96    type Fixed_Stack_Id is record
  97       Top  : Mark_Id;
  98       Last : Mark_Id;
  99       Mem  : Memory (1 .. Mark_Id'Last / 2 - 1);
 100       --  This should really be 1 .. Mark_Id'Last, but there is a bug in gigi
 101       --  with this type, introduced Sep 2001, that causes gigi to reject this
 102       --  type because its size in bytes overflows ???
 103    end record;
 104
 105    type Stack_Ptr is access Stack_Id;
 106    type Fixed_Stack_Ptr is access Fixed_Stack_Id;
 107
 108    function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr);
 109    function To_Addr   is new Unchecked_Conversion (Stack_Ptr, System.Address);
 110    function To_Fixed  is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr);
 111
 112    procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
 113
 114    --------------
 115    -- Allocate --
 116    --------------
 117
 118    procedure SS_Allocate
 119      (Address      : out System.Address;
 120       Storage_Size : SSE.Storage_Count)
 121    is
 122       Stack        : constant Stack_Ptr :=
 123                        From_Addr (SSL.Get_Sec_Stack_Addr.all);
 124       Fixed_Stack  : Fixed_Stack_Ptr;
 125       Chunk        : Chunk_Ptr;
 126       Max_Align    : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
 127       Max_Size     : constant Mark_Id :=
 128                        ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
 129                          * Max_Align;
 130
 131       To_Be_Released_Chunk : Chunk_Ptr;
 132
 133    begin
 134       --  If the secondary stack is fixed in the primary stack, then the
 135       --  handling becomes simple
 136
 137       if not SS_Ratio_Dynamic then
 138          Fixed_Stack := To_Fixed (Stack);
 139
 140          if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
 141             raise Storage_Error;
 142          end if;
 143
 144          Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
 145          Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size);
 146          return;
 147       end if;
 148
 149       Chunk := Stack.Current_Chunk;
 150
 151       --  The Current_Chunk may not be the good one if a lot of release
 152       --  operations have taken place. So go down the stack if necessary
 153
 154       while  Chunk.First > Stack.Top loop
 155          Chunk := Chunk.Prev;
 156       end loop;
 157
 158       --  Find out if the available memory in the current chunk is sufficient.
 159       --  if not, go to the next one and eventally create the necessary room
 160
 161       while Chunk.Last - Stack.Top + 1 < Max_Size loop
 162          if Chunk.Next /= null then
 163
 164             --  Release unused non-first empty chunk
 165
 166             if Chunk.Prev /= null and then Chunk.First = Stack.Top then
 167                To_Be_Released_Chunk := Chunk;
 168                Chunk := Chunk.Prev;
 169                Chunk.Next := To_Be_Released_Chunk.Next;
 170                To_Be_Released_Chunk.Next.Prev := Chunk;
 171                Free (To_Be_Released_Chunk);
 172             end if;
 173
 174          --  Create new chunk of the default size unless it is not sufficient
 175
 176          elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
 177             Chunk.Next := new Chunk_Id (
 178               First => Chunk.Last + 1,
 179               Last  => Chunk.Last + Mark_Id (Stack.Default_Size));
 180
 181             Chunk.Next.Prev := Chunk;
 182
 183          else
 184             Chunk.Next := new Chunk_Id (
 185               First => Chunk.Last + 1,
 186               Last  => Chunk.Last + Max_Size);
 187
 188             Chunk.Next.Prev := Chunk;
 189          end if;
 190
 191          Chunk     := Chunk.Next;
 192          Stack.Top := Chunk.First;
 193       end loop;
 194
 195       --  Resulting address is the address pointed by Stack.Top
 196
 197       Address      := Chunk.Mem (Stack.Top)'Address;
 198       Stack.Top    := Stack.Top + Max_Size;
 199       Stack.Current_Chunk := Chunk;
 200    end SS_Allocate;
 201
 202    -------------
 203    -- SS_Free --
 204    -------------
 205
 206    procedure SS_Free (Stk : in out System.Address) is
 207       Stack : Stack_Ptr;
 208       Chunk : Chunk_Ptr;
 209
 210       procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
 211
 212    begin
 213       if not SS_Ratio_Dynamic then
 214          return;
 215       end if;
 216
 217       Stack := From_Addr (Stk);
 218       Chunk := Stack.Current_Chunk;
 219
 220       while Chunk.Prev /= null loop
 221          Chunk := Chunk.Prev;
 222       end loop;
 223
 224       while Chunk.Next /= null loop
 225          Chunk := Chunk.Next;
 226          Free (Chunk.Prev);
 227       end loop;
 228
 229       Free (Chunk);
 230       Free (Stack);
 231       Stk := Null_Address;
 232    end SS_Free;
 233
 234    -------------
 235    -- SS_Info --
 236    -------------
 237
 238    procedure SS_Info is
 239       Stack       : constant Stack_Ptr :=
 240                       From_Addr (SSL.Get_Sec_Stack_Addr.all);
 241       Fixed_Stack : Fixed_Stack_Ptr;
 242       Nb_Chunks   : Integer            := 1;
 243       Chunk       : Chunk_Ptr          := Stack.Current_Chunk;
 244
 245    begin
 246       Put_Line ("Secondary Stack information:");
 247
 248       if not SS_Ratio_Dynamic then
 249          Fixed_Stack := To_Fixed (Stack);
 250          Put_Line (
 251            "  Total size              : "
 252            & Mark_Id'Image (Fixed_Stack.Last)
 253            & " bytes");
 254          Put_Line (
 255            "  Current allocated space : "
 256            & Mark_Id'Image (Fixed_Stack.Top - 1)
 257            & " bytes");
 258          return;
 259       end if;
 260
 261       while Chunk.Prev /= null loop
 262          Chunk := Chunk.Prev;
 263       end loop;
 264
 265       while Chunk.Next /= null loop
 266          Nb_Chunks := Nb_Chunks + 1;
 267          Chunk := Chunk.Next;
 268       end loop;
 269
 270       --  Current Chunk information
 271
 272       Put_Line (
 273         "  Total size              : "
 274         & Mark_Id'Image (Chunk.Last)
 275         & " bytes");
 276       Put_Line (
 277         "  Current allocated space : "
 278         & Mark_Id'Image (Stack.Top - 1)
 279         & " bytes");
 280
 281       Put_Line (
 282         "  Number of Chunks       : "
 283         & Integer'Image (Nb_Chunks));
 284
 285       Put_Line (
 286         "  Default size of Chunks : "
 287         & SSE.Storage_Count'Image (Stack.Default_Size));
 288    end SS_Info;
 289
 290    -------------
 291    -- SS_Init --
 292    -------------
 293
 294    procedure SS_Init
 295      (Stk  : in out System.Address;
 296       Size : Natural := Default_Secondary_Stack_Size)
 297    is
 298       Stack : Stack_Ptr;
 299       Fixed_Stack : Fixed_Stack_Ptr;
 300
 301    begin
 302       if not SS_Ratio_Dynamic then
 303          Fixed_Stack      := To_Fixed (From_Addr (Stk));
 304          Fixed_Stack.Top  := Fixed_Stack.Mem'First;
 305
 306          if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then
 307             Fixed_Stack.Last := 0;
 308          else
 309             Fixed_Stack.Last := Mark_Id (Size) -
 310               2 * Mark_Id'Max_Size_In_Storage_Elements;
 311          end if;
 312
 313          return;
 314       end if;
 315
 316       Stack               := new Stack_Id;
 317       Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
 318       Stack.Top           := 1;
 319       Stack.Default_Size  := SSE.Storage_Count (Size);
 320
 321       Stk := To_Addr (Stack);
 322    end SS_Init;
 323
 324    -------------
 325    -- SS_Mark --
 326    -------------
 327
 328    function SS_Mark return Mark_Id is
 329    begin
 330       return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top;
 331    end SS_Mark;
 332
 333    ----------------
 334    -- SS_Release --
 335    ----------------
 336
 337    procedure SS_Release (M : Mark_Id) is
 338    begin
 339       From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M;
 340    end SS_Release;
 341
 342    -------------------------
 343    -- Package Elaboration --
 344    -------------------------
 345
 346    --  Allocate a secondary stack for the main program to use.
 347    --  We make sure that the stack has maximum alignment. Some systems require
 348    --  this (e.g. Sun), and in any case it is a good idea for efficiency.
 349
 350    Stack : aliased Stack_Id;
 351    for Stack'Alignment use Standard'Maximum_Alignment;
 352
 353    Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size);
 354    for Chunk'Alignment use Standard'Maximum_Alignment;
 355
 356    Chunk_Address : System.Address;
 357
 358 begin
 359    if SS_Ratio_Dynamic then
 360       Stack.Top           := 1;
 361       Stack.Current_Chunk := Chunk'Access;
 362       Stack.Default_Size  := Default_Secondary_Stack_Size;
 363       System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
 364
 365    else
 366       Chunk_Address := Chunk'Address;
 367       SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
 368       System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
 369    end if;
 370 end System.Secondary_Stack;