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