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