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