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