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-2009, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Compiler_Unit;
  33
  34 with System.Soft_Links;
  35 with System.Parameters;
  36 with Ada.Unchecked_Conversion;
  37 with Ada.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 Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
 120    --  Free a dynamically allocated chunk
 121
 122    function To_Stack_Ptr is new
 123      Ada.Unchecked_Conversion (Address, Stack_Ptr);
 124    function To_Addr is new
 125      Ada.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 structure
 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      Ada.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 eventually 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
 306               new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr);
 307
 308          begin
 309             Chunk := Stack.Current_Chunk;
 310
 311             while Chunk.Prev /= null loop
 312                Chunk := Chunk.Prev;
 313             end loop;
 314
 315             while Chunk.Next /= null loop
 316                Chunk := Chunk.Next;
 317                Free (Chunk.Prev);
 318             end loop;
 319
 320             Free (Chunk);
 321             Free (Stack);
 322             Stk := Null_Address;
 323          end;
 324       end if;
 325    end SS_Free;
 326
 327    ----------------
 328    -- SS_Get_Max --
 329    ----------------
 330
 331    function SS_Get_Max return Long_Long_Integer is
 332    begin
 333       if SS_Ratio_Dynamic then
 334          return -1;
 335       else
 336          declare
 337             Fixed_Stack : constant Fixed_Stack_Ptr :=
 338                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 339          begin
 340             return Long_Long_Integer (Fixed_Stack.Max);
 341          end;
 342       end if;
 343    end SS_Get_Max;
 344
 345    -------------
 346    -- SS_Info --
 347    -------------
 348
 349    procedure SS_Info is
 350    begin
 351       Put_Line ("Secondary Stack information:");
 352
 353       --  Case of fixed secondary stack
 354
 355       if not SS_Ratio_Dynamic then
 356          declare
 357             Fixed_Stack : constant Fixed_Stack_Ptr :=
 358                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 359
 360          begin
 361             Put_Line (
 362                       "  Total size              : "
 363                       & SS_Ptr'Image (Fixed_Stack.Last)
 364                       & " bytes");
 365
 366             Put_Line (
 367                       "  Current allocated space : "
 368                       & SS_Ptr'Image (Fixed_Stack.Top - 1)
 369                       & " bytes");
 370          end;
 371
 372       --  Case of dynamically allocated secondary stack
 373
 374       else
 375          declare
 376             Stack     : constant Stack_Ptr :=
 377                           To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 378             Nb_Chunks : Integer   := 1;
 379             Chunk     : Chunk_Ptr := Stack.Current_Chunk;
 380
 381          begin
 382             while Chunk.Prev /= null loop
 383                Chunk := Chunk.Prev;
 384             end loop;
 385
 386             while Chunk.Next /= null loop
 387                Nb_Chunks := Nb_Chunks + 1;
 388                Chunk := Chunk.Next;
 389             end loop;
 390
 391             --  Current Chunk information
 392
 393             Put_Line (
 394                       "  Total size              : "
 395                       & SS_Ptr'Image (Chunk.Last)
 396                       & " bytes");
 397
 398             Put_Line (
 399                       "  Current allocated space : "
 400                       & SS_Ptr'Image (Stack.Top - 1)
 401                       & " bytes");
 402
 403             Put_Line (
 404                       "  Number of Chunks       : "
 405                       & Integer'Image (Nb_Chunks));
 406
 407             Put_Line (
 408                       "  Default size of Chunks : "
 409                       & SSE.Storage_Count'Image (Stack.Default_Size));
 410          end;
 411       end if;
 412    end SS_Info;
 413
 414    -------------
 415    -- SS_Init --
 416    -------------
 417
 418    procedure SS_Init
 419      (Stk  : in out Address;
 420       Size : Natural := Default_Secondary_Stack_Size)
 421    is
 422    begin
 423       --  Case of fixed size secondary stack
 424
 425       if not SS_Ratio_Dynamic then
 426          declare
 427             Fixed_Stack : constant Fixed_Stack_Ptr :=
 428                             To_Fixed_Stack_Ptr (Stk);
 429
 430          begin
 431             Fixed_Stack.Top  := 0;
 432             Fixed_Stack.Max  := 0;
 433
 434             if Size < Dummy_Fixed_Stack.Mem'Position then
 435                Fixed_Stack.Last := 0;
 436             else
 437                Fixed_Stack.Last :=
 438                  SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
 439             end if;
 440          end;
 441
 442       --  Case of dynamically allocated secondary stack
 443
 444       else
 445          declare
 446             Stack : Stack_Ptr;
 447          begin
 448             Stack               := new Stack_Id;
 449             Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
 450             Stack.Top           := 1;
 451             Stack.Default_Size  := SSE.Storage_Count (Size);
 452             Stk := To_Addr (Stack);
 453          end;
 454       end if;
 455    end SS_Init;
 456
 457    -------------
 458    -- SS_Mark --
 459    -------------
 460
 461    function SS_Mark return Mark_Id is
 462       Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
 463    begin
 464       if SS_Ratio_Dynamic then
 465          return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
 466       else
 467          return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
 468       end if;
 469    end SS_Mark;
 470
 471    ----------------
 472    -- SS_Release --
 473    ----------------
 474
 475    procedure SS_Release (M : Mark_Id) is
 476    begin
 477       if SS_Ratio_Dynamic then
 478          To_Stack_Ptr (M.Sstk).Top := M.Sptr;
 479       else
 480          To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
 481       end if;
 482    end SS_Release;
 483
 484    -------------------------
 485    -- Package Elaboration --
 486    -------------------------
 487
 488    --  Allocate a secondary stack for the main program to use
 489
 490    --  We make sure that the stack has maximum alignment. Some systems require
 491    --  this (e.g. Sparc), and in any case it is a good idea for efficiency.
 492
 493    Stack : aliased Stack_Id;
 494    for Stack'Alignment use Standard'Maximum_Alignment;
 495
 496    Static_Secondary_Stack_Size : constant := 10 * 1024;
 497    --  Static_Secondary_Stack_Size must be static so that Chunk is allocated
 498    --  statically, and not via dynamic memory allocation.
 499
 500    Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size);
 501    for Chunk'Alignment use Standard'Maximum_Alignment;
 502    --  Default chunk used, unless gnatbind -D is specified with a value
 503    --  greater than Static_Secondary_Stack_Size
 504
 505 begin
 506    declare
 507       Chunk_Address : Address;
 508       Chunk_Access  : Chunk_Ptr;
 509
 510    begin
 511       if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then
 512
 513          --  Normally we allocate the secondary stack for the main program
 514          --  statically, using the default secondary stack size.
 515
 516          Chunk_Access := Chunk'Access;
 517
 518       else
 519          --  Default_Secondary_Stack_Size was increased via gnatbind -D, so we
 520          --  need to allocate a chunk dynamically.
 521
 522          Chunk_Access :=
 523            new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
 524       end if;
 525
 526       if SS_Ratio_Dynamic then
 527          Stack.Top           := 1;
 528          Stack.Current_Chunk := Chunk_Access;
 529          Stack.Default_Size  :=
 530            SSE.Storage_Offset (Default_Secondary_Stack_Size);
 531          System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
 532
 533       else
 534          Chunk_Address := Chunk_Access.all'Address;
 535          SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
 536          System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
 537       end if;
 538    end;
 539 end System.Secondary_Stack;