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