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