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