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-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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    --  There are two entirely different implementations of the secondary
  49    --  stack mechanism in this unit, and this Boolean is used to select
  50    --  between them (at compile time, so the generated code will contain
  51    --  only the code for the desired variant). If SS_Ratio_Dynamic is
  52    --  True, then the secondary stack is dynamically allocated from the
  53    --  heap in a linked list of chunks. If SS_Ration_Dynamic is False,
  54    --  then the secondary stack is allocated statically by grabbing a
  55    --  section of the primary stack and using it for this purpose.
  56
  57    type Memory is array (SS_Ptr range <>) of SSE.Storage_Element;
  58    for Memory'Alignment use Standard'Maximum_Alignment;
  59    --  This is the type used for actual allocation of secondary stack
  60    --  areas. We require maximum alignment for all such allocations.
  61
  62    ---------------------------------------------------------------
  63    -- Data Structures for Dynamically Allocated Secondary Stack --
  64    ---------------------------------------------------------------
  65
  66    --  The following is a diagram of the data structures used for the
  67    --  case of a dynamically allocated secondary stack, where the stack
  68    --  is allocated as a linked list of chunks allocated from the heap.
  69
  70    --                                      +------------------+
  71    --                                      |       Next       |
  72    --                                      +------------------+
  73    --                                      |                  | Last (200)
  74    --                                      |                  |
  75    --                                      |                  |
  76    --                                      |                  |
  77    --                                      |                  |
  78    --                                      |                  |
  79    --                                      |                  | First (101)
  80    --                                      +------------------+
  81    --                         +----------> |          |       |
  82    --                         |            +----------+-------+
  83    --                         |                    |  |
  84    --                         |                    ^  V
  85    --                         |                    |  |
  86    --                         |            +-------+----------+
  87    --                         |            |       |          |
  88    --                         |            +------------------+
  89    --                         |            |                  | Last (100)
  90    --                         |            |         C        |
  91    --                         |            |         H        |
  92    --    +-----------------+  |  +-------->|         U        |
  93    --    |  Current_Chunk -|--+  |         |         N        |
  94    --    +-----------------+     |         |         K        |
  95    --    |       Top      -|-----+         |                  | First (1)
  96    --    +-----------------+               +------------------+
  97    --    | Default_Size    |               |       Prev       |
  98    --    +-----------------+               +------------------+
  99    --
 100
 101    type Chunk_Id (First, Last : SS_Ptr);
 102    type Chunk_Ptr is access all Chunk_Id;
 103
 104    type Chunk_Id (First, Last : SS_Ptr) is record
 105       Prev, Next : Chunk_Ptr;
 106       Mem        : Memory (First .. Last);
 107    end record;
 108
 109    type Stack_Id is record
 110       Top           : SS_Ptr;
 111       Default_Size  : SSE.Storage_Count;
 112       Current_Chunk : Chunk_Ptr;
 113    end record;
 114
 115    type Stack_Ptr is access Stack_Id;
 116    --  Pointer to record used to represent a dynamically allocated secondary
 117    --  stack descriptor for a secondary stack chunk.
 118
 119    procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
 120    --  Free a dynamically allocated chunk
 121
 122    function To_Stack_Ptr is new
 123      Unchecked_Conversion (Address, Stack_Ptr);
 124    function To_Addr is new
 125      Unchecked_Conversion (Stack_Ptr, Address);
 126    --  Convert to and from address stored in task data structures
 127
 128    --------------------------------------------------------------
 129    -- Data Structures for Statically Allocated Secondary Stack --
 130    --------------------------------------------------------------
 131
 132    --  For the static case, the secondary stack is a single contiguous
 133    --  chunk of storage, carved out of the primary stack, and represented
 134    --  by the following data strcuture
 135
 136    type Fixed_Stack_Id is record
 137       Top : SS_Ptr;
 138       --  Index of next available location in Mem. This is initialized to
 139       --  0, and then incremented on Allocate, and Decremented on Release.
 140
 141       Last : SS_Ptr;
 142       --  Length of usable Mem array, which is thus the index past the
 143       --  last available location in Mem. Mem (Last-1) can be used. This
 144       --  is used to check that the stack does not overflow.
 145
 146       Max : SS_Ptr;
 147       --  Maximum value of Top. Initialized to 0, and then may be incremented
 148       --  on Allocate, but is never Decremented. The last used location will
 149       --  be Mem (Max - 1), so Max is the maximum count of used stack space.
 150
 151       Mem : Memory (0 .. 0);
 152       --  This is the area that is actually used for the secondary stack.
 153       --  Note that the upper bound is a dummy value properly defined by
 154       --  the value of Last. We never actually allocate objects of type
 155       --  Fixed_Stack_Id, so the bounds declared here do not matter.
 156    end record;
 157
 158    Dummy_Fixed_Stack : Fixed_Stack_Id;
 159    pragma Warnings (Off, Dummy_Fixed_Stack);
 160    --  Well it is not quite true that we never allocate an object of the
 161    --  type. This dummy object is allocated for the purpose of getting the
 162    --  offset of the Mem field via the 'Position attribute (such a nuisance
 163    --  that we cannot apply this to a field of a type!)
 164
 165    type Fixed_Stack_Ptr is access Fixed_Stack_Id;
 166    --  Pointer to record used to describe statically allocated sec stack
 167
 168    function To_Fixed_Stack_Ptr is new
 169      Unchecked_Conversion (Address, Fixed_Stack_Ptr);
 170    --  Convert from address stored in task data structures
 171
 172    --------------
 173    -- Allocate --
 174    --------------
 175
 176    procedure SS_Allocate
 177      (Addr         : out Address;
 178       Storage_Size : SSE.Storage_Count)
 179    is
 180       Max_Align    : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
 181       Max_Size     : constant SS_Ptr :=
 182                        ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align)
 183                          * Max_Align;
 184
 185    begin
 186       --  Case of fixed allocation secondary stack
 187
 188       if not SS_Ratio_Dynamic then
 189          declare
 190             Fixed_Stack : constant Fixed_Stack_Ptr :=
 191                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 192
 193          begin
 194             --  Check if max stack usage is increasing
 195
 196             if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then
 197
 198                --  If so, check if max size is exceeded
 199
 200                if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
 201                   raise Storage_Error;
 202                end if;
 203
 204                --  Record new max usage
 205
 206                Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;
 207             end if;
 208
 209             --  Set resulting address and update top of stack pointer
 210
 211             Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
 212             Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;
 213          end;
 214
 215       --  Case of dynamically allocated secondary stack
 216
 217       else
 218          declare
 219             Stack : constant Stack_Ptr :=
 220                       To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 221             Chunk : Chunk_Ptr;
 222
 223             To_Be_Released_Chunk : Chunk_Ptr;
 224
 225          begin
 226             Chunk := Stack.Current_Chunk;
 227
 228             --  The Current_Chunk may not be the good one if a lot of release
 229             --  operations have taken place. So go down the stack if necessary
 230
 231             while Chunk.First > Stack.Top loop
 232                Chunk := Chunk.Prev;
 233             end loop;
 234
 235             --  Find out if the available memory in the current chunk is
 236             --  sufficient, if not, go to the next one and eventally create
 237             --  the necessary room.
 238
 239             while Chunk.Last - Stack.Top + 1 < Max_Size loop
 240                if Chunk.Next /= null then
 241
 242                   --  Release unused non-first empty chunk
 243
 244                   if Chunk.Prev /= null and then Chunk.First = Stack.Top then
 245                      To_Be_Released_Chunk := Chunk;
 246                      Chunk := Chunk.Prev;
 247                      Chunk.Next := To_Be_Released_Chunk.Next;
 248                      To_Be_Released_Chunk.Next.Prev := Chunk;
 249                      Free (To_Be_Released_Chunk);
 250                   end if;
 251
 252                   --  Create new chunk of default size unless it is not
 253                   --  sufficient to satisfy the current request.
 254
 255                elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
 256                   Chunk.Next :=
 257                     new Chunk_Id
 258                       (First => Chunk.Last + 1,
 259                        Last  => Chunk.Last + SS_Ptr (Stack.Default_Size));
 260
 261                   Chunk.Next.Prev := Chunk;
 262
 263                   --  Otherwise create new chunk of requested size
 264
 265                else
 266                   Chunk.Next :=
 267                     new Chunk_Id
 268                       (First => Chunk.Last + 1,
 269                        Last  => Chunk.Last + Max_Size);
 270
 271                   Chunk.Next.Prev := Chunk;
 272                end if;
 273
 274                Chunk     := Chunk.Next;
 275                Stack.Top := Chunk.First;
 276             end loop;
 277
 278             --  Resulting address is the address pointed by Stack.Top
 279
 280             Addr                := Chunk.Mem (Stack.Top)'Address;
 281             Stack.Top           := Stack.Top + Max_Size;
 282             Stack.Current_Chunk := Chunk;
 283          end;
 284       end if;
 285    end SS_Allocate;
 286
 287    -------------
 288    -- SS_Free --
 289    -------------
 290
 291    procedure SS_Free (Stk : in out Address) is
 292    begin
 293       --  Case of statically allocated secondary stack, nothing to free
 294
 295       if not SS_Ratio_Dynamic then
 296          return;
 297
 298       --  Case of dynamically allocated secondary stack
 299
 300       else
 301          declare
 302             Stack : Stack_Ptr := To_Stack_Ptr (Stk);
 303             Chunk : Chunk_Ptr;
 304
 305             procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
 306
 307          begin
 308             Chunk := Stack.Current_Chunk;
 309
 310             while Chunk.Prev /= null loop
 311                Chunk := Chunk.Prev;
 312             end loop;
 313
 314             while Chunk.Next /= null loop
 315                Chunk := Chunk.Next;
 316                Free (Chunk.Prev);
 317             end loop;
 318
 319             Free (Chunk);
 320             Free (Stack);
 321             Stk := Null_Address;
 322          end;
 323       end if;
 324    end SS_Free;
 325
 326    ----------------
 327    -- SS_Get_Max --
 328    ----------------
 329
 330    function SS_Get_Max return Long_Long_Integer is
 331    begin
 332       if SS_Ratio_Dynamic then
 333          return -1;
 334       else
 335          declare
 336             Fixed_Stack : constant Fixed_Stack_Ptr :=
 337                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 338          begin
 339             return Long_Long_Integer (Fixed_Stack.Max);
 340          end;
 341       end if;
 342    end SS_Get_Max;
 343
 344    -------------
 345    -- SS_Info --
 346    -------------
 347
 348    procedure SS_Info is
 349    begin
 350       Put_Line ("Secondary Stack information:");
 351
 352       --  Case of fixed secondary stack
 353
 354       if not SS_Ratio_Dynamic then
 355          declare
 356             Fixed_Stack : constant Fixed_Stack_Ptr :=
 357                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 358
 359          begin
 360             Put_Line (
 361                       "  Total size              : "
 362                       & SS_Ptr'Image (Fixed_Stack.Last)
 363                       & " bytes");
 364
 365             Put_Line (
 366                       "  Current allocated space : "
 367                       & SS_Ptr'Image (Fixed_Stack.Top - 1)
 368                       & " bytes");
 369          end;
 370
 371       --  Case of dynamically allocated secondary stack
 372
 373       else
 374          declare
 375             Stack     : constant Stack_Ptr :=
 376                           To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 377             Nb_Chunks : Integer   := 1;
 378             Chunk     : Chunk_Ptr := Stack.Current_Chunk;
 379
 380          begin
 381             while Chunk.Prev /= null loop
 382                Chunk := Chunk.Prev;
 383             end loop;
 384
 385             while Chunk.Next /= null loop
 386                Nb_Chunks := Nb_Chunks + 1;
 387                Chunk := Chunk.Next;
 388             end loop;
 389
 390             --  Current Chunk information
 391
 392             Put_Line (
 393                       "  Total size              : "
 394                       & SS_Ptr'Image (Chunk.Last)
 395                       & " bytes");
 396
 397             Put_Line (
 398                       "  Current allocated space : "
 399                       & SS_Ptr'Image (Stack.Top - 1)
 400                       & " bytes");
 401
 402             Put_Line (
 403                       "  Number of Chunks       : "
 404                       & Integer'Image (Nb_Chunks));
 405
 406             Put_Line (
 407                       "  Default size of Chunks : "
 408                       & SSE.Storage_Count'Image (Stack.Default_Size));
 409          end;
 410       end if;
 411    end SS_Info;
 412
 413    -------------
 414    -- SS_Init --
 415    -------------
 416
 417    procedure SS_Init
 418      (Stk  : in out Address;
 419       Size : Natural := Default_Secondary_Stack_Size)
 420    is
 421    begin
 422       --  Case of fixed size secondary stack
 423
 424       if not SS_Ratio_Dynamic then
 425          declare
 426             Fixed_Stack : constant Fixed_Stack_Ptr :=
 427                             To_Fixed_Stack_Ptr (Stk);
 428
 429          begin
 430             Fixed_Stack.Top  := 0;
 431             Fixed_Stack.Max  := 0;
 432
 433             if Size < Dummy_Fixed_Stack.Mem'Position then
 434                Fixed_Stack.Last := 0;
 435             else
 436                Fixed_Stack.Last :=
 437                  SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
 438             end if;
 439          end;
 440
 441       --  Case of dynamically allocated secondary stack
 442
 443       else
 444          declare
 445             Stack : Stack_Ptr;
 446          begin
 447             Stack               := new Stack_Id;
 448             Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
 449             Stack.Top           := 1;
 450             Stack.Default_Size  := SSE.Storage_Count (Size);
 451             Stk := To_Addr (Stack);
 452          end;
 453       end if;
 454    end SS_Init;
 455
 456    -------------
 457    -- SS_Mark --
 458    -------------
 459
 460    function SS_Mark return Mark_Id is
 461       Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
 462    begin
 463       if SS_Ratio_Dynamic then
 464          return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
 465       else
 466          return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
 467       end if;
 468    end SS_Mark;
 469
 470    ----------------
 471    -- SS_Release --
 472    ----------------
 473
 474    procedure SS_Release (M : Mark_Id) is
 475    begin
 476       if SS_Ratio_Dynamic then
 477          To_Stack_Ptr (M.Sstk).Top := M.Sptr;
 478       else
 479          To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
 480       end if;
 481    end SS_Release;
 482
 483    -------------------------
 484    -- Package Elaboration --
 485    -------------------------
 486
 487    --  Allocate a secondary stack for the main program to use
 488
 489    --  We make sure that the stack has maximum alignment. Some systems require
 490    --  this (e.g. Sun), and in any case it is a good idea for efficiency.
 491
 492    Stack : aliased Stack_Id;
 493    for Stack'Alignment use Standard'Maximum_Alignment;
 494
 495    Chunk : aliased Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
 496    for Chunk'Alignment use Standard'Maximum_Alignment;
 497
 498    Chunk_Address : Address;
 499
 500 begin
 501    if SS_Ratio_Dynamic then
 502       Stack.Top           := 1;
 503       Stack.Current_Chunk := Chunk'Access;
 504       Stack.Default_Size  := SSE.Storage_Offset (Default_Secondary_Stack_Size);
 505       System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
 506
 507    else
 508       Chunk_Address := Chunk'Address;
 509       SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
 510       System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
 511    end if;
 512 end System.Secondary_Stack;