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       Count_Unreleased_Chunks : Natural;
 132       To_Be_Released_Chunk    : Chunk_Ptr;
 133
 134    begin
 135       --  If the secondary stack is fixed in the primary stack, then the
 136       --  handling becomes simple
 137
 138       if not SS_Ratio_Dynamic then
 139          Fixed_Stack := To_Fixed (Stack);
 140
 141          if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
 142             raise Storage_Error;
 143          end if;
 144
 145          Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
 146          Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size);
 147          return;
 148       end if;
 149
 150       Chunk := Stack.Current_Chunk;
 151
 152       --  The Current_Chunk may not be the good one if a lot of release
 153       --  operations have taken place. So go down the stack if necessary
 154
 155       while  Chunk.First > Stack.Top loop
 156          Chunk := Chunk.Prev;
 157       end loop;
 158
 159       --  Find out if the available memory in the current chunk is sufficient.
 160       --  if not, go to the next one and eventally create the necessary room
 161
 162       Count_Unreleased_Chunks := 0;
 163
 164       while Chunk.Last - Stack.Top + 1 < Max_Size loop
 165          if Chunk.Next /= null then
 166
 167             --  Release unused non-first empty chunk
 168
 169             if Chunk.Prev /= null and then Chunk.First = Stack.Top then
 170                To_Be_Released_Chunk := Chunk;
 171                Chunk := Chunk.Prev;
 172                Chunk.Next := To_Be_Released_Chunk.Next;
 173                To_Be_Released_Chunk.Next.Prev := Chunk;
 174                Free (To_Be_Released_Chunk);
 175             end if;
 176
 177          --  Create new chunk of the default size unless it is not sufficient
 178
 179          elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
 180             Chunk.Next := new Chunk_Id (
 181               First => Chunk.Last + 1,
 182               Last  => Chunk.Last + Mark_Id (Stack.Default_Size));
 183
 184             Chunk.Next.Prev := Chunk;
 185
 186          else
 187             Chunk.Next := new Chunk_Id (
 188               First => Chunk.Last + 1,
 189               Last  => Chunk.Last + Max_Size);
 190
 191             Chunk.Next.Prev := Chunk;
 192          end if;
 193
 194          Chunk     := Chunk.Next;
 195          Stack.Top := Chunk.First;
 196       end loop;
 197
 198       --  Resulting address is the address pointed by Stack.Top
 199
 200       Address      := Chunk.Mem (Stack.Top)'Address;
 201       Stack.Top    := Stack.Top + Max_Size;
 202       Stack.Current_Chunk := Chunk;
 203    end SS_Allocate;
 204
 205    -------------
 206    -- SS_Free --
 207    -------------
 208
 209    procedure SS_Free (Stk : in out System.Address) is
 210       Stack : Stack_Ptr;
 211       Chunk : Chunk_Ptr;
 212
 213       procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
 214
 215    begin
 216       if not SS_Ratio_Dynamic then
 217          return;
 218       end if;
 219
 220       Stack := From_Addr (Stk);
 221       Chunk := Stack.Current_Chunk;
 222
 223       while Chunk.Prev /= null loop
 224          Chunk := Chunk.Prev;
 225       end loop;
 226
 227       while Chunk.Next /= null loop
 228          Chunk := Chunk.Next;
 229          Free (Chunk.Prev);
 230       end loop;
 231
 232       Free (Chunk);
 233       Free (Stack);
 234       Stk := Null_Address;
 235    end SS_Free;
 236
 237    -------------
 238    -- SS_Info --
 239    -------------
 240
 241    procedure SS_Info is
 242       Stack       : constant Stack_Ptr :=
 243                       From_Addr (SSL.Get_Sec_Stack_Addr.all);
 244       Fixed_Stack : Fixed_Stack_Ptr;
 245       Nb_Chunks   : Integer            := 1;
 246       Chunk       : Chunk_Ptr          := Stack.Current_Chunk;
 247
 248    begin
 249       Put_Line ("Secondary Stack information:");
 250
 251       if not SS_Ratio_Dynamic then
 252          Fixed_Stack := To_Fixed (Stack);
 253          Put_Line (
 254            "  Total size              : "
 255            & Mark_Id'Image (Fixed_Stack.Last)
 256            & " bytes");
 257          Put_Line (
 258            "  Current allocated space : "
 259            & Mark_Id'Image (Fixed_Stack.Top - 1)
 260            & " bytes");
 261          return;
 262       end if;
 263
 264       while Chunk.Prev /= null loop
 265          Chunk := Chunk.Prev;
 266       end loop;
 267
 268       while Chunk.Next /= null loop
 269          Nb_Chunks := Nb_Chunks + 1;
 270          Chunk := Chunk.Next;
 271       end loop;
 272
 273       --  Current Chunk information
 274
 275       Put_Line (
 276         "  Total size              : "
 277         & Mark_Id'Image (Chunk.Last)
 278         & " bytes");
 279       Put_Line (
 280         "  Current allocated space : "
 281         & Mark_Id'Image (Stack.Top - 1)
 282         & " bytes");
 283
 284       Put_Line (
 285         "  Number of Chunks       : "
 286         & Integer'Image (Nb_Chunks));
 287
 288       Put_Line (
 289         "  Default size of Chunks : "
 290         & SSE.Storage_Count'Image (Stack.Default_Size));
 291    end SS_Info;
 292
 293    -------------
 294    -- SS_Init --
 295    -------------
 296
 297    procedure SS_Init
 298      (Stk  : in out System.Address;
 299       Size : Natural := Default_Secondary_Stack_Size)
 300    is
 301       Stack : Stack_Ptr;
 302       Fixed_Stack : Fixed_Stack_Ptr;
 303
 304    begin
 305       if not SS_Ratio_Dynamic then
 306          Fixed_Stack      := To_Fixed (From_Addr (Stk));
 307          Fixed_Stack.Top  := Fixed_Stack.Mem'First;
 308
 309          if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then
 310             Fixed_Stack.Last := 0;
 311          else
 312             Fixed_Stack.Last := Mark_Id (Size) -
 313               2 * Mark_Id'Max_Size_In_Storage_Elements;
 314          end if;
 315
 316          return;
 317       end if;
 318
 319       Stack               := new Stack_Id;
 320       Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
 321       Stack.Top           := 1;
 322       Stack.Default_Size  := SSE.Storage_Count (Size);
 323
 324       Stk := To_Addr (Stack);
 325    end SS_Init;
 326
 327    -------------
 328    -- SS_Mark --
 329    -------------
 330
 331    function SS_Mark return Mark_Id is
 332    begin
 333       return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top;
 334    end SS_Mark;
 335
 336    ----------------
 337    -- SS_Release --
 338    ----------------
 339
 340    procedure SS_Release (M : Mark_Id) is
 341    begin
 342       From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M;
 343    end SS_Release;
 344
 345    -------------------------
 346    -- Package Elaboration --
 347    -------------------------
 348
 349    --  Allocate a secondary stack for the main program to use.
 350    --  We make sure that the stack has maximum alignment. Some systems require
 351    --  this (e.g. Sun), and in any case it is a good idea for efficiency.
 352
 353    Stack : aliased Stack_Id;
 354    for Stack'Alignment use Standard'Maximum_Alignment;
 355
 356    Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size);
 357    for Chunk'Alignment use Standard'Maximum_Alignment;
 358
 359    Chunk_Address : System.Address;
 360
 361 begin
 362    if SS_Ratio_Dynamic then
 363       Stack.Top           := 1;
 364       Stack.Current_Chunk := Chunk'Access;
 365       Stack.Default_Size  := Default_Secondary_Stack_Size;
 366       System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
 367
 368    else
 369       Chunk_Address := Chunk'Address;
 370       SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
 371       System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
 372    end if;
 373 end System.Secondary_Stack;