gcc/ada/s-finimp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --    S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N   --
   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 with Ada.Exceptions;
  35 with Ada.Tags;
  36
  37 with System.Soft_Links;
  38
  39 with System.Restrictions;
  40
  41 package body System.Finalization_Implementation is
  42
  43    use Ada.Exceptions;
  44    use System.Finalization_Root;
  45
  46    package SSL renames System.Soft_Links;
  47
  48    use type SSE.Storage_Offset;
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    type RC_Ptr is access all Record_Controller;
  55
  56    function To_RC_Ptr is
  57      new Ada.Unchecked_Conversion (Address, RC_Ptr);
  58
  59    procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
  60    pragma Import
  61      (Ada, Raise_From_Controlled_Operation,
  62       "ada__exceptions__raise_from_controlled_operation");
  63    pragma No_Return (Raise_From_Controlled_Operation);
  64    --  Raise Program_Error from an exception that occurred during an Adjust or
  65    --  Finalize operation. We use this rather kludgy Ada Import interface
  66    --  because this procedure is not available in the visible part of the
  67    --  Ada.Exceptions spec.
  68
  69    procedure Raise_From_Finalize
  70      (L          : Finalizable_Ptr;
  71       From_Abort : Boolean;
  72       E_Occ      : Exception_Occurrence);
  73    --  Deal with an exception raised during finalization of a list. L is a
  74    --  pointer to the list of element not yet finalized. From_Abort is true
  75    --  if the finalization actions come from an abort rather than a normal
  76    --  exit. E_Occ represents the exception being raised.
  77
  78    function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
  79    pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
  80
  81    function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
  82      return SSE.Storage_Count;
  83    pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
  84
  85    function Get_Deep_Controller (Obj : System.Address) return RC_Ptr;
  86    --  Given the address (obj) of a tagged object, return a
  87    --  pointer to the record controller of this object.
  88
  89    ------------
  90    -- Adjust --
  91    ------------
  92
  93    procedure Adjust (Object : in out Record_Controller) is
  94
  95       First_Comp : Finalizable_Ptr;
  96       My_Offset : constant SSE.Storage_Offset :=
  97                     Object.My_Address - Object'Address;
  98
  99       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
 100       --  Subtract the offset to the pointer
 101
 102       procedure Reverse_Adjust (P : Finalizable_Ptr);
 103       --  Ajust the components in the reverse order in which they are stored
 104       --  on the finalization list. (Adjust and Finalization are not done in
 105       --  the same order)
 106
 107       ----------------
 108       -- Ptr_Adjust --
 109       ----------------
 110
 111       procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
 112       begin
 113          if Ptr /= null then
 114             Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset);
 115          end if;
 116       end Ptr_Adjust;
 117
 118       --------------------
 119       -- Reverse_Adjust --
 120       --------------------
 121
 122       procedure Reverse_Adjust (P : Finalizable_Ptr) is
 123       begin
 124          if P /= null then
 125             Ptr_Adjust (P.Next);
 126             Reverse_Adjust (P.Next);
 127             Adjust (P.all);
 128             Object.F := P;   --  Successfully adjusted, so place in list.
 129          end if;
 130       end Reverse_Adjust;
 131
 132    --  Start of processing for Adjust
 133
 134    begin
 135       --  Adjust the components and their finalization pointers next. We must
 136       --  protect against an exception in some call to Adjust, so we keep
 137       --  pointing to the list of successfully adjusted components, which can
 138       --  be finalized if an exception is raised.
 139
 140       First_Comp := Object.F;
 141       Object.F := null;               --  nothing adjusted yet.
 142       Ptr_Adjust (First_Comp);        --  set addresss of first component.
 143       Reverse_Adjust (First_Comp);
 144
 145       --  Then Adjust the controller itself
 146
 147       Object.My_Address := Object'Address;
 148
 149    exception
 150       when others =>
 151          --  Finalize those components that were successfully adjusted, and
 152          --  propagate exception. The object itself is not yet attached to
 153          --  global finalization list, so we cannot rely on the outer call to
 154          --  Clean to take care of these components.
 155
 156          Finalize (Object);
 157          raise;
 158    end Adjust;
 159
 160    --------------------------
 161    -- Attach_To_Final_List --
 162    --------------------------
 163
 164    procedure Attach_To_Final_List
 165      (L       : in out Finalizable_Ptr;
 166       Obj     : in out Finalizable;
 167       Nb_Link : Short_Short_Integer)
 168    is
 169    begin
 170       --  Simple case: attachment to a one way list
 171
 172       if Nb_Link = 1 then
 173          Obj.Next := L;
 174          L        := Obj'Unchecked_Access;
 175
 176       --  Dynamically allocated objects: they are attached to a doubly linked
 177       --  list, so that an element can be finalized at any moment by means of
 178       --  an unchecked deallocation. Attachment is protected against
 179       --  multi-threaded access.
 180
 181       elsif Nb_Link = 2 then
 182
 183          --  Raise Program_Error if we're trying to allocate an object in a
 184          --  collection whose finalization has already started.
 185
 186          if L = Collection_Finalization_Started then
 187             raise Program_Error with
 188               "allocation after collection finalization started";
 189          end if;
 190
 191          Locked_Processing : begin
 192             SSL.Lock_Task.all;
 193             Obj.Next    := L.Next;
 194             Obj.Prev    := L.Next.Prev;
 195             L.Next.Prev := Obj'Unchecked_Access;
 196             L.Next      := Obj'Unchecked_Access;
 197             SSL.Unlock_Task.all;
 198
 199          exception
 200             when others =>
 201                SSL.Unlock_Task.all;
 202                raise;
 203          end Locked_Processing;
 204
 205       --  Attachment of arrays to the final list (used only for objects
 206       --  returned by function). Obj, in this case is the last element,
 207       --  but all other elements are already threaded after it. We just
 208       --  attach the rest of the final list at the end of the array list.
 209
 210       elsif Nb_Link = 3 then
 211          declare
 212             P : Finalizable_Ptr := Obj'Unchecked_Access;
 213
 214          begin
 215             while P.Next /= null loop
 216                P := P.Next;
 217             end loop;
 218
 219             P.Next := L;
 220             L := Obj'Unchecked_Access;
 221          end;
 222
 223       --  Make the object completely unattached (case of a library-level,
 224       --  Finalize_Storage_Only object).
 225
 226       elsif Nb_Link = 4 then
 227          Obj.Prev := null;
 228          Obj.Next := null;
 229       end if;
 230    end Attach_To_Final_List;
 231
 232    ---------------------
 233    -- Deep_Tag_Attach --
 234    ----------------------
 235
 236    procedure Deep_Tag_Attach
 237      (L : in out SFR.Finalizable_Ptr;
 238       A : System.Address;
 239       B : Short_Short_Integer)
 240    is
 241       V          : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
 242       Controller : constant RC_Ptr := Get_Deep_Controller (A);
 243
 244    begin
 245       if Controller /= null then
 246          Attach_To_Final_List (L, Controller.all, B);
 247       end if;
 248
 249       --  Is controlled
 250
 251       if V.all in Finalizable then
 252          Attach_To_Final_List (L, V.all, B);
 253       end if;
 254    end Deep_Tag_Attach;
 255
 256    -----------------------------
 257    -- Detach_From_Final_List --
 258    -----------------------------
 259
 260    --  We know that the detach object is neither at the beginning nor at the
 261    --  end of the list, thank's to the dummy First and Last Elements but the
 262    --  object may not be attached at all if it is Finalize_Storage_Only
 263
 264    procedure Detach_From_Final_List (Obj : in out Finalizable) is
 265    begin
 266
 267       --  When objects are not properly attached to a doubly linked list do
 268       --  not try to detach them. The only case where it can happen is when
 269       --  dealing with Finalize_Storage_Only objects which are not always
 270       --  attached to the finalization list.
 271
 272       if Obj.Next /= null and then Obj.Prev /= null then
 273          SSL.Lock_Task.all;
 274          Obj.Next.Prev := Obj.Prev;
 275          Obj.Prev.Next := Obj.Next;
 276          SSL.Unlock_Task.all;
 277       end if;
 278
 279    exception
 280       when others =>
 281          SSL.Unlock_Task.all;
 282          raise;
 283    end Detach_From_Final_List;
 284
 285    --------------
 286    -- Finalize --
 287    --------------
 288
 289    procedure Finalize   (Object : in out Limited_Record_Controller) is
 290    begin
 291       Finalize_List (Object.F);
 292    end Finalize;
 293
 294    --------------------------
 295    -- Finalize_Global_List --
 296    --------------------------
 297
 298    procedure Finalize_Global_List is
 299    begin
 300       --  There are three case here:
 301
 302       --  a. the application uses tasks, in which case Finalize_Global_Tasks
 303       --     will defer abort.
 304
 305       --  b. the application doesn't use tasks but uses other tasking
 306       --     constructs, such as ATCs and protected objects. In this case,
 307       --     the binder will call Finalize_Global_List instead of
 308       --     Finalize_Global_Tasks, letting abort undeferred, and leading
 309       --     to assertion failures in the GNULL
 310
 311       --  c. the application doesn't use any tasking construct in which case
 312       --     deferring abort isn't necessary.
 313
 314       --  Until another solution is found to deal with case b, we need to
 315       --  call abort_defer here to pass the checks, but we do not need to
 316       --  undefer abort, since Finalize_Global_List is the last procedure
 317       --  called before exiting the partition.
 318
 319       SSL.Abort_Defer.all;
 320       Finalize_List (Global_Final_List);
 321    end Finalize_Global_List;
 322
 323    -------------------
 324    -- Finalize_List --
 325    -------------------
 326
 327    procedure Finalize_List (L : Finalizable_Ptr) is
 328       P : Finalizable_Ptr := L;
 329       Q : Finalizable_Ptr;
 330
 331       type Fake_Exception_Occurence is record
 332          Id : Exception_Id;
 333       end record;
 334       type Ptr is access all Fake_Exception_Occurence;
 335
 336       function To_Ptr is new
 337         Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
 338
 339       X :  Exception_Id := Null_Id;
 340
 341    begin
 342       --  If abort is allowed, we get the current exception before starting
 343       --  to finalize in order to check if we are in the abort case if an
 344       --  exception is raised. When abort is not allowed, avoid accessing the
 345       --  current exception since this can be a pretty costly operation in
 346       --  programs using controlled types heavily.
 347
 348       if System.Restrictions.Abort_Allowed then
 349          X := To_Ptr (SSL.Get_Current_Excep.all).Id;
 350       end if;
 351
 352       while P /= null loop
 353          Q := P.Next;
 354          Finalize (P.all);
 355          P := Q;
 356       end loop;
 357
 358    exception
 359       when E_Occ : others =>
 360          Raise_From_Finalize (
 361            Q,
 362            X = Standard'Abort_Signal'Identity,
 363            E_Occ);
 364    end Finalize_List;
 365
 366    ------------------
 367    -- Finalize_One --
 368    ------------------
 369
 370    procedure Finalize_One (Obj : in out  Finalizable) is
 371    begin
 372       Detach_From_Final_List (Obj);
 373       Finalize (Obj);
 374    exception
 375       when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
 376    end Finalize_One;
 377
 378    -------------------------
 379    -- Get_Deep_Controller --
 380    -------------------------
 381
 382    function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is
 383       The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag;
 384       Offset  : SSE.Storage_Offset := RC_Offset (The_Tag);
 385
 386    begin
 387       --  Fetch the controller from the Parent or above if necessary
 388       --  when there are no controller at this level
 389
 390       while Offset = -2 loop
 391          The_Tag := Ada.Tags.Parent_Tag (The_Tag);
 392          Offset  := RC_Offset (The_Tag);
 393       end loop;
 394
 395       --  No Controlled component case
 396
 397       if Offset = 0 then
 398          return null;
 399
 400       --  The _controller Offset is known statically
 401
 402       elsif Offset > 0 then
 403          return To_RC_Ptr (Obj + Offset);
 404
 405       --  At this stage, we know that the controller is part of the
 406       --  ancestor corresponding to the tag "The_Tag" and that its parent
 407       --  is variable sized. We assume that the _controller is the first
 408       --  compoment right after the parent.
 409
 410       --  ??? note that it may not be true if there are new discriminants
 411
 412       else --  Offset = -1
 413
 414          declare
 415             --  define a faked record controller to avoid generating
 416             --  unnecessary expanded code for controlled types
 417
 418             type Faked_Record_Controller is record
 419                Tag, Prec, Next : Address;
 420             end record;
 421
 422             --  Reconstruction of a type with characteristics
 423             --  comparable to the original type
 424
 425             D : constant := SSE.Storage_Offset (Storage_Unit - 1);
 426
 427             type Parent_Type is new SSE.Storage_Array
 428                    (1 .. (Parent_Size (Obj, The_Tag) + D) /
 429                             SSE.Storage_Offset (Storage_Unit));
 430             for Parent_Type'Alignment use Address'Alignment;
 431
 432             type Faked_Type_Of_Obj is record
 433                Parent : Parent_Type;
 434                Controller : Faked_Record_Controller;
 435             end record;
 436
 437             type Obj_Ptr is access all Faked_Type_Of_Obj;
 438             function To_Obj_Ptr is
 439               new Ada.Unchecked_Conversion (Address, Obj_Ptr);
 440
 441          begin
 442             return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
 443          end;
 444       end if;
 445    end Get_Deep_Controller;
 446
 447    ----------------
 448    -- Initialize --
 449    ----------------
 450
 451    procedure Initialize (Object : in out Limited_Record_Controller) is
 452       pragma Warnings (Off, Object);
 453    begin
 454       null;
 455    end Initialize;
 456
 457    procedure Initialize (Object : in out Record_Controller) is
 458    begin
 459       Object.My_Address := Object'Address;
 460    end Initialize;
 461
 462    ---------------------
 463    -- Move_Final_List --
 464    ---------------------
 465
 466    procedure Move_Final_List
 467      (From : in out SFR.Finalizable_Ptr;
 468       To   : Finalizable_Ptr_Ptr)
 469    is
 470    begin
 471       --  This is currently called at the end of the return statement, and the
 472       --  caller does NOT defer aborts. We need to defer aborts to prevent
 473       --  mangling the finalization lists.
 474
 475       SSL.Abort_Defer.all;
 476
 477       --  Put the return statement's finalization list onto the caller's one,
 478       --  thus transferring responsibility for finalization of the return
 479       --  object to the caller.
 480
 481       Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
 482
 483       --  Empty the return statement's finalization list, so that when the
 484       --  cleanup code executes, there will be nothing to finalize.
 485       From := null;
 486
 487       SSL.Abort_Undefer.all;
 488    end Move_Final_List;
 489
 490    -------------------------
 491    -- Raise_From_Finalize --
 492    -------------------------
 493
 494    procedure Raise_From_Finalize
 495      (L          : Finalizable_Ptr;
 496       From_Abort : Boolean;
 497       E_Occ      : Exception_Occurrence)
 498    is
 499       P   : Finalizable_Ptr := L;
 500       Q   : Finalizable_Ptr;
 501
 502    begin
 503       --  We already got an exception. We now finalize the remainder of
 504       --  the list, ignoring all further exceptions.
 505
 506       while P /= null loop
 507          Q := P.Next;
 508
 509          begin
 510             Finalize (P.all);
 511          exception
 512             when others => null;
 513          end;
 514
 515          P := Q;
 516       end loop;
 517
 518       if From_Abort then
 519          --  If finalization from an Abort, then nothing to do
 520
 521          null;
 522
 523       else
 524          --  Else raise Program_Error with an appropriate message
 525
 526          Raise_From_Controlled_Operation (E_Occ);
 527       end if;
 528    end Raise_From_Finalize;
 529
 530 --  Initialization of package, set Adafinal soft link
 531
 532 begin
 533    SSL.Finalize_Global_List := Finalize_Global_List'Access;
 534
 535 end System.Finalization_Implementation;