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